mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-30 11:58:22 +00:00
Compare commits
4
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
 Evgeny Poberezkin
|
692d829dca | ||
|
Evgeny Poberezkin
|
e10cec4c94 | ||
|
Evgeny Poberezkin
|
b9654fad31 | ||
|
Evgeny Poberezkin
|
0e7471ee00 |
@@ -63,7 +63,7 @@ jobs:
|
||||
mv $(cabal list-bin xftp) xftp-ubuntu-${{ matrix.platform_name}}
|
||||
|
||||
- name: Build changelog
|
||||
if: startsWith(github.ref, 'refs/tags/v')
|
||||
if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-22.04'
|
||||
id: build_changelog
|
||||
uses: mikepenz/release-changelog-builder-action@v1
|
||||
with:
|
||||
|
||||
-137
@@ -1,140 +1,3 @@
|
||||
# 6.1.3
|
||||
|
||||
SMP server: fix restoring notification credentials.
|
||||
|
||||
# 6.1.2
|
||||
|
||||
Servers: more reliable restoring of state.
|
||||
|
||||
SMP server: reduced memory usage and faster start.
|
||||
|
||||
Notifications: compensate for iOS notifications being droppted by Apple while device is offline (#1378):
|
||||
- Ntf server: send multiple SMP notifications in one iOS notification.
|
||||
- Agent: get multiple messages for one iOS notification.
|
||||
|
||||
# 6.1.1
|
||||
|
||||
SMP:
|
||||
- stop server faster (#1371)
|
||||
- add STORE error (#1372)
|
||||
|
||||
# 6.1.0
|
||||
|
||||
Version 6.1.0.7
|
||||
|
||||
SMP server and client:
|
||||
- transport block encryption (#1317).
|
||||
|
||||
Agent:
|
||||
- batch and optimize iOS notifications processing (#1308, #1311, #1313, #1316, #1330, #1331, #1333, #1337, #1346).
|
||||
- allow receiving multiple messages from single iOS notification (#1355, #1362).
|
||||
- prepare connection to accept to avoid race condition with events (#1365).
|
||||
- transport isolation mode "Session" (default) to use new SOCKS credentials when client restarts or SOCKS proxy configuration changes (#1321).
|
||||
|
||||
Ntf server:
|
||||
- control port (#1354).
|
||||
- enable pings on ntf subscriptions, to resubscribe on reconnection (#1353).
|
||||
|
||||
SMP server:
|
||||
- support multiple server ports (#1319).
|
||||
- support serving HTTPS and SMP transport on the same port (#1326, #1327).
|
||||
- persist iOS notifications to avoid losing them when Ntf server is offline (#1336, #1339, #1350).
|
||||
- fix lost notification subscriptions (#1347).
|
||||
- reject SKEY with different key earlier, at verification step (#1366).
|
||||
- pass server information via CLI during server initialization (#1356).
|
||||
- show version on server page (#1341).
|
||||
- explicit graceful shutdown on SIGINT (#1360).
|
||||
|
||||
XRCP (remote access protocol):
|
||||
- use SHA3-256 in hybrid key agreement (#1302).
|
||||
- session encryption with forward secrecy (#1328).
|
||||
|
||||
# 6.0.5
|
||||
|
||||
SMP agent:
|
||||
- support generic SOCKS proxy (without isolate-by-auth).
|
||||
- reduce max message sizes
|
||||
|
||||
# 6.0.4
|
||||
|
||||
SMP server:
|
||||
- better performance/memory: fewer map updates on re-subscriptions (#1297), split and reduce STM transactions (#1294)
|
||||
- send DELD when subscribed queue is deleted (#1312)
|
||||
- add created/updated/used date to queues to manage expiration (#1306)
|
||||
|
||||
XFTP server: truncate file creation time to 1 hour (#1310)
|
||||
|
||||
Servers:
|
||||
- bind control port only to 127.0.0.1 for better security in case of firewall misconfiguration (#1280)
|
||||
- reduce memory used for period stats (#1298)
|
||||
|
||||
Agent: process last notification from list (#1307)
|
||||
- report receive file error with redirected file ID, when redirect is present (#1304)
|
||||
- special error when deleted user record is not in database (#1303)
|
||||
- fix race when sending a message to the deleted connection (#1296)
|
||||
- support for multiple messages in a single notification
|
||||
|
||||
Ntf server:
|
||||
- only use SOCKS proxy for servers without public address (#1314)
|
||||
|
||||
# 6.0.3
|
||||
|
||||
Agent:
|
||||
- fix possible stuck queue rotation (#1290).
|
||||
|
||||
SMP server:
|
||||
- batch END responses when subscribed client switches to reduce server and client traffic.
|
||||
- reduce STM transactions for better performance.
|
||||
- add stats for END events and for SUB/DEL event batches.
|
||||
- remove "expensive" stats to save memory.
|
||||
|
||||
# 6.0.2
|
||||
|
||||
SMP agent:
|
||||
- fix stuck connection commands when a server is not responding.
|
||||
- store query errors, reduce slow query threshold to 1ms.
|
||||
|
||||
Notification server:
|
||||
- reduce PING interval to 1 minute.
|
||||
- fix subscriptions disabled on race condition (only mark subscriptions with END status when received via the active connection).
|
||||
|
||||
# 6.0.1
|
||||
|
||||
SMP agent:
|
||||
- support changing user of the new connection.
|
||||
- do not start delivery workers when there are no messages to deliver.
|
||||
- enable notifications for all connections.
|
||||
- combine database transactions when subscribing.
|
||||
|
||||
SMP server:
|
||||
- safe compacting of store log.
|
||||
- fix possible race when creating client that might lead to memory leak.
|
||||
|
||||
Dependencies: upgrade tls to 1.9
|
||||
|
||||
# 6.0.0
|
||||
|
||||
Version 6.0.0.8
|
||||
|
||||
Agent:
|
||||
- enabled fast handshake support.
|
||||
- batch-send multiple messages in each connection.
|
||||
- resume subscriptions as soon as agent moves to foreground or as network connection resumes.
|
||||
- "known" servers to determine whether to use SMP proxy.
|
||||
- retry on SMP proxy NO_SESSION error.
|
||||
- fixes to notification subscriptions.
|
||||
- persistent server statistics.
|
||||
- better concurrency.
|
||||
|
||||
SMP server:
|
||||
- reduce threads usage.
|
||||
- additional statistics.
|
||||
- improve disabling inactive clients.
|
||||
- additional control port commands for monitoring.
|
||||
|
||||
Notification server:
|
||||
- support onion-only SMP servers.
|
||||
|
||||
# 5.8.2
|
||||
|
||||
Agent:
|
||||
|
||||
@@ -149,15 +149,8 @@ On Linux, you can deploy smp and xftp server using Docker. This will download im
|
||||
You can install and setup servers automatically using our script:
|
||||
|
||||
```sh
|
||||
curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh &&\
|
||||
if echo '53fcdb4ceab324316e2c4cda7e84dbbb344f32550a65975a7895425e5a1be757 simplex-server-install.sh' | sha256sum -c; then
|
||||
chmod +x ./simplex-server-install.sh
|
||||
./simplex-server-install.sh
|
||||
rm ./simplex-server-install.sh
|
||||
else
|
||||
echo "SHA-256 checksum is incorrect!"
|
||||
rm ./simplex-server-install.sh
|
||||
fi
|
||||
curl --proto '=https' --tlsv1.2 -sSf https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/install.sh -o simplex-server-install.sh \
|
||||
&& if echo 'b8cf2be103f21f9461d9a500bcd3db06ab7d01d68871b07f4bd245195cbead1d simplex-server-install.sh' | sha256sum -c; then chmod +x ./simplex-server-install.sh && ./simplex-server-install.sh; rm ./simplex-server-install.sh; else echo "SHA-256 checksum is incorrect!" && rm ./simplex-server-install.sh; fi
|
||||
```
|
||||
|
||||
### Build from source
|
||||
|
||||
@@ -15,7 +15,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
setLogLevel LogInfo
|
||||
setLogLevel LogDebug -- change to LogError in production
|
||||
cfgPath <- getEnvPath "NTF_SERVER_CFG_PATH" defaultCfgPath
|
||||
logPath <- getEnvPath "NTF_SERVER_LOG_PATH" defaultLogPath
|
||||
withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath
|
||||
|
||||
@@ -19,4 +19,4 @@ main = do
|
||||
setLogLevel LogDebug
|
||||
cfgPath <- getEnvPath "SMP_SERVER_CFG_PATH" defaultCfgPath
|
||||
logPath <- getEnvPath "SMP_SERVER_LOG_PATH" defaultLogPath
|
||||
withGlobalLogging logCfg $ smpServerCLI_ Static.generateSite Static.serveStaticFiles Static.attachStaticFiles cfgPath logPath
|
||||
withGlobalLogging logCfg $ smpServerCLI_ Static.generateSite Static.serveStaticFiles cfgPath logPath
|
||||
|
||||
@@ -221,10 +221,6 @@
|
||||
Public information
|
||||
</h2>
|
||||
<table id="public-info">
|
||||
<tr class="text-grey-black dark:text-white text-base">
|
||||
<td>Server version:</td>
|
||||
<td>${version}</td>
|
||||
</tr>
|
||||
<tr class="text-grey-black dark:text-white text-base">
|
||||
<td>Source code:</td>
|
||||
<td><a href="${sourceCode}" target="_blank">${sourceCode}</a></td>
|
||||
@@ -295,12 +291,6 @@
|
||||
<td>${hostingEntity} (${hostingCountry})</td>
|
||||
</tr>
|
||||
</x-hosting>
|
||||
<x-hostingType>
|
||||
<tr class="text-grey-black dark:text-white text-base">
|
||||
<td>Hosting type:</td>
|
||||
<td>${hostingType}</td>
|
||||
</tr>
|
||||
</x-hostingType>
|
||||
<x-serverCountry>
|
||||
<tr class="text-grey-black dark:text-white text-base">
|
||||
<td>Server country:</td>
|
||||
|
||||
@@ -7,30 +7,22 @@ module Static where
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (toUpper)
|
||||
import Data.IORef (readIORef)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.String (fromString)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Network.Socket (getPeerName)
|
||||
import Network.Wai (Application)
|
||||
import qualified Network.Wai.Application.Static as S
|
||||
import qualified Network.Wai.Handler.Warp as W
|
||||
import qualified Network.Wai.Handler.Warp.Internal as WI
|
||||
import qualified Network.Wai.Handler.WarpTLS as WT
|
||||
import Network.Wai.Application.Static as S
|
||||
import Network.Wai.Handler.Warp as W
|
||||
import qualified Network.Wai.Handler.WarpTLS as W
|
||||
import Simplex.Messaging.Encoding.String (strEncode)
|
||||
import Simplex.Messaging.Server (AttachHTTP)
|
||||
import Simplex.Messaging.Server.Information
|
||||
import Simplex.Messaging.Server.Main (EmbeddedWebParams (..), WebHttpsParams (..))
|
||||
import Simplex.Messaging.Transport (simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import Static.Embedded as E
|
||||
import System.Directory (createDirectoryIfMissing)
|
||||
import System.FilePath
|
||||
import UnliftIO.Concurrent (forkFinally)
|
||||
import UnliftIO.Exception (bracket, finally)
|
||||
|
||||
serveStaticFiles :: EmbeddedWebParams -> IO ()
|
||||
serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams} = do
|
||||
@@ -39,44 +31,9 @@ serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
|
||||
W.runSettings (mkSettings port) (S.staticApp $ S.defaultFileServerSettings webStaticPath)
|
||||
forM_ webHttpsParams $ \WebHttpsParams {port, cert, key} -> flip forkFinally (\e -> logError $ "HTTPS server crashed: " <> tshow e) $ do
|
||||
logInfo $ "Serving static site on port " <> tshow port <> " (TLS)"
|
||||
WT.runTLS (WT.tlsSettings cert key) (mkSettings port) app
|
||||
W.runTLS (W.tlsSettings cert key) (mkSettings port) (S.staticApp $ S.defaultFileServerSettings webStaticPath)
|
||||
where
|
||||
app = staticFiles webStaticPath
|
||||
mkSettings port = W.setPort port warpSettings
|
||||
|
||||
-- | Prepare context and prepare HTTP handler for TLS connections that already passed TLS.handshake and ALPN check.
|
||||
attachStaticFiles :: FilePath -> (AttachHTTP -> IO ()) -> IO ()
|
||||
attachStaticFiles path action =
|
||||
-- Initialize global internal state for http server.
|
||||
WI.withII warpSettings $ \ii -> do
|
||||
action $ \socket cxt -> do
|
||||
-- Initialize internal per-connection resources.
|
||||
addr <- getPeerName socket
|
||||
withConnection addr cxt $ \(conn, transport) ->
|
||||
withTimeout ii conn $ \th ->
|
||||
-- Run Warp connection handler to process HTTP requests for static files.
|
||||
WI.serveConnection conn ii th addr transport warpSettings app
|
||||
where
|
||||
app = staticFiles path
|
||||
-- from warp-tls
|
||||
withConnection socket cxt = bracket (WT.attachConn socket cxt) (terminate . fst)
|
||||
-- from warp
|
||||
withTimeout ii conn =
|
||||
bracket
|
||||
(WI.registerKillThread (WI.timeoutManager ii) (WI.connClose conn))
|
||||
WI.cancel
|
||||
-- shared clean up
|
||||
terminate conn = WI.connClose conn `finally` (readIORef (WI.connWriteBuffer conn) >>= WI.bufFree)
|
||||
|
||||
warpSettings :: W.Settings
|
||||
warpSettings = W.setGracefulShutdownTimeout (Just 1) W.defaultSettings
|
||||
|
||||
staticFiles :: FilePath -> Application
|
||||
staticFiles root = S.staticApp settings
|
||||
where
|
||||
settings = (S.defaultFileServerSettings root)
|
||||
{ S.ssListing = Nothing
|
||||
}
|
||||
mkSettings port = setPort port defaultSettings
|
||||
|
||||
generateSite :: ServerInformation -> Maybe TransportHost -> FilePath -> IO ()
|
||||
generateSite si onionHost sitePath = do
|
||||
@@ -121,7 +78,6 @@ serverInformation ServerInformation {config, information} onionHost = render E.i
|
||||
where
|
||||
basic =
|
||||
[ ("sourceCode", Just . encodeUtf8 $ sourceCode spi),
|
||||
("version", Just $ B.pack simplexMQVersion),
|
||||
("website", encodeUtf8 <$> website spi)
|
||||
]
|
||||
conds ServerConditions {conditions, amendments} =
|
||||
@@ -153,8 +109,7 @@ serverInformation ServerInformation {config, information} onionHost = render E.i
|
||||
("hostingCountry", encodeUtf8 <$> country)
|
||||
]
|
||||
server =
|
||||
[ ("serverCountry", encodeUtf8 <$> serverCountry spi),
|
||||
("hostingType", (\s -> maybe s (\(c, rest) -> toUpper c `B.cons` rest) $ B.uncons s) . strEncode <$> hostingType spi)
|
||||
[ ("serverCountry", fmap encodeUtf8 $ serverCountry =<< information)
|
||||
]
|
||||
|
||||
-- Copy-pasted from simplex-chat Simplex.Chat.Types.Preferences
|
||||
|
||||
@@ -4,14 +4,6 @@ packages: .
|
||||
-- packages: . ../http2
|
||||
-- packages: . ../network-transport
|
||||
|
||||
-- package *
|
||||
-- coverage: True
|
||||
-- library-coverage: True
|
||||
|
||||
-- package attoparsec
|
||||
-- coverage: False
|
||||
-- library-coverage: False
|
||||
|
||||
index-state: 2023-12-12T00:00:00Z
|
||||
|
||||
package cryptostore
|
||||
@@ -36,17 +28,3 @@ source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/sqlcipher-simple.git
|
||||
tag: a46bd361a19376c5211f1058908fc0ae6bf42446
|
||||
|
||||
-- waiting for published warp-tls-3.4.7
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/yesodweb/wai.git
|
||||
tag: ec5e017d896a78e787a5acea62b37a4e677dec2e
|
||||
subdir: warp-tls
|
||||
|
||||
-- backported fork due http-5.0
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/wai.git
|
||||
tag: 2f6e5aa5f05ba9140ac99e195ee647b4f7d926b0
|
||||
subdir: warp
|
||||
|
||||
+21
-105
@@ -2,6 +2,10 @@
|
||||
set -eu
|
||||
|
||||
# Links to scripts/configs
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
|
||||
bin_smp="$bin/smp-server-ubuntu-20_04-x86-64"
|
||||
bin_xftp="$bin/xftp-server-ubuntu-20_04-x86-64"
|
||||
|
||||
scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main"
|
||||
scripts_systemd_smp="$scripts/smp-server.service"
|
||||
scripts_systemd_xftp="$scripts/xftp-server.service"
|
||||
@@ -22,8 +26,6 @@ path_conf_var="/var/opt"
|
||||
path_conf_smp="$path_conf_etc/simplex $path_conf_var/simplex"
|
||||
path_conf_xftp="$path_conf_etc/simplex-xftp $path_conf_var/simplex-xftp /srv/xftp"
|
||||
|
||||
path_conf_info="$path_conf_etc/simplex-info"
|
||||
|
||||
path_systemd="/etc/systemd/system"
|
||||
path_systemd_smp="$path_systemd/smp-server.service"
|
||||
path_systemd_xftp="$path_systemd/xftp-server.service"
|
||||
@@ -54,7 +56,7 @@ ${GRN}1.${NC} Install latest binaries from GitHub releases:
|
||||
${GRN}2.${NC} Create server directories:
|
||||
- smp: ${YLW}${path_conf_smp}${NC}
|
||||
- xftp: ${YLW}${path_conf_xftp}${NC}
|
||||
${GRN}3.${NC} Setup user for server:
|
||||
${GRN}3.${NC} Setup user for each server:
|
||||
- xmp: ${YLW}${user_smp}${NC}
|
||||
- xftp: ${YLW}${user_xftp}${NC}
|
||||
${GRN}4.${NC} Create systemd services:
|
||||
@@ -63,12 +65,7 @@ ${GRN}4.${NC} Create systemd services:
|
||||
${GRN}5.${NC} Install stopscript (systemd), update and uninstallation script:
|
||||
- all: ${YLW}${path_bin_update}${NC}, ${YLW}${path_bin_uninstall}${NC}, ${YLW}${path_bin_stopscript}${NC}
|
||||
|
||||
Press:
|
||||
- ${GRN}1${NC} to install smp server
|
||||
- ${GRN}2${NC} to install xftp server
|
||||
- ${RED}Ctrl+C${NC} to cancel installation
|
||||
|
||||
Selection: "
|
||||
Press ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
|
||||
|
||||
end="Installtion is complete!
|
||||
|
||||
@@ -79,79 +76,27 @@ Please checkout our server guides:
|
||||
To uninstall with full clean-up, simply run: ${YLW}sudo /usr/local/bin/simplex-servers-uninstall${NC}
|
||||
"
|
||||
|
||||
set_version() {
|
||||
ver="${VER:-latest}"
|
||||
|
||||
case "$ver" in
|
||||
latest)
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
|
||||
remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
|
||||
;;
|
||||
*)
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/download/${ver}"
|
||||
remote_version="${ver}"
|
||||
;;
|
||||
esac
|
||||
}
|
||||
|
||||
os_test() {
|
||||
. /etc/os-release
|
||||
|
||||
case "$VERSION_ID" in
|
||||
20.04|22.04) : ;;
|
||||
24.04) VERSION_ID='22.04' ;;
|
||||
*) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;;
|
||||
esac
|
||||
|
||||
version="$(printf '%s' "$VERSION_ID" | tr '.' '_')"
|
||||
arch="$(uname -p)"
|
||||
|
||||
case "$arch" in
|
||||
x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;;
|
||||
*) printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;;
|
||||
esac
|
||||
|
||||
bin_smp="$bin/smp-server-ubuntu-${version}-${arch}"
|
||||
bin_xftp="$bin/xftp-server-ubuntu-${version}-${arch}"
|
||||
}
|
||||
|
||||
setup_bins() {
|
||||
eval "bin=\$bin_${1}"
|
||||
eval "path=\$path_bin_${1}"
|
||||
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path" && chmod +x "$path"
|
||||
|
||||
unset bin path
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
|
||||
}
|
||||
|
||||
setup_users() {
|
||||
eval "user=\$user_${1}"
|
||||
|
||||
useradd -M "$user" 2> /dev/null || true
|
||||
|
||||
unset user
|
||||
useradd -M "$user_smp" 2> /dev/null || true
|
||||
useradd -M "$user_xftp" 2> /dev/null || true
|
||||
}
|
||||
|
||||
setup_dirs() {
|
||||
# Unquoted varibles, so field splitting can occur
|
||||
eval "path_conf=\$path_conf_${1}"
|
||||
eval "user=\$user_${1}"
|
||||
|
||||
mkdir -p $path_conf
|
||||
mkdir -p $path_conf_info
|
||||
printf "local_version_%s='%s'\n" "$1" "$remote_version" >> "$path_conf_info/release"
|
||||
chown -R "$user":"$user" $path_conf
|
||||
|
||||
unset path_conf user
|
||||
mkdir -p $path_conf_smp
|
||||
chown "$user_smp":"$user_smp" $path_conf_smp
|
||||
mkdir -p $path_conf_xftp
|
||||
chown "$user_xftp":"$user_xftp" $path_conf_xftp
|
||||
}
|
||||
|
||||
setup_systemd() {
|
||||
eval "scripts_systemd=\$scripts_systemd_${1}"
|
||||
eval "path_systemd=\$path_systemd_${1}"
|
||||
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd" -o "$path_systemd"
|
||||
|
||||
unset scripts_systemd path_systemd
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_smp" -o "$path_systemd_smp"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_xftp" -o "$path_systemd_xftp"
|
||||
}
|
||||
|
||||
setup_scripts() {
|
||||
@@ -165,61 +110,32 @@ checks() {
|
||||
printf "This script is intended to be run with root privileges. Please re-run script using sudo."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
set_version
|
||||
os_test
|
||||
|
||||
mkdir -p $path_conf_info
|
||||
}
|
||||
|
||||
main() {
|
||||
checks
|
||||
|
||||
printf "%b\n%b" "${BLU}$logo${NC}" "$welcome"
|
||||
printf "%b\n%b\n" "${BLU}$logo${NC}" "$welcome"
|
||||
read ans
|
||||
|
||||
case "$ans" in
|
||||
1) setup='smp' ;;
|
||||
2) setup='xftp' ;;
|
||||
*) printf 'Installation aborted.\n' && exit 0 ;;
|
||||
esac
|
||||
|
||||
printf "Installing binaries..."
|
||||
|
||||
for i in $setup; do
|
||||
setup_bins "$i"
|
||||
done
|
||||
|
||||
setup_bins
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "Creating users..."
|
||||
|
||||
for i in $setup; do
|
||||
setup_users "$i"
|
||||
done
|
||||
|
||||
setup_users
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "Creating directories..."
|
||||
|
||||
for i in $setup; do
|
||||
setup_dirs "$i"
|
||||
done
|
||||
|
||||
setup_dirs
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "Creating systemd services..."
|
||||
|
||||
for i in $setup; do
|
||||
setup_systemd "$i"
|
||||
done
|
||||
|
||||
setup_systemd
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "Installing stopscript, update and uninstallation script..."
|
||||
|
||||
setup_scripts
|
||||
|
||||
printf "${GRN} Done!${NC}\n"
|
||||
|
||||
printf "%b" "$end"
|
||||
|
||||
+211
@@ -0,0 +1,211 @@
|
||||
name: simplexmq
|
||||
version: 6.0.0.7
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: |
|
||||
This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
<./docs/Simplex-Messaging-Client.html client> and
|
||||
<./docs/Simplex-Messaging-Agent.html agent> for SMP protocols:
|
||||
.
|
||||
* <https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md SMP protocol>
|
||||
* <https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md SMP agent protocol>
|
||||
.
|
||||
See <https://github.com/simplex-chat/simplex-chat terminal chat prototype> built with SimpleXMQ broker.
|
||||
|
||||
homepage: https://github.com/simplex-chat/simplexmq#readme
|
||||
license: AGPL-3
|
||||
author: simplex.chat
|
||||
maintainer: chat@simplex.chat
|
||||
copyright: 2020-2022 simplex.chat
|
||||
category: Chat, Network, Web, System, Cryptography
|
||||
extra-source-files:
|
||||
- README.md
|
||||
- CHANGELOG.md
|
||||
- cbits/sha512.h
|
||||
- cbits/sntrup761.h
|
||||
- apps/smp-server/static/*.html
|
||||
- apps/smp-server/static/media/*
|
||||
|
||||
dependencies:
|
||||
- aeson == 2.2.*
|
||||
- ansi-terminal >= 0.10 && < 0.12
|
||||
- asn1-encoding == 0.9.*
|
||||
- asn1-types == 0.3.*
|
||||
- async == 2.2.*
|
||||
- attoparsec == 0.14.*
|
||||
- base >= 4.14 && < 5
|
||||
- base64-bytestring >= 1.0 && < 1.3
|
||||
- case-insensitive == 1.2.*
|
||||
- composition == 1.0.*
|
||||
- constraints >= 0.12 && < 0.14
|
||||
- containers == 0.6.*
|
||||
- crypton == 0.34.*
|
||||
- crypton-x509 == 1.7.*
|
||||
- crypton-x509-store == 1.6.*
|
||||
- crypton-x509-validation == 1.6.*
|
||||
- cryptostore == 0.3.*
|
||||
- data-default == 0.7.*
|
||||
- direct-sqlcipher == 2.3.*
|
||||
- directory == 1.3.*
|
||||
- filepath == 1.4.*
|
||||
- hourglass == 0.2.*
|
||||
- http-types == 0.12.*
|
||||
- http2 >= 4.2.2 && < 4.3
|
||||
- ini == 0.4.1
|
||||
- iproute == 1.7.*
|
||||
- iso8601-time == 0.1.*
|
||||
- memory == 0.18.*
|
||||
- mtl >= 2.3.1 && < 3.0
|
||||
- network >= 3.1.2.7 && < 3.2
|
||||
- network-info >= 0.2 && < 0.3
|
||||
- network-transport == 0.5.6
|
||||
- network-udp >= 0.0 && < 0.1
|
||||
- optparse-applicative >= 0.15 && < 0.17
|
||||
- process == 1.6.*
|
||||
- random >= 1.1 && < 1.3
|
||||
- simple-logger == 0.1.*
|
||||
- socks == 0.6.*
|
||||
- sqlcipher-simple == 0.4.*
|
||||
- stm == 2.5.*
|
||||
- temporary == 1.3.*
|
||||
- time == 1.12.*
|
||||
- time-manager == 0.0.*
|
||||
- tls >= 1.7.0 && < 1.8
|
||||
- transformers == 0.6.*
|
||||
- unliftio == 0.2.*
|
||||
- unliftio-core == 0.2.*
|
||||
- websockets == 0.12.*
|
||||
- yaml == 0.11.*
|
||||
- zstd == 0.1.3.*
|
||||
|
||||
flags:
|
||||
swift:
|
||||
description: Enable swift JSON format
|
||||
manual: True
|
||||
default: False
|
||||
use_crypton:
|
||||
description: Use crypton etc. in cryptostore
|
||||
manual: True
|
||||
default: True
|
||||
|
||||
# cpp-options:
|
||||
# - -Dslow_servers
|
||||
|
||||
when:
|
||||
- condition: flag(swift)
|
||||
cpp-options:
|
||||
- -DswiftJSON
|
||||
- condition: impl(ghc >= 9.6.2)
|
||||
dependencies:
|
||||
- bytestring == 0.11.*
|
||||
- template-haskell == 2.20.*
|
||||
- text >= 2.0.1 && < 2.2
|
||||
- condition: impl(ghc < 9.6.2)
|
||||
dependencies:
|
||||
- bytestring == 0.10.*
|
||||
- template-haskell == 2.16.*
|
||||
- text >= 1.2.3.0 && < 1.3
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
c-sources:
|
||||
- cbits/sha512.c
|
||||
- cbits/sntrup761.c
|
||||
include-dirs: cbits
|
||||
extra-libraries: crypto
|
||||
|
||||
executables:
|
||||
smp-server:
|
||||
source-dirs:
|
||||
- apps/smp-server
|
||||
- apps/smp-server/web
|
||||
main: Main.hs
|
||||
dependencies:
|
||||
- file-embed
|
||||
- simplexmq
|
||||
- wai-app-static
|
||||
- warp
|
||||
- warp-tls
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
|
||||
ntf-server:
|
||||
source-dirs: apps/ntf-server
|
||||
main: Main.hs
|
||||
dependencies:
|
||||
- simplexmq
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
|
||||
xftp-server:
|
||||
source-dirs: apps/xftp-server
|
||||
main: Main.hs
|
||||
dependencies:
|
||||
- simplexmq
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
|
||||
xftp:
|
||||
source-dirs: apps/xftp
|
||||
main: Main.hs
|
||||
dependencies:
|
||||
- simplexmq
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
|
||||
tests:
|
||||
simplexmq-test:
|
||||
source-dirs: tests
|
||||
main: Test.hs
|
||||
dependencies:
|
||||
- simplexmq
|
||||
- deepseq == 1.4.*
|
||||
- generic-random == 1.5.*
|
||||
- hspec == 2.11.*
|
||||
- hspec-core == 2.11.*
|
||||
- HUnit == 1.6.*
|
||||
- QuickCheck == 2.14.*
|
||||
- silently == 1.2.*
|
||||
- main-tester == 0.2.*
|
||||
- timeit == 2.0.*
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-A64M
|
||||
- -with-rtsopts=-N1
|
||||
|
||||
ghc-options:
|
||||
# - -haddock
|
||||
- -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-unused-packages
|
||||
- -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
|
||||
|
||||
default-extensions:
|
||||
- StrictData
|
||||
+3
-5
@@ -559,13 +559,11 @@ In current implementation of XFTP protocol in SimpleX Chat clients don't use FAC
|
||||
|
||||
- perform traffic correlation attacks against senders and recipients and correlate senders and recipients within the monitored set, frustrated by the number of users on the servers.
|
||||
|
||||
- observe how much traffic is being sent, and make guesses as to its purpose.
|
||||
- observe how much traffic is being sent, and make guesses as to its purpose
|
||||
|
||||
- in case of a compromised transport protocol, correlate file senders and receivers.
|
||||
*cannot, even in case of a compromised transport protocol:*
|
||||
|
||||
*cannot, in case of a non-compromised transport protocol:*
|
||||
|
||||
- perform traffic correlation attacks.
|
||||
- perform traffic correlation attacks with any increase in efficiency over a non-compromised transport protocol
|
||||
|
||||
#### XFTP server
|
||||
|
||||
|
||||
+9
-29
@@ -67,7 +67,7 @@ The session invitation contains this data:
|
||||
- CA TLS certificate fingerprint of the controller - this is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
|
||||
- Session Ed25519 public key used to verify the announcement and commands - this mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
|
||||
- Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity.
|
||||
- Session X25519 DH key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. DH public key and KEM encapsulation key are sent unencrypted. NaCL crypto_box is used for encryption.
|
||||
- Session X25519 DH key and SNTRUP761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. DH public key and KEM encapsulation key are sent unencrypted. NaCL crypto_box is used for encryption.
|
||||
|
||||
Host application decrypts (except the first session) and validates the invitation:
|
||||
- Session signature is valid.
|
||||
@@ -184,7 +184,7 @@ The controller decrypts (including the first session) and validates the received
|
||||
The controller should reply with with `ctrlHello` or `ctrlError` response:
|
||||
|
||||
```abnf
|
||||
ctrlHello = %s"HELLO " kemCiphertext encrypted(unpaddedSize ctrlHelloJSON helloPad) pad
|
||||
ctrlHello = %s"HELLO " kemCiphertext nonce encrypted(unpaddedSize ctrlHelloJSON helloPad) pad
|
||||
; ctrlHelloJSON is encrypted with the hybrid secret,
|
||||
; including both previously agreed DH secret and KEM secret from kemCiphertext
|
||||
unpaddedSize = largeLength
|
||||
@@ -206,8 +206,6 @@ JTD schema for the encrypted part of controller HELLO block `ctrlHelloJSON`:
|
||||
}
|
||||
```
|
||||
|
||||
Controller `hello` block and all subsequent protocol messages are encrypted with the chain keys derived from the hybrid key (see key exchange below) - that is why conntroller hello block does not include nonce. That provides forward secrecy within the XRCP session. Receiving this `hello` block allows host to compute the same hybrid keys and to derive the same chain keys.
|
||||
|
||||
Once the controller replies HELLO to the valid host HELLO block, it should stop accepting new TCP connections.
|
||||
|
||||
### Controller/host session operation
|
||||
@@ -225,12 +223,10 @@ tlsunique channel binding from TLS session MUST be included in commands (include
|
||||
The syntax for encrypted command and response body encoding:
|
||||
|
||||
```abnf
|
||||
commandBody = counter encBody sessSignature idSignature [attachment]
|
||||
responseBody = counter encBody [attachment] ; counter must match command
|
||||
; counter is placed outside of encrypted body to allow correlating encryption keys
|
||||
; with the chain keys (each command and response are encrypted by different keys)
|
||||
encBody = encLength32 encrypted(tlsunique body)
|
||||
attachment = %x01 encLength32 encrypted(attachment)
|
||||
commandBody = encBody sessSignature idSignature [attachment]
|
||||
responseBody = encBody [attachment] ; counter must match command
|
||||
encBody = nonce encLength32 encrypted(tlsunique counter body)
|
||||
attachment = %x01 nonce encLength32 encrypted(attachment)
|
||||
noAttachment = %x00
|
||||
tlsunique = length 1*OCTET
|
||||
counter = 8*8 OCTET ; int64
|
||||
@@ -243,7 +239,7 @@ If the command or response includes attachment, its hash must be included in com
|
||||
|
||||
Initial announcement is shared out-of-band (URI with xrcp scheme), and it is not encrypted.
|
||||
|
||||
This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will contain DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA3-256 over concatenated DH shared secret and KEM encapsulated secret) to derive keys for controller HELLO response (that contains KEM ciphertext in plaintext part) and subsequent session commands and responses.
|
||||
This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will contain DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA256 over concatenated DH shared secret and KEM encapsulated secret) both for controller HELLO response (that contains KEM ciphertext in plaintext part) and subsequent session commands and responses.
|
||||
|
||||
During the next session the announcement is sent via encrypted multicast block. The shared key for this announcement and for host HELLO block is determined using the KEM shared secret from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement.
|
||||
|
||||
@@ -254,7 +250,7 @@ In pseudo-code:
|
||||
```
|
||||
// session 1
|
||||
hostHelloSecret(1) = dhSecret(1)
|
||||
sessionSecret(1) = sha3-256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello
|
||||
sessionSecret(1) = sha256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello
|
||||
dhSecret(1) = dh(hostHelloDhKey(1), controllerInvitationDhKey(1))
|
||||
kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1))
|
||||
// kemEncKey is included in host HELLO, kemCiphertext - in controller HELLO
|
||||
@@ -266,7 +262,7 @@ dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerDhKey(n))
|
||||
|
||||
// session n
|
||||
hostHelloSecret(n) = dhSecret(n)
|
||||
sessionSecret(n) = sha3-256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello
|
||||
sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello
|
||||
dhSecret(n) = dh(hostHelloDhKey(n), controllerDhKey(n))
|
||||
// controllerDhKey(n) is either from invitation or from multicast announcement
|
||||
kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n))
|
||||
@@ -277,22 +273,6 @@ If controller fails to store the new host DH key after receiving HELLO block, th
|
||||
|
||||
To decrypt a multicast announcement, the host should try to decrypt it using the keys of all known (paired) remote controllers.
|
||||
|
||||
Once kemSecret is agreed for the session, it is used to derive two chain keys, to receive and to send messages:
|
||||
|
||||
```
|
||||
host: sndKey, rcvKey = HKDF(kemSecret, "SimpleXSbChainInit", 64)
|
||||
controller: rcvKey, sndKey = HKDF(kemSecret, "SimpleXSbChainInit", 64)
|
||||
```
|
||||
|
||||
where HKDF is based on SHA512, with empty salt.
|
||||
|
||||
Actual keys and nonces to encrypt and decrypt messages are derived from these chain keys:
|
||||
|
||||
```
|
||||
to send: (sndKey', sk, nonce) = HKDF(sndKey, "SimpleXSbChain", 88)
|
||||
to receive: (rcvKey', sk, nonce) = HKDF(rcvKey, "SimpleXSbChain", 88)
|
||||
```
|
||||
|
||||
## Threat model
|
||||
|
||||
#### A passive network adversary able to monitor the site-local traffic:
|
||||
|
||||
@@ -1,124 +0,0 @@
|
||||
# Short invitation links
|
||||
|
||||
## Problem
|
||||
|
||||
Long links look scary and unsafe for many users. While this is a perceived problem, rather than a real one, it hurts adoption.
|
||||
|
||||
What is worse, long links do not fit in profile descriptions of other social networks where people might want to advertize their contact addresses.
|
||||
|
||||
The current link size limitation is also the reason for not including PQ KEM keys into invitation links and addresses, postponing the moment when PQ-resistant encryption kicks in - if we include PQ KEM key into the link, the QR code will not be scannable.
|
||||
|
||||
Additionally, if we store short links, they can also include chat preferences and public profile data.
|
||||
|
||||
## Solution
|
||||
|
||||
MITM-resistant link shortening.
|
||||
|
||||
Instead of generating the random address that would resolve into the link - doing so would create the possibility of MITM by the server hosting this link - we can use private key as the link ID that will be passed to the accepting party, and the hash of the public key as ID for the server - the accepting party would present this key itself as ID and it will also be used for server to client encryption (see Protocol below). HKDF will be used to derive symmetric key from private key and used in secret_box together with random nonce (to allow replacing data with the same key but with a different nonce - nonce will be sent to the server too). secret_box construction is authenticated encryption, so it would protect from MITM.
|
||||
|
||||
The proposed syntax:
|
||||
|
||||
```abnf
|
||||
shortConnectionRequest = connectionScheme "/" connReqType "#/" smpServer "/" linkHash
|
||||
connReqType = %s"invitation" / %s"contact"
|
||||
connectionScheme = (%s"https://" clientAppServer) / %s"simplex:"
|
||||
clientAppServer = hostname [ ":" port ]
|
||||
; client app server, e.g. simplex.chat
|
||||
smpServer = serverIdentity "@" srvHosts [":" port] ; no smp:// prefix, no escaping
|
||||
srvHosts = <hostname> ["," srvHosts] ; RFC1123, RFC5891
|
||||
linkHash = <base64url encoded SHA256 or SHA512 hash of the original link>
|
||||
```
|
||||
|
||||
If SMP server supports pages, its name can be used as clientAppServer, without repeating it after #, for a shorter link.
|
||||
|
||||
Example link:
|
||||
|
||||
```
|
||||
https://simplex.chat/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im/abcdefghij0123456789abcdefghij0123456789abc=
|
||||
```
|
||||
|
||||
This link has the length of ~136 characters (256 bits), which is shorter than the full contact address (~310 characters) and much shorter than invitation links (~528 characters) even without post-quantum keys added to them.
|
||||
|
||||
This size can be further reduced by
|
||||
- use server domain in the link.
|
||||
- do not include onion address, as the connection happens via proxy anyway, if it's untrusted server.
|
||||
- not pinning server TLS certificate - the downside here is that while the attack that compromises TLS will not be able to substitute the link (because it's hash will not match), it will be able to intercept and to block it.
|
||||
- using shorter hash, e.g. SHA128 - reducing the collision resistance.
|
||||
|
||||
If the server is known, the client could use it's hash and onion address, otherwise it could trust the proxy to use any existing session with the same hostname or to accept the risk of interception - given that there is no risk of substitution.
|
||||
|
||||
With the first two of these "improvements" the link could be ~122 characters:
|
||||
|
||||
```
|
||||
https://smp8.simplex.im/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@/abcdefghij0123456789abcdefghij0123456789abc
|
||||
```
|
||||
|
||||
If onion address is preserved the link will be ~184 characters (won't fit in Twitter 160 characters bio):
|
||||
|
||||
```
|
||||
https://smp8.simplex.im/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc
|
||||
```
|
||||
|
||||
If we implement it, the request to resolve the link would be made via proxied SMP command (to avoid the direct connection between the client and the recipient's server).
|
||||
|
||||
Pros:
|
||||
- a bit shorter link.
|
||||
- possibility to include post-quantum keys into the full link keeping the same shortened link size.
|
||||
- possibility to include chat profile of contact or group, and preferences, for a much better connection experience, and to show this information when the link sent in the conversation (clients can resolve them automatically, without connecting - it can be resolved by the sending clients).
|
||||
- server will not have access to the link.
|
||||
|
||||
Cons:
|
||||
- protocol complexity.
|
||||
- observers can access the link content, so for 1-time invitation we should only include permissions and not profile.
|
||||
|
||||
Pros are a huge improvement of UX of connecting both within and from outside of the app (e.g., link can be resolved even before creating chat profile, as part of the onboarding).
|
||||
|
||||
## Protocol
|
||||
|
||||
To support short links, the SMP servers would provide a simple key-value store enabled by three additional commands: `WRT`, `CLR` and `READ`
|
||||
|
||||
`WRT` command is used to store and to update values in the store. The size of the value is limited by the same size as sent messages (or, possibly, smaller - as connection information size used in confirmation messages) - the clients would use this fixed size irrespective of the content. `WRT` command will be sent with the data blob ID in the transaction entityId field, public authorization key used to authorize `WRT` and `CLR` commands (subsequent WRT commands to the existing key must use the same key), and the data blob.
|
||||
|
||||
`CLR` command must use with the same entity ID and must be authorized by the same key.
|
||||
|
||||
`READ` command must use the ID which hash would be equal of the ID used to create the data blob, and this ID would also be used as public authorization
|
||||
|
||||
## Algorithm to store and to retrieve data blob.
|
||||
|
||||
**Store data blob**
|
||||
|
||||
- the data blob owner generates X25519 key pair: `(k, pk)`.
|
||||
- private key `pk` will be included in the short link shared with the other party (only base64url encoded key bytes, not X509 encoding).
|
||||
- `HKDF(pk)` will be used to encrypt the link data with secret_box before storing it on the server.
|
||||
- the hash of public key `sha256(k)` will be used as ID by the owner to store and to remove the data blob (`WRT` and `CLR` commands).
|
||||
|
||||
**Retrieve data blob**
|
||||
|
||||
- the sender uses the public key `k` derived from the private key `pk` included in the link as entity ID to retrieve data blob (the server will compute the ID used by the owner as `sha256(k)` and will be able to look it up). This provides the quality that the traffic of the parties has no shared IDs inside TLS. It also means that unlike message queue creation, the ID to retrieve the blob was never sent to the blob creator, and also is not known to the server in advance (the second part is only an observation, in itself it does not increase security, as server has access to an encrypted blob anyway).
|
||||
- note that the sender does not authorize the request to retrieve the blob, as it would not increase security unless a different key is used to authorize, and adding a key would increase link size.
|
||||
- server session keys with the sender will be `(sk, spk)`, where `sk` is public key shared with the sender during session handshake, and `spk` is the private key known only to the server.
|
||||
- this public key `k` will also be combined with server session key `spk` using `dh(k, spk)` to encrypt the response, so that there is no ciphertext in common in sent and received traffic for these blobs. Correlation ID will be used as a nonce for this encryption.
|
||||
- having received the blob, the client can now decrypt it using secret_box with `HKDF(pk)`.
|
||||
|
||||
Using the same key as ID for the request, and also to additionally encrypt the response allows to use a single key in the link, without increasing the link size.
|
||||
|
||||
## Threat model
|
||||
|
||||
**Compromised SMP server**
|
||||
|
||||
can:
|
||||
- delete link data.
|
||||
- hide link selectively from some requests.
|
||||
|
||||
cannot:
|
||||
- undetectably replace link data.
|
||||
- access unencrypted link data, whether it was or was not accessed by the accepting party.
|
||||
- observe IP addresses of the users accessing link data.
|
||||
|
||||
**Passive observer who observed short link**:
|
||||
|
||||
can:
|
||||
- access original unencrypted link data
|
||||
|
||||
cannot:
|
||||
- replace or delete the link data
|
||||
@@ -1,18 +0,0 @@
|
||||
# iOS notifications stability
|
||||
|
||||
## Problem
|
||||
|
||||
iOS notifications may fail to deliver for several reasons, but there are two important reasons that we could address:
|
||||
- when notification server is not subscribed to SMP server(s), the notifications can be dropped - it can happen because either notification server restarts or becuase SMP server restarted and some messages are received before notification server resubscribed. We lose approximately 3% of notifications because of this reason.
|
||||
- when user device is offline or has low power condition, Apple does not deliver notification, but puts them to storage. If while the notification is in storage a new one arrives it would overwrite the previous notification. If it was the message to the same message queue, the client will download messages anyway, up to a limit, but if the message was to another queue, it will not be delivered until the app is opened. Apple delivers about 88% of notifications that should be delivered (not accounting for uninstalled apps), the rest is replaced with the newer notifications.
|
||||
|
||||
## Solution
|
||||
|
||||
The first problem can be solved by preserving notifications for a limited time (say 1 hour) in case there is no subscription to notification from notification server. At the very least, they can be preserved in SMP server memory but can also be stored to a file on restart, similar to messages, and be delivered when notification server resubscribes. It is sufficient to store one notification per messaging queue.
|
||||
|
||||
The second problem is both more damaging and more complex to solve. The solution could be to always deliver several last notifications to different queues in one packet (Apple allows up to ~4-5kb notification size, and we are sending packets of fixed size 512 bytes, so we could fit up to 8-10 of them in each notification).
|
||||
|
||||
Every time a client receives such batch of notifications if can:
|
||||
- check if that notification was already received in the previous batch.
|
||||
- if it was received, it would be ignored, otherwise it would be processed.
|
||||
- process them one by one, started from the most recent one while the time allows.
|
||||
@@ -1,179 +0,0 @@
|
||||
# SMP server message storage
|
||||
|
||||
## Problem
|
||||
|
||||
Currently SMP servers store all queues in server memory. As the traffic grows, so does the number of undelivered messages. What is worse, Haskell is not avoiding heap fragmentation when messages are allocated and then de-allocated - undelivered messages use ByteString and GC cannot move them around, as they use pinned memory.
|
||||
|
||||
## Possible solutions
|
||||
|
||||
### Solution 1: solve only GC fragmentation problem
|
||||
|
||||
Move from ByteString to some other primitive to store messages in memory long term, e.g. ShortByteString, or manage allocation/de-allocation of stored messages manually in some other way.
|
||||
|
||||
Pros: the simplest solution that avoids substantial re-engineering of the server.
|
||||
|
||||
Cons:
|
||||
- not a long term solution, as memory growth still has limits.
|
||||
- may be ineffective, as it introduces additional copying of bytes.
|
||||
|
||||
### Solution 2: move message storage to hard drive
|
||||
|
||||
Use files or RocksDB to store messages.
|
||||
|
||||
Pros:
|
||||
- much lower memory usage.
|
||||
- no message loss in case of abnormal server termination (important until clients have delivery redundancy).
|
||||
- this is a long term solution, and at some point it might need to be done anyway.
|
||||
|
||||
Cons:
|
||||
- substantial re-engineering costs and risks.
|
||||
- metadata privacy. Currently we only save undelivered messages when server is restarted, with this approach all messages will be stored for some time. this argument is limited, as hosting providers of VMs can make memory snapshots too, on the other hand they are harder to analyze than files. On another hand, with this approach messages will be stored for a shorter time.
|
||||
|
||||
#### RocksDB and other key-value stores
|
||||
|
||||
The downside of any key-value stores is that they don't seem to have efficient primitives for sequential delivery. While sequential delivery can be modelled with linked lists, they would require 1 key insert (on send), 3 key updates (1 update to update queue data on send, 1 update of the last message to point to the next, 1 update on delivery or message expiration) and 1 key deletion (on delivery or message expiration) for each delivered message.
|
||||
|
||||
This might result in substantial write amplification and compacting costs.
|
||||
|
||||
In general, tree structures that are efficient for quick lookups and updates, given approximately fixed value size, are inefficient for modelling queues.
|
||||
|
||||
#### Files
|
||||
|
||||
The upside of files is that they are well suited for sequential delivery and don't result in the same churn, with careful design, as trees do.
|
||||
|
||||
The downside of filesystem is that it does not scale well with the large number of files in a folder, so queues will have to be spread across multiple folders, following tree-like structure.
|
||||
|
||||
I could not find an available library that efficiently models sequential delivery in highly concurrent environment.
|
||||
|
||||
A possible design could be the following.
|
||||
|
||||
##### Queue folder and files
|
||||
|
||||
Each message queue is stored in its own folder (see below on folder locations). Folder would contain these files:
|
||||
|
||||
- `messages.abcd.log` - the file that is used to read messages from, sequentially
|
||||
- `messages.efgh.log` - the optional file that is used to write messages, in case it is different from read file.
|
||||
- `queue.log` - append-only file where the last line represents the current queue state
|
||||
- `queue.timestamp.log` - previous states of queue.log file
|
||||
|
||||
Each line in "queue.log" file has this syntax
|
||||
|
||||
```abnf
|
||||
queueLogLine =
|
||||
%s"read_file=" base64
|
||||
%s"read_msg=" digits
|
||||
%s"read_byte=" digits
|
||||
%s"write_file=" base64
|
||||
%s"write_msg=" digits
|
||||
```
|
||||
|
||||
When queue is first requested by the server:
|
||||
|
||||
```c
|
||||
if queue folder exists:
|
||||
read queue state from last line of queue.log
|
||||
if queue.log contained more than one line: // compaction
|
||||
copy queue.log to queue.timestamp.log
|
||||
write one line queue state to queue.log
|
||||
else:
|
||||
create queue folder
|
||||
create messages.abcd.log (abcd is some random string)
|
||||
read_msg = 0
|
||||
read_byte = 0
|
||||
create queue.log with one line: "read_file=abcd read_msg=0 read_byte=0 write_files=abcd write_msg=0"
|
||||
open read_file in ReadMode and seek to read_byte position
|
||||
nextReadByte = read_byte
|
||||
nextReadMsg = read_msg
|
||||
open write_file in AppendMode
|
||||
```
|
||||
|
||||
When message is added to the queue (assumes that queue state is loaded to server memory, if not the previous section will be done first):
|
||||
|
||||
```c
|
||||
if write_msg > max_queue_messages:
|
||||
return quota error
|
||||
else if write_msg = max_queue_messages:
|
||||
add quota_exceeded message to write_file
|
||||
update queue state: write_msg += 1
|
||||
append updated queue state to queue.log
|
||||
else
|
||||
// It is required that `max_queue_messages < max_file_messages`,
|
||||
// so that we never need more than one additional write file.
|
||||
if write_msg >= max_file_messages: // queue file rotation
|
||||
create messages.efgh.log // efgh is some random string
|
||||
update queue state: write_file=efgh write_msg=0 // read file remains the same as it was
|
||||
append updated queue state to queue.log
|
||||
copy queue.log to queue.timestamp.log
|
||||
// `old` needs to be defined to limit the number and storage duration,
|
||||
// preserving not more than N files, and not more than M days files, "and then some"
|
||||
// (that is if the queue has high churn, we have file from M days before in any case, for any debugging).
|
||||
delete `old` `queue.timestamp.log` files
|
||||
write one line queue state to queue.log // compaction
|
||||
|
||||
add message to write_file
|
||||
update queue state: write_msg += 1
|
||||
append updated queue state to queue.log
|
||||
```
|
||||
|
||||
The above algorithm assumes `max_queue_messages < than max_file_messages`, so that we never need more than one write file.
|
||||
|
||||
When message is delivered, it is simply read from the read queue, queue state does not change yet:
|
||||
|
||||
```c
|
||||
if nextReadMsg > read_msg:
|
||||
deliver cached message, no need to read it again
|
||||
else
|
||||
read message from read_file handle
|
||||
nextReadMsg = read_msg + 1
|
||||
nextReadByte = current position in file
|
||||
```
|
||||
|
||||
When message delivery is acknowledged, the read queue needs to be advanced, and possibly switched to read from the current write_queue:
|
||||
|
||||
```c
|
||||
if nextReadByte == read_byte:
|
||||
return error // nothing was delivered
|
||||
else if nextReadByte = EOF:
|
||||
// end of file is reached, possibly some other condition,
|
||||
// but it should allow changing max_file_messages on server restart
|
||||
currReadFile = read_file
|
||||
read_file = write_file
|
||||
read_msg = 0
|
||||
read_byte = 0
|
||||
append updated queue state to queue.log
|
||||
delete currReadFile
|
||||
else
|
||||
read_msg += 1
|
||||
read_byte = nextReadByte
|
||||
// `seek` should not be necessary, as the handle is already at nextReadByte position here
|
||||
// seek to read_byte
|
||||
append updated queue state to queue.log
|
||||
```
|
||||
|
||||
The above algorithm delegates the problem of compaction and fragmentation management to file system, that is very optimized for such scenarios.
|
||||
|
||||
Also, read and write files will grow to almost a constant size, so the space they used may be re-used.
|
||||
|
||||
An important consideration is that writes to queue.log and message.log files and queue state modifications have to be sequential, without concurrency - it can be managed with the usual locks.
|
||||
|
||||
##### Queue folders structure
|
||||
|
||||
Most Linux systems use EXT4 filesystem where the file lookup time scales linearly to the number of files. While alternatives with logarithmic lookup time exist (XFS), they may be very complex to configure on the existing systems.
|
||||
|
||||
So storing all queue folders in one folder won't scale.
|
||||
|
||||
To solve this problem we could use recipient queue ID in base64url format not as a folder name, but as a folder path, splitting it to path fragments of some length. The number of fragments can be configurable and migration to a different fragment size can be supported as the number of queues on a given server grows.
|
||||
|
||||
Currently, queue ID is 24 bytes random number, thus allowing 2^192 possible queue IDs. If we assume that a server must hold 1b queues, it means that we have ~2^162 possible addresses for each existing queue. 24 bytes in base64 is 32 characters that can be split into say 8 fragments with 4 characters each, so that queue folder path for queue with ID `abcdefghijklmnopqrstuvwxyz012345` would be:
|
||||
|
||||
`/var/opt/simplex/messages/abcd/efgh/ijkl/mnop/qrst/uvwx/yz01/2345`
|
||||
|
||||
The maximum theoretic number of the folders on the 1st level is 64^4, or 2^24 ~ 16m - this is probably still a large number of subfolders for EXT4. Given that addresses are random, all the possible combinations in the first folder can be used with a large number of queues.
|
||||
|
||||
So we could use an unequal split of path, two letters each and the last being long:
|
||||
|
||||
`/var/opt/simplex/messages/ab/cd/ef/ghijklmnopqrstuvwxyz012345`
|
||||
|
||||
The first three levels in this case can have 4096 subfolders each, and it gives 68b possible subfolders (64^2^3), so the last level will be sparse in case of 1b queues on the server. So we could make it 4 levels with 2 letters to never think about it, accounting for a large variance of the random numbers distribution:
|
||||
|
||||
`/var/opt/simplex/messages/ab/cd/ef/gh/ijklmnopqrstuvwxyz012345`
|
||||
@@ -1,81 +0,0 @@
|
||||
# Storage considerations for SMP queues
|
||||
|
||||
See [Short invitation links](./2024-06-21-short-links.md).
|
||||
|
||||
## Problem
|
||||
|
||||
1) queue records are created permanently, until the clients delete them.
|
||||
|
||||
2) clients only delete queue records based on some user action, pending connections do not expire.
|
||||
|
||||
While part 2 should be improved in the client, indefinite storage of queue records becomes a much bigger issue if each of them would result in a permanent storage of 4-16kb blob in server memory, without server-side expiration for short invitation links.
|
||||
|
||||
## Possible solutions
|
||||
|
||||
1) Add some queue timestamp, e.g. queue creation date, to expire unsecured queues after say 3 weeks.
|
||||
|
||||
The problem with this approach is that contact addresses are also unsecured queues, and they should not be expired.
|
||||
|
||||
We could set really large expiration time, and require that clients "update" the unsecured queues they need at least every 1-2 years, but it would not solve the problem of storing a large number of blobs in the server memory for unused/abandoned 1-time invitations.
|
||||
|
||||
2) Do not store blobs in memory / append-only log, and instead use something like RocksDB. While it may be a correct long term solution, it may be not expedient enough at the current POC stage for this feature. Also, the lack of expiration is wrong in any case and would indefinitely grow server storage.
|
||||
|
||||
3) Add flag allowing the server to differentiate permanent queues used as contact addresses, also using different blob sizes for them. In this case, messaging queues will be expired if not secured after 3 weeks, and contact address queues would be expired if not "updated" by the owner within 2 years.
|
||||
|
||||
Probably all three solutions need to be used, to avoid creating a non-expiring blob storage in memory, as in case too many of such blobs are created it would not be possible to differentiate between real users and resource exhaustion attacks, and unlike with messages, they won't be expiring too.
|
||||
|
||||
Servers already can differentiate messaging queues and contact address queues, if they want to:
|
||||
- with the old 4-message handshake, the confirmation message on a normal queue was different, and also KEY command was eventually used.
|
||||
- with the fast 2-message handshake, while the confirmation message has the same syntax, and the differences are inside encrypted envelope, the client still uses SKEY command.
|
||||
- in both cases, the usual messaging queues are secured, and contact addresses are not, so this difference is visible in the storage as well (although it is not easy to differentiate between abandoned 1-time invitations and contact addresses).
|
||||
|
||||
Differentiating these queues can also allow different message retention times - e.g., the queues for contact addresses could have bigger size, but have lower message retention time.
|
||||
|
||||
## Proposed solution
|
||||
|
||||
1. Add queue updated_at date into queue records. While it adds some metadata, it seems necessary to manage retention and quality of service. It will not include exact time, only date, and the time of creation will be replaced by the time of any update - queue secured, a message is sent, or queue owner subscribes to the queue. To avoid the need to update store log on every message this information can be appended to store log on server termination. Or given that only one update per day is needed it may be ok to make these updates as they happen (temporarily making the sequence and time of these events available in storage).
|
||||
|
||||
2. Add flag to indicate the queue usage - messaging queue or queue for contact address connection requests. This would result in different queue size and different retention policy for queue and its messages. We already have "sender can secure flag" which is, effectively, this flag - contact address queues are never secured. So this does not increase stored metadata in any way.
|
||||
|
||||
## Possible changes to short links
|
||||
|
||||
This is a design considerations and a concept, not a design yet.
|
||||
|
||||
Instead of implementing a generic blob storage that can be used as an attack vector, and adds additional failure point (another server storing blob that is necessary to connect to the queue on the current server), but instead adds an extended queue information blobs, most of which could be dropped without the loss of connectivity, so that the attack can be mitigated by deleting these blobs without users losing the ability to connect, as long as the queue and minimal extended information is retained.
|
||||
|
||||
So, to make the connection there need to be these elements:
|
||||
|
||||
- queue server and queue ID - mandatory part, that can be included in short link
|
||||
- SMP key - mandatory part for all queues. We are considering initializing ratchets earlier for contact addresses, and include ratchet keys and pre-keys into queue data as well, but it is out of scope here.
|
||||
- Ratchet keys - mandatory part for 1-time invitation that won't fit in short link.
|
||||
- PQ key - optional part that can be stored with addresses if ratchet keys are added and with 1-time invitations.
|
||||
- App blobs - chat preferences for 1-time invitation links and profile information for contact addresses.
|
||||
|
||||
So rather that storing one blob with a large address inside it, not associated with the queue, increasing probability of failure and reducing our ability to mitigate resource exhaustion, we could store extended blobs associated with the queues.
|
||||
|
||||
Also, we need the address shared with the sender (party accepting the connection) to be short. We could use a similar approach that was proposed for data blobs, using a single random seed per queues to derive multiple keys and IDs from it. For example:
|
||||
|
||||
1. The queue owner:
|
||||
- generates Ed25529 key pair `(sk, spk)` and X25519 key pair `(dhk, dhpk)` to use with the server, same as now sent in NEW command.
|
||||
- generates queue recipient ID (this ID can still be server-generated).
|
||||
- generates X25519 key pair `(k, pk)` to use with the accepting party.
|
||||
- derives from `k`:
|
||||
- sender ID.
|
||||
- symmetric key for authenticated encryption of blobs.
|
||||
- `k` will be used as short link.
|
||||
2. All other data from the invitation can be included in queue creation request and be associated with the queue as 1-3 blobs with different priority:
|
||||
- ratchet keys - it will have a small size, so only this blob cannot be removed, while other blobs can be removed in case of resource exhaustion.
|
||||
- PQ keys - optional blob.
|
||||
- conversation preferences and profile - can be removed depending on creation time, e.g. all new blobs can be removed.
|
||||
|
||||
The algorithm used to derive key and ID from `k` needs to be cryptographically secure, e.g. it could be some KDF or ChaCha DRG initialized with `k` as seed, TBC.
|
||||
|
||||
So, coupling blob storage with messaging queues has these pros/cons:
|
||||
|
||||
Cons:
|
||||
- no additional layer of privacy - the server used for connection is visible in the link, even after the blobs are removed from the server.
|
||||
|
||||
Pros:
|
||||
- no additional point of failure in the connection process - the same server will be used to retrieve necessary blobs as for connection.
|
||||
- queue blobs of messaging blobs will be automatically removed once the queue is secured or expired, without additional request from the recipient - reducing the storage and the time these blobs are available.
|
||||
- queue blobs for contact addresses will be structured and some of the large blobs can be removed in case of resource exhaustion attack (and recreated by the client if needed), with the only downside that PQ handshake will be postponed (which is the case now) and profile will not be available at a point of connection.
|
||||
@@ -1,80 +0,0 @@
|
||||
# Blob extensions for SMP queues
|
||||
|
||||
Evolution of the design for short links, see [here](./2024-06-21-short-links.md) and [here](./2024-09-05-queue-storage.md).
|
||||
|
||||
## Problems
|
||||
|
||||
Allow storing extended information with SMP queues to improve UX and security of making connections:
|
||||
- short invitation links and contact addresses.
|
||||
- PQ encryption from the first message.
|
||||
- present user profile with chat preferences and welcome message when the public address link is scanned.
|
||||
|
||||
## Design
|
||||
|
||||
1. Queue creation/update date is already added to server persistence, allowing to expire queues and blobs, depending on their usage.
|
||||
2. Add "queue type" metadata to NEW command to indicate whether messaging queue is used as public address or as messaging queue (see previous docs on why it doesn't change threat model). While at the moment it would match sndSecure flag there may be future scenarios when they diverge. Initially only "invitation" and "contact" types will be supported.
|
||||
3. Prohibit sndSecure flag for "contact" queues, prohibit securing contact queues.
|
||||
4. Add "queue blobs" to NEW command:
|
||||
- blob0: ratchetKeys up to N0 bytes - priority 0, can't be removed by the server, only in "invitation"
|
||||
- blob1: PQ key up to N1 bytes - priority 1, can be removed by the server, only used in "invitation"
|
||||
- blob2: Application data up to N2 bytes - priority 2, can be removed by the server.
|
||||
5. Add linkId to NEW command
|
||||
6. linkId and blobs will be removed when queue is secured.
|
||||
7. Add recipient command to remove/upsert blob2 for contact queues.
|
||||
8. Add sender command to retrieve blobs.
|
||||
|
||||
## Protocol
|
||||
|
||||
### Creating a queue:
|
||||
|
||||
The queue owner:
|
||||
- generates Ed25529 key pair `(sk, spk)` and X25519 key pair `(dhk, dhpk)` to use with the server, same as now. `sk` and `dhk` will be sent in NEW command.
|
||||
- generates X25519 key pair `(k, pk)` to use with the accepting party to encrypt queue messages.
|
||||
- derives from `k` using HKDF:
|
||||
- symmetric key `bk` for authenticated encryption of blobs.
|
||||
- `linkId`, will be sent in NEW command.
|
||||
- `k` will be used as short link.
|
||||
- sends NEW command.
|
||||
|
||||
NEW command syntax:
|
||||
|
||||
```abnf
|
||||
create = %s"NEW " linkId queueType recipientAuthPublicKey recipientDhPublicKey
|
||||
basicAuth subscribe sndSecure [ "0" blob0 ] [ "1" blob1 ] [ "2" blob2 ]
|
||||
queueType = %s"I" / %s "C" ; new parameter
|
||||
linkId = length *OCTET ; new parameter,
|
||||
; can be empty in which case blobs won't be allowed
|
||||
blob0 = word16 *OCTET ; new parameter, encrypted ratchet keys,
|
||||
; including nonce and auth tag
|
||||
blob1 = word16 *OCTET ; new parameter, encrypted PQ key
|
||||
blob2 = word16 *OCTET ; new parameter, encrypted application data
|
||||
```
|
||||
|
||||
SET - command to update queue blobs (recipientId is used as entity ID):
|
||||
|
||||
```abnf
|
||||
set = %s"SET " linkId [ "2" blob2 ] ; passing empty blob removes it
|
||||
linkId ; updated (or the same) linkId, can be empty to remove blobs
|
||||
; allows to change the address without removing the queue / changing blobs
|
||||
; (e.g., to avoid losing the messages).
|
||||
```
|
||||
|
||||
### Sending messages to the queue
|
||||
|
||||
GET - command to get queue blobs (linkId is used as entity ID):
|
||||
|
||||
```abnf
|
||||
get = %s"GET"
|
||||
```
|
||||
|
||||
Response to GET:
|
||||
|
||||
```abnf
|
||||
blobs = %s"BLOB" senderId [ "0" blob0 ] [ "1" blob1 ] [ "2" blob2 ]
|
||||
```
|
||||
|
||||
As blobs are retrieved using a separate linkId, once blobs are removed it will be impossible to find senderId from short link - it is a threat model improvement. Once server storage is compacted, it will be impossible to find queue related to the link even with the access to server data (unless server preserves the data).
|
||||
|
||||
### Possible privacy improvement
|
||||
|
||||
We could only allow unauthorized GET and authorized SET commands for long-term "contact" queues, and return BLOB in response to SKEY (or require that GET is authorized) - so that only the person who secures the queue will get access to data blobs. This way it ensures that the parties transmitting the invitation links cannot retrieve their content without the sender noticing it.
|
||||
@@ -1,26 +0,0 @@
|
||||
# Private rendezvous protocol
|
||||
|
||||
## Problem
|
||||
|
||||
Our current handshake protocol is open to this attack: whoever observes the link exchange, knows on which server connection is being made, and if the traffic on this server is observed, then it can confirm communication between parties. Further, even with the [last proposal](./2024-09-09-smp-blobs.md#possible-privacy-improvement), having real-time access to the server data allows to establish the exact messaging queue that is used to send messages.
|
||||
|
||||
## Solution
|
||||
|
||||
We could make the initial link exchange more private by making it harder for any observer to discover which server will be used for messaging by hiding this information from the server that hosts the initial link.
|
||||
|
||||
Preliminary, the protocol could be the following:
|
||||
|
||||
1. Connection initiator stores 224-256 bytes of encrypted connection link on a rendezvous server (link contains server host and linkId on another messaging server, not a rendezvous one).
|
||||
|
||||
2. Rendezvous server adds these links to buckets, up to 64 links per bucket. Bucket ID is the timestamp when the bucket was created + a sequential bucket number, in case more than one bucket is created per second.
|
||||
|
||||
3. The server responds to the link creator with a bucket ID where this link was added. That bucket ID is its timestamp + a number prevents server "fingerprinting" clients and using say one bucket for each client. If timestamp is different or a bucket number within this timestamp is too large, the client can refuse to use it, depending on the client settings.
|
||||
|
||||
4. The initiating party will pass to the accepting party the rendezvous server host, the hash of this bucket ID (bucket link) and the passphrase to derive the key from. The initiating party has an option to pass a link and passphrase via two channels - in which case the link will only contain the bucket ID.
|
||||
|
||||
5. The accepting party would then request the bucket via its ID hash (the server would store hashes to be able to look up - hash is used to prevent showing time in the link) and attempt to decrypt all contained links using the provided key.
|
||||
The accepting party then will continue the connection via the decrypted link.
|
||||
|
||||
This obviously does not protect accepting party from the initiating party, if it can choose rendezvous server it controls. It also does not protect from the malicious rendezvous server that would collaborate with link observers. I think reunion doesn’t protect from it too.
|
||||
|
||||
But it does protect connection from whoever observes the link, particularly if this link only contains the bucket and the key is passed separately, via some other channel.
|
||||
@@ -1,163 +0,0 @@
|
||||
# Sharing protocol ports with HTTPS
|
||||
|
||||
Some networks block all ports other than web ports, including port 5223 used for SMP protocol by default. Running SMP servers on a common web port 443 would allow them to work on more networks. The servers would need to provide an HTTPS page for browsers (and probes).
|
||||
|
||||
## Problem
|
||||
|
||||
Browsers and tools rely on system CA bundles instead of certificate pinning.
|
||||
The crypto parameters used by HTTPS are different from what the protocols use.
|
||||
Public certificate providers like LetsEncrypt can only sign specific types of keys and Ed25519 isn't one of them.
|
||||
|
||||
This means a server should distinguish browser and protocol clients and adjust its behavior to match.
|
||||
|
||||
## Solution
|
||||
|
||||
`tls` package has a server hook that allows producing a different set of `TLS.Credentials` according to a client-provided "Server Name Indication" extension.
|
||||
|
||||
Since LE certificates are only handed out to domain names, TLS client will be sending the SNI.
|
||||
However client transports are constructed over connected sockets and the SNI wouldn't be present unless explicitly requested.
|
||||
When a client sends SNI, then it's a browser and a web credentials should be used.
|
||||
Otherwise it's a protocol client to be offered the self-signed ca, cert and key.
|
||||
|
||||
When a transport colocated with a HTTPS, its ALPN list should be extended with `h2 http/1.1`.
|
||||
The browsers will send it, and it should be checked before running transport client.
|
||||
If HTTP ALPN is detected, then the client connection is served with HTTP `Application` instead (the same "server information" page).
|
||||
|
||||
If some client connects to server IP, doesn't send SNI and doesn't send ALPN, it will look like a pre-handshake client.
|
||||
In that case a server will send its handshake first.
|
||||
This can be mitigated by delaying its handshake and letting the probe to issue its HTTP request.
|
||||
|
||||
## Implementation plan
|
||||
|
||||
An unmodified client should be able to use protocols on port 443 right away.
|
||||
|
||||
The switchover happens inside `runTransportServerState` before `runClient`:
|
||||
|
||||
```haskell
|
||||
runServer (tcpPort, ATransport t) = do
|
||||
-- ...
|
||||
runTransportServerState_ ss started tcpPort serverParams tCfg $ \socket h -> do -- expose raw socket for warp-tls internals to attach
|
||||
negotiated <- getSessionALPN
|
||||
if allowHTTP t && isHTTP negotiated -- only attempt the switch for the TLS transport
|
||||
then runHTTP socket (tlsContext h)-- ... collect data and produce values needed to run WAI Application
|
||||
else runClient serverSignKey t h `runReaderT` env -- performs serverHandshake etc as usual
|
||||
```
|
||||
|
||||
The web app and server live outside, so `runHttp` has to be provided by the `runSMPServer` caller.
|
||||
Additonally, Warp is using its `InternalInfo` object that's scoped to `withII` bracket.
|
||||
|
||||
```haskell
|
||||
runServer ini = do
|
||||
-- ...
|
||||
|
||||
runWebServer ini ServerInformation {config, information} $ if sharedHttps then Nothing else webHttpsParams -- suppress serving https
|
||||
if sharedHttps
|
||||
then withRunHTTP staticFilesPath \attachStatic -> runSMPServer cfg (Just attachStatic) -- provide wrapped application runner
|
||||
else runSMPServer cfg Nothing
|
||||
```
|
||||
|
||||
### Upstream
|
||||
|
||||
The implementation relies on a few modification to upstream code:
|
||||
- `warp-tls`: The library provides `httpOverTls`, but it wants to do handshake itself.
|
||||
Since we have to do the handshake to switch on ALPN, the setup function has to be split.
|
||||
This is a resonable change that may be upstreamed and nothing blocks us from using the recent version.
|
||||
- `warp`: Only the re-export of `serveConnection` is needed.
|
||||
Unfortunately the most recent `warp` version can't be used right away due to dependency cascade around `http-5` and `auto-update-2`.
|
||||
So a fork containing the backported re-export has to be used until the dependencies are refreshed.
|
||||
|
||||
|
||||
### TLS.ServerParams
|
||||
|
||||
When a server has port sharing enabled, a new set of TLS params is loaded and combined with transport params:
|
||||
|
||||
```haskell
|
||||
newEnv config = do
|
||||
-- ...
|
||||
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
|
||||
sharedServerParams <- forM ((,) <$> sharedHttpsCredentials config <*> alpn transportConfig) $ \((chain, key), alpn) ->
|
||||
let ca = Nothing -- It is possible to provide CA certificate, but it is typical for web server to use combined certificate chains
|
||||
loadHTTPSServerParams tlsServerParams ca chain key alpn
|
||||
```
|
||||
|
||||
`loadHTTPSServerParams` extends params with:
|
||||
1. `onALPNClientSuggest` hook gets `["h2", "http/1.1"]` added to the ALPN list which is now required.
|
||||
2. `onServerNameIndication` hook added, which upon detecting client SNI prepends the web credentials.
|
||||
3. `sharedCredentials = T.Credentials []` should be done to prevent transport credentials confusing browsers.
|
||||
But that aborts key exchange somewhere in tls internals, so disabled for now.
|
||||
As a workaround, another set of dummy credentials can be provided in the hope that any sane browser would reject them.
|
||||
Like, RC4 ciphers, "impossible" digest combination, etc.
|
||||
|
||||
### supportedParameters
|
||||
|
||||
TLS certificate chains provided by LetsEncrypt use ECDSA/P256 and that requires extending `supportedParameters` with things disabled in transports:
|
||||
|
||||
```haskell
|
||||
browserCiphers =
|
||||
[ TE.cipher_TLS13_AES128CCM8_SHA256
|
||||
, TE.cipher_ECDHE_ECDSA_AES128CCM8_SHA256
|
||||
, TE.cipher_ECDHE_ECDSA_AES256CCM8_SHA256
|
||||
]
|
||||
browserGroups =
|
||||
[ T.P256
|
||||
]
|
||||
browserSigs =
|
||||
[ (T.HashSHA256, T.SignatureECDSA),
|
||||
(T.HashSHA384, T.SignatureECDSA)
|
||||
]
|
||||
```
|
||||
|
||||
This may not be enough for other certificate providers.
|
||||
|
||||
## Configuration
|
||||
|
||||
> XXX: This is for the current implementation and should be updated.
|
||||
|
||||
Web certificate chain is picked up from the WEB section:
|
||||
|
||||
```ini
|
||||
[TRANSPORT]
|
||||
port: 443
|
||||
|
||||
[WEB]
|
||||
https: 443
|
||||
cert: /etc/opt/simplex/web.cert
|
||||
key: /etc/opt/simplex/web.key
|
||||
|
||||
# Alternatively, with a proper access configuration, the paths can point to the LE creds directly:
|
||||
# cert: /etc/letsencrypt/live/smp.hostname.tld/fullchain.pem
|
||||
# key: /etc/letsencrypt/live/smp.hostname.tld/privkey.pem
|
||||
```
|
||||
|
||||
When `TRANSPORT.port` matches `WEB.https` the transport server becomes shared.
|
||||
|
||||
Perhaps a more desirable option would be explicit configuration resulting in additional transported to run:
|
||||
|
||||
```ini
|
||||
[TRANSPORT]
|
||||
port: 5223 ; pure protocol transport
|
||||
# control_port: 5224
|
||||
shared_port: 443 ; variant 1: register in TRANSPORT
|
||||
|
||||
[WEB]
|
||||
https: 443
|
||||
cert: /etc/opt/simplex/web.cert
|
||||
key: /etc/opt/simplex/web.key
|
||||
# transport: on ; variant 2:
|
||||
```
|
||||
|
||||
## Caveats
|
||||
|
||||
Serving static files and the protocols togother may pose a problem for those who currently use dedicated web servers as they should switch to embedded http handlers.
|
||||
|
||||
As before, using embedded HTTP server is increasing attack surface.
|
||||
|
||||
Users who want to run everything on a single host will have to add and extra IP address and bind servers to specific IPs instead of 0.0.0.0.
|
||||
An amalgamated server binary can be provided that would contain both SMP and XFTP servers, where transport will dispatch connections by handshake ALPN.
|
||||
|
||||
## Alternative: Use transports routable with reverse-proxies
|
||||
|
||||
An "industrial" reverse proxy may do the ALPN routing, serving HTTP by itself and delegating `smp` and `xftp` to protocol servers.
|
||||
Same with the `websockets`.
|
||||
|
||||
Since this in effect does TLS termination, the protocol servers will have to rely on credentials from protocol handshakes.
|
||||
@@ -1,49 +0,0 @@
|
||||
# iOS notifications delivery
|
||||
|
||||
## Problem
|
||||
|
||||
For iOS notifications to be delivered the client has to create credentials for notification subscription on SMP server using NKEY command and after that create a subscription on notification server using SNEW command. These two commands are sent in sequence, after the connections are created, and for it to happen the client needs to be online and in foreground.
|
||||
|
||||
iOS users tend to close the app when it is not used, and iOS has very limited permissions for background activities, so these notification subscriptions are created with a substantial delay, and notifications do not work.
|
||||
|
||||
This problem is distinct from and probably more common than other problems affecting notifications delivery described [here](./2024-07-06-ios-notifications.md).
|
||||
|
||||
## Solution
|
||||
|
||||
1. When the new connection is created, the client already knows if it needs to create notification subscription or not, based on the conversation setting (e.g., if the group is muted, the client will not create notification subscription as well.). We should extend NEW command to avoid the need to send additional NKEY command with an option to create notification subscription at the point where connection is created. NDEL would still be used to disable this notification, and NKEY will be used to re-enable it.
|
||||
|
||||
2. In the same way we stopped using SDEL command (NDEL sends notification DELD to subscribed notification server) to delete notificaiton subscriptions from notification server, we should delegate creating notification subscription on notification server to SMP servers. Clients could use keys agreed with ntf server for e2e encryption and for command authorization to encrypt and sign instruction to create notification subscription that will be forwarded to notification server using protocol similar to SMP proxies. This will avoid the need for clients to separately contact notification servers that won't happen until they are online.
|
||||
|
||||
3. Instead of making Ntf server trust DELD notifications, we could send deletion instructions signed by the client, which will only fail to send in case notification server is down (and they won't be sent later after server restart).
|
||||
|
||||
Cons:
|
||||
- If SMP servers were to retain in the storage the information about which notification server is used for which queue, it would reduce metadata privacy. While currently it is not an issue, as all notification servers are known and operated by us, once there are other client apps, this can be used for app users fingerprinting, which would act as a deterrence from using new apps – but only if app users use servers of operators who are different from the app provider. To mitigate it, we could only store it in server memory and include notification instruction in subscription commands (SUB) and include notification subscription status in SUB responses. We don't need to mitigate the problem of server being able to store this information, as messaging servers can observe which notification servers connect to them anyway.
|
||||
- If SMP server is restarted before the subscription request is forwared to the notification server, then it will have to be forwarded again, once the client subscribes. The problem here is that if the client is offline, it will neither subscribe to the queue to send notification subscription request, nor receive notifications from this queue. Storing notification server and subscription request would mitigate that, as in this case we could send all pending requests on server start, without depending on client subscriptions.
|
||||
- "Small" agent will need to support connections to ntf servers and manage workers that retry sending pending subscription requests.
|
||||
- Until the client learns the public keys of notification server, it will not be able to decrypt notifications. It potentially can be mitigated by using the public key of the server returned when token is created, in this way different client keys (per-queue) will be combined with the same ntf server key (per-token).
|
||||
|
||||
## Implementation details
|
||||
|
||||
1. NEW and NKEY commands will need to be extended to include notification subscription request. As the notifier ID needs to be sent to notification server, this notifier ID will have to be client-generated and supplied as part of NEW command.
|
||||
|
||||
now:
|
||||
|
||||
```haskell
|
||||
NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
|
||||
NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
|
||||
```
|
||||
|
||||
extended:
|
||||
|
||||
```haskell
|
||||
NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Maybe NtfRequest -> Command Recipient
|
||||
|
||||
data NtfRequest = NtfRequest NotifierId NtfPublicAuthKey RcvNtfPublicDhKey NtfServerRequest
|
||||
|
||||
data NtfServerRequest = NtfServerRequest NtfServer EncSingedNtfCmd
|
||||
|
||||
NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Maybe NtfServerRequest -> Command Recipient
|
||||
-- NotifierID is passed in entity ID field of the transmission
|
||||
```
|
||||
|
||||
2. Notification server will need to support an additional command to receive "proxied" subscription commands, `SFWD`, that would include `NtfServerRequest`. This command can include both `SNEW` and `SDEL` commands.
|
||||
@@ -1,15 +0,0 @@
|
||||
# Expiring messages in journal storage
|
||||
|
||||
## Problem
|
||||
|
||||
The journal storage servers recently migrated to do not delete delivered or expired messages, they only update pointers to journal file lines. The messages are actually deleted when the whole journal file is deleted (when fully deleted or fully expired).
|
||||
|
||||
The problem is that in case the queue stops receiving the new messages then writing of messages won't switch to the new journal file, and the current journal file containing delivered or expired messages would never be deleted.
|
||||
|
||||
## Solution
|
||||
|
||||
Remove current journal file and update queue_state.log during message expiration of "idle" queue (that is, without any new messages received or delivered within 3 hours) in case when:
|
||||
- the queue is "empty" after the expiration
|
||||
- the queue contains only quota marker(s), in which case move them to a new journal file and update the queue_state accordingly. Quota markers can be kept indefinitely to prevent writing the new messages to the dormant queues that reached capacity, so it's important to handle this case.
|
||||
|
||||
Also remove current journal file when the queue is opened in case it is empty (as it would not be ever expired in case it remains empty), and also update queue_state.log
|
||||
@@ -1,58 +0,0 @@
|
||||
# Blob extensions for SMP queues 2 and queue storage
|
||||
|
||||
This document evolves the design proposed [here](./2024-09-09-smp-blobs.md).
|
||||
|
||||
## Problems
|
||||
|
||||
In addition to problems in the first doc, we have these issues with in-memory queue record storage:
|
||||
- many queues are idle or rarely used, but they are loaded to memory, and currently just loading all queues uses 20gb RAM on each server, and takes 10 min to process, increasing downtimes during restarts.
|
||||
- adding blobs to memory would make this problem much worse.
|
||||
|
||||
## Proposed solution
|
||||
|
||||
Move queues to the same journalling approach as [used for messages](./2024-09-01-smp-message-storage.md) now, with independent file names in the same folders.
|
||||
|
||||
Each queue change would be logged to its own file, and every time the queue is opened the whole file will be read and compacted to a single line - replacing one store log for all queues, with individual log files for each queue.
|
||||
|
||||
Queue deletion would not be making a record in the file, instead it would be deleting the entire folder - it would reduce retention period for any metadata of deleted queues.
|
||||
|
||||
We could additionally record deletions to the central log, for debugging, and reset it on every start. But in this case we should not remove folders at the point of deletion, but rather mark them as deleted and delete on restart. TBC
|
||||
|
||||
It would also allow simplifying blob storage by having only one blob per queue - for example, limied to 16kb (a bit smaller to fit in block) for contact address queues and 4-8kb for invitations (to fit PQ keys and conversation preferences).
|
||||
|
||||
We would also need to be able to lookup recipient ID via sender/notifier/link IDs.
|
||||
|
||||
One possible solution is to use and load to memory a central index file. But it is likely to also consume a lot of memory and result in slow starts.
|
||||
|
||||
Another solution that is probably better is to use the same folder structure and put notifier/sender/link files with the ID of the recipient queue inside the files. So to locate recipient queue the sender would have to locate folder containing the reference file pointing to the recipient queue and then to locate the actual queue data.
|
||||
|
||||
## Implementation details
|
||||
|
||||
Each queue folder would these files:
|
||||
|
||||
- queue_state.log (and timestamped backups) - to store pointers to message journals (already implemented)
|
||||
- messages.randomBase64.log - message journals (already implemented)
|
||||
- queue_rec.log (and timestamped backups) - to log complete queue record every time it is changed (so only the last line needs to be read following the same logic as with queue_state.log, to prevent file corruption).
|
||||
- blob.data, blob.data.bak, blob.timestamp.data - files for data blobs (to make sure some copy of this file is readable/correct in case of write corruption) - the same two step overwrite process will be used as currently with store log compacting:
|
||||
- on write: 1. if file exists, move it to .bak, 2. store new blob to .data, 3. move .bak to .timestamp.data
|
||||
- on read: 1. if .bak exists, move it to .data 2. use .data
|
||||
|
||||
Additional suggestion to reduce probability of queue_state.log and queue_rec.log file corruption is to do one of the following:
|
||||
- log end of lines in the beginning of the output, not in the end, to prevent the last line from being corrupted in case the previous line was not fully stored. The downside is that the file will not be EOL terminated, and there will be no confirmation that the output was fully made.
|
||||
- log EOL both in the beginning and at the end of output, and ignore empty lines in between - this would both confirm that the last line is fully logged and prevent corruption of the next line in case it was not.
|
||||
- check the last byte of the file and log EOL if it is not EOL. Probably cleanest approach, but with a small performance cost.
|
||||
|
||||
If queue folder is a reference to the queue, it may have one of these files:
|
||||
- notifier.id
|
||||
- sender.id
|
||||
- link.id
|
||||
|
||||
These files would contain a one line with the recipient ID of the queue. These files would never change, they can only be deleted when queue is deleted or when notifier/link is deleted.
|
||||
|
||||
There is logic in code preventing using the same ID in different contexts, and the ID size is large enough to make any collisions unlikely (192 bits), so with correctly working code the queue folder would either have one of reference files, and nothing else, or the queue and message files from the beginning of this section. But even if the same ID is re-used in different context, it should not cause any problems as file names don't overlap.
|
||||
|
||||
While we could store different types of references in different types of folders, it would have additional costs of maintaining 4 folder hierarchies. Instead we could use the fact that it is one hierarchy to prevent using the same ID in different contexts.
|
||||
|
||||
## Protocol
|
||||
|
||||
The only change in protocol is that there will be only one blob per queue, without markers (see the previous doc). Otherwise the protocol and proposed privacy improvement seem reasonable.
|
||||
@@ -53,7 +53,7 @@ The session invitation contains this data:
|
||||
- CA TLS certificate fingerprint of the controller - this is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
|
||||
- Session Ed25519 public key used to verify the announcement and commands - this mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
|
||||
- Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity.
|
||||
- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. This DH public key is always sent unencrypted. NaCL Cryptobox is used for encryption.
|
||||
- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. These DH public key and KEM encapsulation key are always sent unencrypted. NaCL Cryptobox is used for encryption.
|
||||
|
||||
Host device decrypts (except the first session) and validates the invitation:
|
||||
- Session signature is valid.
|
||||
|
||||
@@ -1,174 +1,30 @@
|
||||
#!/usr/bin/env sh
|
||||
set -eu
|
||||
|
||||
# Common
|
||||
# ------
|
||||
path_conf_var="/var/opt"
|
||||
path_conf_smp="$path_conf_var/simplex"
|
||||
path_conf_xftp="$path_conf_var/simplex-xftp"
|
||||
path_conf_storelog_smp="$path_conf_smp/smp-server-store.log"
|
||||
path_conf_storelog_xftp="$path_conf_xftp/file-server-store.log"
|
||||
date="$(date -u '+%Y-%m-%dT%H:%M:%S')"
|
||||
|
||||
GRN='\033[0;32m'
|
||||
YLW='\033[1;33m'
|
||||
BLU='\033[1;34m'
|
||||
RED='\033[0;31m'
|
||||
NC='\033[0m'
|
||||
|
||||
path_conf_var="/var/opt"
|
||||
|
||||
smp_variables() {
|
||||
path_conf_smp="$path_conf_var/simplex"
|
||||
path_conf_smp_archive="$path_conf_smp/backups"
|
||||
path_conf_smp_archive_storelog="$path_conf_smp_archive/queues"
|
||||
path_conf_smp_archive_stats="$path_conf_smp_archive/stats"
|
||||
path_conf_smp_archive_messages="$path_conf_smp_archive/messages"
|
||||
path_conf_storelog_smp="$path_conf_smp/smp-server-store.log"
|
||||
path_conf_storelog_smp_out="$path_conf_smp_archive_storelog/smp-server-store.log.${date:-date-failed}"
|
||||
|
||||
path_conf_stats_smp="$path_conf_smp/smp-server-stats.log"
|
||||
path_conf_stats_smp_out="$path_conf_smp_archive_stats/smp-server-stats.log.${date:-date-failed}"
|
||||
|
||||
path_conf_messages_smp="$path_conf_smp/smp-server-messages.log"
|
||||
path_conf_messages_smp_out="$path_conf_smp_archive_messages/smp-server-messages.log.${date:-date-failed}"
|
||||
backup_smp() {
|
||||
if [ -e "$path_conf_storelog_smp" ]; then
|
||||
cp "$path_conf_storelog_smp" "${path_conf_storelog_smp}.${date:-date-failed}"
|
||||
fi
|
||||
}
|
||||
|
||||
xftp_variables() {
|
||||
path_conf_xftp="$path_conf_var/simplex-xftp"
|
||||
path_conf_xftp_archive="$path_conf_xftp/backups"
|
||||
|
||||
path_conf_xftp_archive_storelog="$path_conf_xftp_archive/queues"
|
||||
path_conf_xftp_archive_stats="$path_conf_xftp_archive/stats"
|
||||
|
||||
path_conf_storelog_xftp="$path_conf_xftp/file-server-store.log"
|
||||
path_conf_storelog_xftp_out="$path_conf_xftp_archive_storelog/file-server-store.log.${date:-date-failed}"
|
||||
|
||||
path_conf_stats_xftp="$path_conf_xftp/file-server-stats.log"
|
||||
path_conf_stats_xftp_out="$path_conf_xftp_archive_stats/file-server-stats.log.${date:-date-failed}"
|
||||
backup_xftp() {
|
||||
if [ -e "$path_conf_storelog_xftp" ]; then
|
||||
cp "$path_conf_storelog_xftp" "${path_conf_storelog_xftp}.${date:-date-failed}"
|
||||
fi
|
||||
}
|
||||
|
||||
checks() {
|
||||
result=${SERVICE_RESULT:-exit-code}
|
||||
status=${EXIT_STATUS:-TERM}
|
||||
|
||||
case "$result" in
|
||||
success)
|
||||
case "$status" in
|
||||
TERM)
|
||||
printf "${RED}Refusing to backup files with failed service state${NC}\n"
|
||||
exit 1
|
||||
;;
|
||||
*)
|
||||
:
|
||||
;;
|
||||
esac
|
||||
;;
|
||||
*)
|
||||
printf "${RED}Refusing to backup files with failed service state${NC}\n"
|
||||
exit 1
|
||||
;;
|
||||
esac
|
||||
}
|
||||
|
||||
smp_check() {
|
||||
if [ ! -d "$path_conf_smp_archive_storelog" ]; then
|
||||
mkdir -p "$path_conf_smp_archive_storelog"
|
||||
fi
|
||||
if [ ! -d "$path_conf_smp_archive_messages" ]; then
|
||||
mkdir -p "$path_conf_smp_archive_messages"
|
||||
fi
|
||||
if [ ! -d "$path_conf_smp_archive_stats" ]; then
|
||||
mkdir -p "$path_conf_smp_archive_stats"
|
||||
fi
|
||||
}
|
||||
|
||||
xftp_check() {
|
||||
if [ ! -d "$path_conf_xftp_archive_storelog" ]; then
|
||||
mkdir -p "$path_conf_xftp_archive_storelog"
|
||||
fi
|
||||
if [ ! -d "$path_conf_xftp_archive_stats" ]; then
|
||||
mkdir -p "$path_conf_xftp_archive_stats"
|
||||
fi
|
||||
}
|
||||
|
||||
backup() {
|
||||
file="$1"
|
||||
out="$2"
|
||||
file_type="$3"
|
||||
|
||||
if [ -e "$file" ]; then
|
||||
if cp "$file" "$out"; then
|
||||
printf "${YLW}${file_type}${NC} ${GRN}backup successful:${NC} ${BLU}%s${NC}\n" "${out}"
|
||||
else
|
||||
printf "${YLW}${file_type}${NC} ${RED}backup failed!${NC}\n"
|
||||
fi
|
||||
fi
|
||||
|
||||
unset file out file_type
|
||||
}
|
||||
|
||||
cleanup() {
|
||||
directory="$1"
|
||||
|
||||
file_type="$2"
|
||||
|
||||
files_date=$(find "$directory" -type f -exec stat --format="%y" {} + | awk '{print $1}' | sort -nr | uniq | awk 'NR==2')
|
||||
|
||||
if [ -n "$files_date" ]; then
|
||||
files=$(find "$directory" -type f -not -newermt "$files_date" -printf "%T@ %Tc %p\n" | sort -n | awk '{print $NF}')
|
||||
|
||||
if [ -n "$files" ]; then
|
||||
printf '%s' "$files" | xargs rm -f
|
||||
printf "${YLW}Old ${file_type} files${NC}${GRN} has been deleted:${NC}\n"
|
||||
files_colored=$(printf '%s' "$files" | awk '{print "\033[1;34m"$0"\033[0m"}')
|
||||
printf "${files_colored}\n"
|
||||
fi
|
||||
fi
|
||||
|
||||
unset directory file_type files_date files
|
||||
}
|
||||
|
||||
smp_backup() {
|
||||
backup "$path_conf_storelog_smp" "$path_conf_storelog_smp_out" 'Storelog'
|
||||
backup "$path_conf_messages_smp" "$path_conf_messages_smp_out" 'Messages'
|
||||
backup "$path_conf_stats_smp" "$path_conf_stats_smp_out" 'Stats'
|
||||
}
|
||||
|
||||
smp_cleanup() {
|
||||
cleanup "$path_conf_smp_archive_storelog" 'storelog'
|
||||
cleanup "$path_conf_smp_archive_stats" 'stats'
|
||||
cleanup "$path_conf_smp_archive_messages" 'messages'
|
||||
}
|
||||
|
||||
xftp_backup() {
|
||||
backup "$path_conf_storelog_xftp" "$path_conf_storelog_xftp_out" 'Storelog'
|
||||
backup "$path_conf_stats_xftp" "$path_conf_stats_xftp_out" 'Stats'
|
||||
}
|
||||
|
||||
xftp_cleanup() {
|
||||
cleanup "$path_conf_xftp_archive_storelog" 'storelog'
|
||||
cleanup "$path_conf_xftp_archive_stats" 'stats'
|
||||
}
|
||||
|
||||
main() {
|
||||
type="${1:-}"
|
||||
|
||||
checks
|
||||
|
||||
case "$type" in
|
||||
smp-server)
|
||||
smp_variables
|
||||
smp_check
|
||||
smp_backup
|
||||
smp_cleanup
|
||||
;;
|
||||
xftp-server)
|
||||
xftp_variables
|
||||
xftp_check
|
||||
xftp_backup
|
||||
xftp_cleanup
|
||||
;;
|
||||
*)
|
||||
printf "${YLW}Unknown server type.${NC}\n"
|
||||
exit 1
|
||||
;;
|
||||
esac
|
||||
}
|
||||
|
||||
main "$@"
|
||||
if [ "$1" = 'smp-server' ]; then
|
||||
backup_smp
|
||||
elif [ "$1" = 'xftp-server' ]; then
|
||||
backup_xftp
|
||||
else
|
||||
backup_smp
|
||||
backup_xftp
|
||||
fi
|
||||
|
||||
@@ -13,15 +13,11 @@ fi
|
||||
printf "${RED}This action will permanently remove all configs, directories, binaries from Installation Script. Please backup any relevant configs if they are needed.${NC}\n\nPress ${GRN}ENTER${NC} to continue or ${RED}Ctrl+C${NC} to cancel installation"
|
||||
read ans
|
||||
|
||||
systemctl disable --now smp-server 2>/dev/null || true
|
||||
systemctl revert smp-server 2>/dev/null || true
|
||||
systemctl disable --now xftp-server 2>/dev/null || true
|
||||
systemctl revert xftp-server 2>/dev/null || true
|
||||
systemctl daemon-reload 2>/dev/null || true
|
||||
systemctl stop smp-server
|
||||
systemctl stop xftp-server
|
||||
|
||||
rm -rf /var/opt/simplex /etc/opt/simplex /etc/opt/simplex-info /var/opt/simplex-xftp /etc/opt/simplex-xftp /srv/xftp /etc/systemd/system/smp-server.service /etc/systemd/system/xftp-server.service /usr/local/bin/smp-server /usr/local/bin/xftp-server /usr/local/bin/simplex-servers-update /usr/local/bin/simplex-servers-uninstall /usr/local/bin/simplex-servers-stopscript
|
||||
rm -rf /var/opt/simplex /etc/opt/simplex /var/opt/simplex-xftp /etc/opt/simplex-xftp /srv/xftp /etc/systemd/system/smp-server.service /etc/systemd/system/xftp-server.service /usr/local/bin/smp-server /usr/local/bin/xftp-server /usr/local/bin/simplex-servers-update /usr/local/bin/simplex-servers-uninstall
|
||||
|
||||
userdel smp 2>/dev/null || true
|
||||
userdel xftp 2>/dev/null || true
|
||||
userdel smp && userdel xftp
|
||||
|
||||
printf "Uninstallation is complete! Thanks for trying out SimpleX!\n"
|
||||
|
||||
@@ -2,6 +2,10 @@
|
||||
set -eu
|
||||
|
||||
# Links to scripts/configs
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
|
||||
bin_smp="$bin/smp-server-ubuntu-20_04-x86-64"
|
||||
bin_xftp="$bin/xftp-server-ubuntu-20_04-x86-64"
|
||||
|
||||
scripts="https://raw.githubusercontent.com/simplex-chat/simplexmq/stable/scripts/main"
|
||||
scripts_systemd_smp="$scripts/smp-server.service"
|
||||
scripts_systemd_xftp="$scripts/xftp-server.service"
|
||||
@@ -29,9 +33,6 @@ path_tmp_bin_stopscript="$path_tmp_bin/simplex-servers-stopscript"
|
||||
path_tmp_systemd_smp="$path_tmp_bin/smp-server.service"
|
||||
path_tmp_systemd_xftp="$path_tmp_bin/xftp-server.service"
|
||||
|
||||
path_conf_etc='/etc/opt'
|
||||
path_conf_info='/etc/opt/simplex-info'
|
||||
|
||||
GRN='\033[0;32m'
|
||||
BLU='\033[1;36m'
|
||||
YLW='\033[1;33m'
|
||||
@@ -39,55 +40,8 @@ RED='\033[0;31m'
|
||||
NC='\033[0m'
|
||||
|
||||
# Currently, XFTP default to v0.1.0, so it doesn't make sense to check its version
|
||||
|
||||
os_test() {
|
||||
. /etc/os-release
|
||||
|
||||
case "$VERSION_ID" in
|
||||
20.04|22.04) : ;;
|
||||
24.04) VERSION_ID='22.04' ;;
|
||||
*) printf "${RED}Unsupported Ubuntu version!${NC}\nPlease file Github issue with request to support Ubuntu %s: https://github.com/simplex-chat/simplexmq/issues/new\n" "$VERSION_ID" && exit 1 ;;
|
||||
esac
|
||||
|
||||
version="$(printf '%s' "$VERSION_ID" | tr '.' '_')"
|
||||
arch="$(uname -p)"
|
||||
|
||||
case "$arch" in
|
||||
x86_64) arch="$(printf '%s' "$arch" | tr '_' '-')" ;;
|
||||
*) printf "${RED}Unsupported architecture!${NC}\nPlease file Github issue with request to support %s architecture: https://github.com/simplex-chat/simplexmq/issues/new" "$arch" && exit 1 ;;
|
||||
esac
|
||||
|
||||
bin_smp="$bin/smp-server-ubuntu-${version}-${arch}"
|
||||
bin_xftp="$bin/xftp-server-ubuntu-${version}-${arch}"
|
||||
}
|
||||
|
||||
installed_test() {
|
||||
set +u
|
||||
for i in $path_conf_etc/*; do
|
||||
if [ -d "$i" ]; then
|
||||
case "$i" in
|
||||
*simplex) apps="smp $apps" ;;
|
||||
*simplex-xftp) apps="xftp $apps" ;;
|
||||
esac
|
||||
fi
|
||||
done
|
||||
set -u
|
||||
}
|
||||
|
||||
set_version() {
|
||||
ver="${VER:-latest}"
|
||||
|
||||
case "$ver" in
|
||||
latest)
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/latest/download"
|
||||
remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
|
||||
;;
|
||||
*)
|
||||
bin="https://github.com/simplex-chat/simplexmq/releases/download/${ver}"
|
||||
remote_version="${ver}"
|
||||
;;
|
||||
esac
|
||||
}
|
||||
local_version="$($path_bin_smp -v | awk '{print $3}')"
|
||||
remote_version="$(curl --proto '=https' --tlsv1.2 -sSf -L https://api.github.com/repos/simplex-chat/simplexmq/releases/latest | grep -i "tag_name" | awk -F \" '{print $4}')"
|
||||
|
||||
update_scripts() {
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_update" -o "$path_tmp_bin_update" && chmod +x "$path_tmp_bin_update"
|
||||
@@ -102,7 +56,6 @@ update_scripts() {
|
||||
mv "$path_tmp_bin_uninstall" "$path_bin_uninstall"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
if diff -q "$path_bin_stopscript" "$path_tmp_bin_stopscript" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}Stopscript script is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_bin_stopscript"
|
||||
@@ -111,7 +64,6 @@ update_scripts() {
|
||||
mv "$path_tmp_bin_stopscript" "$path_bin_stopscript"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
if diff -q "$path_bin_update" "$path_tmp_bin_update" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}Update script is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_bin_update"
|
||||
@@ -119,82 +71,75 @@ update_scripts() {
|
||||
printf -- "- Updating update script..."
|
||||
mv "$path_tmp_bin_update" "$path_bin_update"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
printf -- "- Re-executing Update script with latest updates..."
|
||||
printf "Re-executing Update script with latest updates..."
|
||||
exec sh "$path_bin_update" "continue"
|
||||
fi
|
||||
}
|
||||
|
||||
update_systemd() {
|
||||
service="${1}-server"
|
||||
eval "scripts_systemd=\$scripts_systemd_${1}"
|
||||
eval "path_systemd=\$path_systemd_${1}"
|
||||
eval "path_tmp_systemd=\$path_tmp_systemd_${1}"
|
||||
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd" -o "$path_tmp_systemd"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_smp" -o "$path_tmp_systemd_smp"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$scripts_systemd_xftp" -o "$path_tmp_systemd_xftp"
|
||||
|
||||
if diff -q "$path_systemd" "$path_tmp_systemd" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}%s service is up-to-date${NC}.\n" "$service"
|
||||
rm "$path_tmp_systemd"
|
||||
if diff -q "$path_systemd_smp" "$path_tmp_systemd_smp" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}smp-server service is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_systemd_smp"
|
||||
else
|
||||
printf -- "- Updating %s service..." "$service"
|
||||
mv "$path_tmp_systemd" "$path_systemd"
|
||||
printf -- "- Updating smp-server service..."
|
||||
mv "$path_tmp_systemd_smp" "$path_systemd_smp"
|
||||
systemctl daemon-reload
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
if diff -q "$path_systemd_xftp" "$path_tmp_systemd_xftp" > /dev/null 2>&1; then
|
||||
printf -- "- ${YLW}xftp-server service is up-to-date${NC}.\n"
|
||||
rm "$path_tmp_systemd_xftp"
|
||||
else
|
||||
printf -- "- Updating xftp-server service..."
|
||||
mv "$path_tmp_systemd_xftp" "$path_systemd_xftp"
|
||||
systemctl daemon-reload
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
unset service scripts_systemd path_systemd path_tmp_systemd
|
||||
}
|
||||
|
||||
update_bins() {
|
||||
service="${1}-server"
|
||||
eval "bin=\$bin_${1}"
|
||||
eval "path_bin=\$path_bin_${1}"
|
||||
|
||||
set_ver() {
|
||||
local_version='unset'
|
||||
sed -i -- "s/local_version_${1}=.*/local_version_${1}='${remote_version}'/" "$path_conf_info/release"
|
||||
}
|
||||
|
||||
if [ -f "$path_conf_info/release" ]; then
|
||||
. "$path_conf_info/release" 2>/dev/null
|
||||
|
||||
set +u
|
||||
eval "local_version=\$local_version_${1}"
|
||||
set -u
|
||||
|
||||
if [ -z "${local_version}" ]; then
|
||||
set_ver "$1"
|
||||
fi
|
||||
else
|
||||
printf 'local_version_xftp=\nlocal_version_smp=\n' > "$path_conf_info/release"
|
||||
set_ver "$1"
|
||||
fi
|
||||
|
||||
if [ "$local_version" != "$remote_version" ]; then
|
||||
if systemctl is-active --quiet "$service"; then
|
||||
printf -- "- Stopping %s service..." "$service"
|
||||
systemctl stop "$service"
|
||||
if systemctl is-active --quiet smp-server; then
|
||||
printf -- "- Stopping smp-server service..."
|
||||
systemctl stop smp-server
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Updating %s to %s..." "$service" "$remote_version"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
|
||||
printf -- "- Updating smp-server bin to %s..." "$remote_version"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Starting %s service..." "$service"
|
||||
systemctl start "$service"
|
||||
printf -- "- Starting smp-server service..."
|
||||
systemctl start smp-server
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
else
|
||||
printf -- "- Updating %s to %s..." "$service" "$remote_version"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin" -o "$path_bin" && chmod +x "$path_bin"
|
||||
printf -- "- Updating smp-server bin..."
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_smp" && chmod +x "$path_bin_smp"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
|
||||
if systemctl is-active --quiet xftp-server; then
|
||||
printf -- "- Stopping xftp-server service..."
|
||||
systemctl stop xftp-server
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Updating xftp-server bin to %s..." "$remote_version"
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_xftp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
|
||||
printf -- "- Starting xftp-server service..."
|
||||
systemctl start xftp-server
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
else
|
||||
printf -- "- Updating xftp-server bin..."
|
||||
curl --proto '=https' --tlsv1.2 -sSf -L "$bin_smp" -o "$path_bin_xftp" && chmod +x "$path_bin_xftp"
|
||||
printf "${GRN}Done!${NC}\n"
|
||||
fi
|
||||
else
|
||||
printf -- "- ${YLW}%s is up-to-date${NC}.\n" "$service"
|
||||
printf -- "- ${YLW}smp-server and xftp-server binaries is up-to-date${NC}.\n"
|
||||
fi
|
||||
|
||||
set_ver "$1"
|
||||
|
||||
unset service bin path_bin local_version
|
||||
}
|
||||
|
||||
checks() {
|
||||
@@ -202,12 +147,6 @@ checks() {
|
||||
printf "This script is intended to be run with root privileges. Please re-run script using sudo.\n"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
set_version
|
||||
os_test
|
||||
installed_test
|
||||
|
||||
mkdir -p $path_conf_info
|
||||
}
|
||||
|
||||
main() {
|
||||
@@ -224,14 +163,10 @@ main() {
|
||||
fi
|
||||
|
||||
printf "Updating systemd services...\n"
|
||||
for i in $apps; do
|
||||
update_systemd "$i"
|
||||
done
|
||||
update_systemd
|
||||
|
||||
printf "Updating simplex servers...\n"
|
||||
for i in $apps; do
|
||||
update_bins "$i"
|
||||
done
|
||||
printf "Updating simplex server binaries...\n"
|
||||
update_bins
|
||||
|
||||
rm -rf "$path_tmp_bin"
|
||||
}
|
||||
|
||||
@@ -9,9 +9,7 @@ ExecStart=/usr/local/bin/smp-server start +RTS -N -RTS
|
||||
ExecStopPost=/usr/local/bin/simplex-servers-stopscript smp-server
|
||||
LimitNOFILE=65535
|
||||
KillSignal=SIGINT
|
||||
TimeoutStartSec=infinity
|
||||
TimeoutStopSec=infinity
|
||||
AmbientCapabilities=CAP_NET_BIND_SERVICE
|
||||
|
||||
[Install]
|
||||
WantedBy=multi-user.target
|
||||
|
||||
@@ -9,7 +9,6 @@ ExecStart=/usr/local/bin/xftp-server start +RTS -N -RTS
|
||||
ExecStopPost=/usr/local/bin/simplex-servers-stopscript xftp-server
|
||||
LimitNOFILE=65535
|
||||
KillSignal=SIGINT
|
||||
TimeoutStartSec=infinity
|
||||
TimeoutStopSec=infinity
|
||||
AmbientCapabilities=CAP_NET_BIND_SERVICE
|
||||
|
||||
|
||||
+372
-128
@@ -1,7 +1,11 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: simplexmq
|
||||
version: 6.2.0.6
|
||||
version: 6.0.0.7
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
<./docs/Simplex-Messaging-Client.html client> and
|
||||
@@ -62,11 +66,6 @@ flag use_crypton
|
||||
manual: True
|
||||
default: True
|
||||
|
||||
flag client_library
|
||||
description: Don't build server-related code.
|
||||
manual: True
|
||||
default: False
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Simplex.FileTransfer.Agent
|
||||
@@ -78,6 +77,13 @@ library
|
||||
Simplex.FileTransfer.Crypto
|
||||
Simplex.FileTransfer.Description
|
||||
Simplex.FileTransfer.Protocol
|
||||
Simplex.FileTransfer.Server
|
||||
Simplex.FileTransfer.Server.Control
|
||||
Simplex.FileTransfer.Server.Env
|
||||
Simplex.FileTransfer.Server.Main
|
||||
Simplex.FileTransfer.Server.Stats
|
||||
Simplex.FileTransfer.Server.Store
|
||||
Simplex.FileTransfer.Server.StoreLog
|
||||
Simplex.FileTransfer.Transport
|
||||
Simplex.FileTransfer.Types
|
||||
Simplex.FileTransfer.Util
|
||||
@@ -129,8 +135,6 @@ library
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
|
||||
Simplex.Messaging.Agent.TRcvQueues
|
||||
Simplex.Messaging.Client
|
||||
Simplex.Messaging.Client.Agent
|
||||
@@ -148,13 +152,32 @@ library
|
||||
Simplex.Messaging.Encoding.String
|
||||
Simplex.Messaging.Notifications.Client
|
||||
Simplex.Messaging.Notifications.Protocol
|
||||
Simplex.Messaging.Notifications.Server
|
||||
Simplex.Messaging.Notifications.Server.Env
|
||||
Simplex.Messaging.Notifications.Server.Main
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS.Internal
|
||||
Simplex.Messaging.Notifications.Server.Stats
|
||||
Simplex.Messaging.Notifications.Server.Store
|
||||
Simplex.Messaging.Notifications.Server.StoreLog
|
||||
Simplex.Messaging.Notifications.Transport
|
||||
Simplex.Messaging.Notifications.Types
|
||||
Simplex.Messaging.Parsers
|
||||
Simplex.Messaging.Protocol
|
||||
Simplex.Messaging.Server
|
||||
Simplex.Messaging.Server.CLI
|
||||
Simplex.Messaging.Server.Control
|
||||
Simplex.Messaging.Server.Env.STM
|
||||
Simplex.Messaging.Server.Expiration
|
||||
Simplex.Messaging.Server.Information
|
||||
Simplex.Messaging.Server.Main
|
||||
Simplex.Messaging.Server.MsgStore
|
||||
Simplex.Messaging.Server.MsgStore.STM
|
||||
Simplex.Messaging.Server.QueueStore
|
||||
Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
Simplex.Messaging.Server.QueueStore.STM
|
||||
Simplex.Messaging.Server.Stats
|
||||
Simplex.Messaging.Server.StoreLog
|
||||
Simplex.Messaging.ServiceScheme
|
||||
Simplex.Messaging.Session
|
||||
Simplex.Messaging.TMap
|
||||
@@ -177,44 +200,13 @@ library
|
||||
Simplex.RemoteControl.Discovery.Multicast
|
||||
Simplex.RemoteControl.Invitation
|
||||
Simplex.RemoteControl.Types
|
||||
if !flag(client_library)
|
||||
exposed-modules:
|
||||
Simplex.FileTransfer.Server
|
||||
Simplex.FileTransfer.Server.Control
|
||||
Simplex.FileTransfer.Server.Env
|
||||
Simplex.FileTransfer.Server.Main
|
||||
Simplex.FileTransfer.Server.Stats
|
||||
Simplex.FileTransfer.Server.Store
|
||||
Simplex.FileTransfer.Server.StoreLog
|
||||
Simplex.Messaging.Server
|
||||
Simplex.Messaging.Server.Control
|
||||
Simplex.Messaging.Server.Env.STM
|
||||
Simplex.Messaging.Server.Information
|
||||
Simplex.Messaging.Server.Main
|
||||
Simplex.Messaging.Server.MsgStore
|
||||
Simplex.Messaging.Server.MsgStore.Journal
|
||||
Simplex.Messaging.Server.MsgStore.STM
|
||||
Simplex.Messaging.Server.MsgStore.Types
|
||||
Simplex.Messaging.Server.NtfStore
|
||||
Simplex.Messaging.Server.QueueStore
|
||||
Simplex.Messaging.Server.QueueStore.STM
|
||||
Simplex.Messaging.Server.Stats
|
||||
Simplex.Messaging.Server.StoreLog
|
||||
Simplex.Messaging.Server.StoreLog.Types
|
||||
Simplex.Messaging.Notifications.Server
|
||||
Simplex.Messaging.Notifications.Server.Control
|
||||
Simplex.Messaging.Notifications.Server.Env
|
||||
Simplex.Messaging.Notifications.Server.Main
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS.Internal
|
||||
Simplex.Messaging.Notifications.Server.Stats
|
||||
Simplex.Messaging.Notifications.Server.Store
|
||||
Simplex.Messaging.Notifications.Server.StoreLog
|
||||
other-modules:
|
||||
Paths_simplexmq
|
||||
hs-source-dirs:
|
||||
src
|
||||
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-home-modules -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2
|
||||
default-extensions:
|
||||
StrictData
|
||||
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-unused-packages -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
|
||||
include-dirs:
|
||||
cbits
|
||||
c-sources:
|
||||
@@ -224,12 +216,14 @@ library
|
||||
crypto
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
, asn1-encoding ==0.9.*
|
||||
, asn1-types ==0.3.*
|
||||
, async ==2.2.*
|
||||
, attoparsec ==0.14.*
|
||||
, base >=4.14 && <5
|
||||
, base64-bytestring >=1.0 && <1.3
|
||||
, case-insensitive ==1.2.*
|
||||
, composition ==1.0.*
|
||||
, constraints >=0.12 && <0.14
|
||||
, containers ==0.6.*
|
||||
@@ -264,7 +258,7 @@ library
|
||||
, temporary ==1.3.*
|
||||
, time ==1.12.*
|
||||
, time-manager ==0.0.*
|
||||
, tls >=1.9.0 && <1.10
|
||||
, tls >=1.7.0 && <1.8
|
||||
, transformers ==0.6.*
|
||||
, unliftio ==0.2.*
|
||||
, unliftio-core ==0.2.*
|
||||
@@ -274,37 +268,93 @@ library
|
||||
default-language: Haskell2010
|
||||
if flag(swift)
|
||||
cpp-options: -DswiftJSON
|
||||
if !flag(client_library)
|
||||
build-depends:
|
||||
case-insensitive ==1.2.*
|
||||
, hashable ==1.4.*
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.11.*
|
||||
, template-haskell ==2.20.*
|
||||
, text >=2.0.1 && <2.2
|
||||
if impl(ghc < 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.10.*
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
|
||||
executable ntf-server
|
||||
if flag(client_library)
|
||||
buildable: False
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_simplexmq
|
||||
hs-source-dirs:
|
||||
apps/ntf-server
|
||||
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
|
||||
default-extensions:
|
||||
StrictData
|
||||
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-unused-packages -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
|
||||
build-depends:
|
||||
base
|
||||
, simple-logger
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
, asn1-encoding ==0.9.*
|
||||
, asn1-types ==0.3.*
|
||||
, async ==2.2.*
|
||||
, attoparsec ==0.14.*
|
||||
, base >=4.14 && <5
|
||||
, base64-bytestring >=1.0 && <1.3
|
||||
, case-insensitive ==1.2.*
|
||||
, composition ==1.0.*
|
||||
, constraints >=0.12 && <0.14
|
||||
, containers ==0.6.*
|
||||
, crypton ==0.34.*
|
||||
, crypton-x509 ==1.7.*
|
||||
, crypton-x509-store ==1.6.*
|
||||
, crypton-x509-validation ==1.6.*
|
||||
, cryptostore ==0.3.*
|
||||
, data-default ==0.7.*
|
||||
, direct-sqlcipher ==2.3.*
|
||||
, directory ==1.3.*
|
||||
, filepath ==1.4.*
|
||||
, hourglass ==0.2.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
, ini ==0.4.1
|
||||
, iproute ==1.7.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.18.*
|
||||
, mtl >=2.3.1 && <3.0
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq
|
||||
, socks ==0.6.*
|
||||
, sqlcipher-simple ==0.4.*
|
||||
, stm ==2.5.*
|
||||
, temporary ==1.3.*
|
||||
, time ==1.12.*
|
||||
, time-manager ==0.0.*
|
||||
, tls >=1.7.0 && <1.8
|
||||
, transformers ==0.6.*
|
||||
, unliftio ==0.2.*
|
||||
, unliftio-core ==0.2.*
|
||||
, websockets ==0.12.*
|
||||
, yaml ==0.11.*
|
||||
, zstd ==0.1.3.*
|
||||
default-language: Haskell2010
|
||||
if flag(swift)
|
||||
cpp-options: -DswiftJSON
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.11.*
|
||||
, template-haskell ==2.20.*
|
||||
, text >=2.0.1 && <2.2
|
||||
if impl(ghc < 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.10.*
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
|
||||
executable smp-server
|
||||
if flag(client_library)
|
||||
buildable: False
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Static
|
||||
@@ -313,56 +363,230 @@ executable smp-server
|
||||
hs-source-dirs:
|
||||
apps/smp-server
|
||||
apps/smp-server/web
|
||||
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
|
||||
default-extensions:
|
||||
StrictData
|
||||
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-unused-packages -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
|
||||
build-depends:
|
||||
base
|
||||
, bytestring
|
||||
, directory
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
, asn1-encoding ==0.9.*
|
||||
, asn1-types ==0.3.*
|
||||
, async ==2.2.*
|
||||
, attoparsec ==0.14.*
|
||||
, base >=4.14 && <5
|
||||
, base64-bytestring >=1.0 && <1.3
|
||||
, case-insensitive ==1.2.*
|
||||
, composition ==1.0.*
|
||||
, constraints >=0.12 && <0.14
|
||||
, containers ==0.6.*
|
||||
, crypton ==0.34.*
|
||||
, crypton-x509 ==1.7.*
|
||||
, crypton-x509-store ==1.6.*
|
||||
, crypton-x509-validation ==1.6.*
|
||||
, cryptostore ==0.3.*
|
||||
, data-default ==0.7.*
|
||||
, direct-sqlcipher ==2.3.*
|
||||
, directory ==1.3.*
|
||||
, file-embed
|
||||
, filepath
|
||||
, network
|
||||
, simple-logger
|
||||
, filepath ==1.4.*
|
||||
, hourglass ==0.2.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
, ini ==0.4.1
|
||||
, iproute ==1.7.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.18.*
|
||||
, mtl >=2.3.1 && <3.0
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq
|
||||
, text
|
||||
, unliftio
|
||||
, wai
|
||||
, socks ==0.6.*
|
||||
, sqlcipher-simple ==0.4.*
|
||||
, stm ==2.5.*
|
||||
, temporary ==1.3.*
|
||||
, time ==1.12.*
|
||||
, time-manager ==0.0.*
|
||||
, tls >=1.7.0 && <1.8
|
||||
, transformers ==0.6.*
|
||||
, unliftio ==0.2.*
|
||||
, unliftio-core ==0.2.*
|
||||
, wai-app-static
|
||||
, warp ==3.3.30
|
||||
, warp-tls ==3.4.7
|
||||
, warp
|
||||
, warp-tls
|
||||
, websockets ==0.12.*
|
||||
, yaml ==0.11.*
|
||||
, zstd ==0.1.3.*
|
||||
default-language: Haskell2010
|
||||
if flag(swift)
|
||||
cpp-options: -DswiftJSON
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.11.*
|
||||
, template-haskell ==2.20.*
|
||||
, text >=2.0.1 && <2.2
|
||||
if impl(ghc < 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.10.*
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
|
||||
executable xftp
|
||||
if flag(client_library)
|
||||
buildable: False
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_simplexmq
|
||||
hs-source-dirs:
|
||||
apps/xftp
|
||||
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
|
||||
default-extensions:
|
||||
StrictData
|
||||
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-unused-packages -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
|
||||
build-depends:
|
||||
base
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
, asn1-encoding ==0.9.*
|
||||
, asn1-types ==0.3.*
|
||||
, async ==2.2.*
|
||||
, attoparsec ==0.14.*
|
||||
, base >=4.14 && <5
|
||||
, base64-bytestring >=1.0 && <1.3
|
||||
, case-insensitive ==1.2.*
|
||||
, composition ==1.0.*
|
||||
, constraints >=0.12 && <0.14
|
||||
, containers ==0.6.*
|
||||
, crypton ==0.34.*
|
||||
, crypton-x509 ==1.7.*
|
||||
, crypton-x509-store ==1.6.*
|
||||
, crypton-x509-validation ==1.6.*
|
||||
, cryptostore ==0.3.*
|
||||
, data-default ==0.7.*
|
||||
, direct-sqlcipher ==2.3.*
|
||||
, directory ==1.3.*
|
||||
, filepath ==1.4.*
|
||||
, hourglass ==0.2.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
, ini ==0.4.1
|
||||
, iproute ==1.7.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.18.*
|
||||
, mtl >=2.3.1 && <3.0
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq
|
||||
, socks ==0.6.*
|
||||
, sqlcipher-simple ==0.4.*
|
||||
, stm ==2.5.*
|
||||
, temporary ==1.3.*
|
||||
, time ==1.12.*
|
||||
, time-manager ==0.0.*
|
||||
, tls >=1.7.0 && <1.8
|
||||
, transformers ==0.6.*
|
||||
, unliftio ==0.2.*
|
||||
, unliftio-core ==0.2.*
|
||||
, websockets ==0.12.*
|
||||
, yaml ==0.11.*
|
||||
, zstd ==0.1.3.*
|
||||
default-language: Haskell2010
|
||||
if flag(swift)
|
||||
cpp-options: -DswiftJSON
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.11.*
|
||||
, template-haskell ==2.20.*
|
||||
, text >=2.0.1 && <2.2
|
||||
if impl(ghc < 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.10.*
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
|
||||
executable xftp-server
|
||||
if flag(client_library)
|
||||
buildable: False
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_simplexmq
|
||||
hs-source-dirs:
|
||||
apps/xftp-server
|
||||
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
|
||||
default-extensions:
|
||||
StrictData
|
||||
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-unused-packages -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
|
||||
build-depends:
|
||||
base
|
||||
, simple-logger
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
, asn1-encoding ==0.9.*
|
||||
, asn1-types ==0.3.*
|
||||
, async ==2.2.*
|
||||
, attoparsec ==0.14.*
|
||||
, base >=4.14 && <5
|
||||
, base64-bytestring >=1.0 && <1.3
|
||||
, case-insensitive ==1.2.*
|
||||
, composition ==1.0.*
|
||||
, constraints >=0.12 && <0.14
|
||||
, containers ==0.6.*
|
||||
, crypton ==0.34.*
|
||||
, crypton-x509 ==1.7.*
|
||||
, crypton-x509-store ==1.6.*
|
||||
, crypton-x509-validation ==1.6.*
|
||||
, cryptostore ==0.3.*
|
||||
, data-default ==0.7.*
|
||||
, direct-sqlcipher ==2.3.*
|
||||
, directory ==1.3.*
|
||||
, filepath ==1.4.*
|
||||
, hourglass ==0.2.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
, ini ==0.4.1
|
||||
, iproute ==1.7.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.18.*
|
||||
, mtl >=2.3.1 && <3.0
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq
|
||||
, socks ==0.6.*
|
||||
, sqlcipher-simple ==0.4.*
|
||||
, stm ==2.5.*
|
||||
, temporary ==1.3.*
|
||||
, time ==1.12.*
|
||||
, time-manager ==0.0.*
|
||||
, tls >=1.7.0 && <1.8
|
||||
, transformers ==0.6.*
|
||||
, unliftio ==0.2.*
|
||||
, unliftio-core ==0.2.*
|
||||
, websockets ==0.12.*
|
||||
, yaml ==0.11.*
|
||||
, zstd ==0.1.3.*
|
||||
default-language: Haskell2010
|
||||
if flag(swift)
|
||||
cpp-options: -DswiftJSON
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.11.*
|
||||
, template-haskell ==2.20.*
|
||||
, text >=2.0.1 && <2.2
|
||||
if impl(ghc < 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.10.*
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
|
||||
test-suite simplexmq-test
|
||||
if flag(client_library)
|
||||
buildable: False
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Test.hs
|
||||
other-modules:
|
||||
@@ -374,17 +598,13 @@ test-suite simplexmq-test
|
||||
AgentTests.MigrationTests
|
||||
AgentTests.NotificationTests
|
||||
AgentTests.SchemaDump
|
||||
AgentTests.ServerChoice
|
||||
AgentTests.SQLiteTests
|
||||
CLITests
|
||||
CoreTests.BatchingTests
|
||||
CoreTests.CryptoFileTests
|
||||
CoreTests.CryptoTests
|
||||
CoreTests.EncodingTests
|
||||
CoreTests.MsgStoreTests
|
||||
CoreTests.RetryIntervalTests
|
||||
CoreTests.SOCKSSettings
|
||||
CoreTests.StoreLogTests
|
||||
CoreTests.TRcvQueuesTests
|
||||
CoreTests.UtilTests
|
||||
CoreTests.VersionRangeTests
|
||||
@@ -401,59 +621,83 @@ test-suite simplexmq-test
|
||||
XFTPCLI
|
||||
XFTPClient
|
||||
XFTPServerTests
|
||||
Static
|
||||
Static.Embedded
|
||||
Paths_simplexmq
|
||||
hs-source-dirs:
|
||||
tests
|
||||
apps/smp-server/web
|
||||
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 -with-rtsopts=-N1
|
||||
default-extensions:
|
||||
StrictData
|
||||
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-unused-packages -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 -with-rtsopts=-N1
|
||||
build-depends:
|
||||
base
|
||||
, aeson
|
||||
, async
|
||||
, base64-bytestring
|
||||
, bytestring
|
||||
, containers
|
||||
, crypton
|
||||
, crypton-x509
|
||||
, crypton-x509-store
|
||||
, crypton-x509-validation
|
||||
, deepseq ==1.4.*
|
||||
, directory
|
||||
, file-embed
|
||||
, filepath
|
||||
, generic-random ==1.5.*
|
||||
, hashable
|
||||
, hspec ==2.11.*
|
||||
, http-client
|
||||
, http-types
|
||||
, http2
|
||||
, HUnit ==1.6.*
|
||||
, ini
|
||||
, iso8601-time
|
||||
, main-tester ==0.2.*
|
||||
, memory
|
||||
, mtl
|
||||
, network
|
||||
, process
|
||||
HUnit ==1.6.*
|
||||
, QuickCheck ==2.14.*
|
||||
, random
|
||||
, aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
, asn1-encoding ==0.9.*
|
||||
, asn1-types ==0.3.*
|
||||
, async ==2.2.*
|
||||
, attoparsec ==0.14.*
|
||||
, base >=4.14 && <5
|
||||
, base64-bytestring >=1.0 && <1.3
|
||||
, case-insensitive ==1.2.*
|
||||
, composition ==1.0.*
|
||||
, constraints >=0.12 && <0.14
|
||||
, containers ==0.6.*
|
||||
, crypton ==0.34.*
|
||||
, crypton-x509 ==1.7.*
|
||||
, crypton-x509-store ==1.6.*
|
||||
, crypton-x509-validation ==1.6.*
|
||||
, cryptostore ==0.3.*
|
||||
, data-default ==0.7.*
|
||||
, deepseq ==1.4.*
|
||||
, direct-sqlcipher ==2.3.*
|
||||
, directory ==1.3.*
|
||||
, filepath ==1.4.*
|
||||
, generic-random ==1.5.*
|
||||
, hourglass ==0.2.*
|
||||
, hspec ==2.11.*
|
||||
, hspec-core ==2.11.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
, ini ==0.4.1
|
||||
, iproute ==1.7.*
|
||||
, iso8601-time ==0.1.*
|
||||
, main-tester ==0.2.*
|
||||
, memory ==0.18.*
|
||||
, mtl >=2.3.1 && <3.0
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, silently ==1.2.*
|
||||
, simple-logger
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq
|
||||
, sqlcipher-simple
|
||||
, stm
|
||||
, text
|
||||
, time
|
||||
, socks ==0.6.*
|
||||
, sqlcipher-simple ==0.4.*
|
||||
, stm ==2.5.*
|
||||
, temporary ==1.3.*
|
||||
, time ==1.12.*
|
||||
, time-manager ==0.0.*
|
||||
, timeit ==2.0.*
|
||||
, transformers
|
||||
, unliftio
|
||||
, unliftio-core
|
||||
, unordered-containers
|
||||
, wai
|
||||
, wai-app-static
|
||||
, warp
|
||||
, warp-tls
|
||||
, yaml
|
||||
, tls >=1.7.0 && <1.8
|
||||
, transformers ==0.6.*
|
||||
, unliftio ==0.2.*
|
||||
, unliftio-core ==0.2.*
|
||||
, websockets ==0.12.*
|
||||
, yaml ==0.11.*
|
||||
, zstd ==0.1.3.*
|
||||
default-language: Haskell2010
|
||||
if flag(swift)
|
||||
cpp-options: -DswiftJSON
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.11.*
|
||||
, template-haskell ==2.20.*
|
||||
, text >=2.0.1 && <2.2
|
||||
if impl(ghc < 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.10.*
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
|
||||
@@ -45,7 +45,7 @@ import Data.List (foldl', partition, sortOn)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
@@ -74,7 +74,7 @@ import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String (strDecode, strEncode)
|
||||
import Simplex.Messaging.Protocol (ProtocolServer, ProtocolType (..), XFTPServer)
|
||||
import Simplex.Messaging.Protocol (EntityId, ProtocolServer, ProtocolType (..), XFTPServer)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (catchAll_, liftError, tshow, unlessM, whenM)
|
||||
import System.FilePath (takeFileName, (</>))
|
||||
@@ -190,9 +190,8 @@ runXFTPRcvWorker c srv Worker {doWork} = do
|
||||
runXFTPOperation :: AgentConfig -> AM ()
|
||||
runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} =
|
||||
withWork c doWork (\db -> getNextRcvChunkToDownload db srv rcvFilesTTL) $ \case
|
||||
(RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _, redirectEntityId_) ->
|
||||
rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ (Just fileTmpPath) (INTERNAL "chunk has no replicas")
|
||||
(fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays, redirectEntityId_) -> do
|
||||
(RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _) -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (INTERNAL "chunk has no replicas")
|
||||
(fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays) -> do
|
||||
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
|
||||
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
|
||||
liftIO $ waitWhileSuspended c
|
||||
@@ -203,7 +202,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
|
||||
where
|
||||
retryLoop loop e replicaDelay = do
|
||||
flip catchAgentError (\_ -> pure ()) $ do
|
||||
when (serverHostError e) $ notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFWARN e)
|
||||
when (serverHostError e) $ notify c rcvFileEntityId $ RFWARN e
|
||||
liftIO $ closeXFTPServerClient c userId server digest
|
||||
withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
|
||||
liftIO $ assertAgentForeground c
|
||||
@@ -212,7 +211,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
|
||||
atomically . incXFTPServerStat c userId srv $ case e of
|
||||
XFTP _ XFTP.AUTH -> downloadAuthErrs
|
||||
_ -> downloadErrs
|
||||
rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ (Just fileTmpPath) e
|
||||
rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) e
|
||||
downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM ()
|
||||
downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do
|
||||
unlessM ((approvedRelays ||) <$> ipAddressProtected') $ throwE $ FILE NOT_APPROVED
|
||||
@@ -263,11 +262,11 @@ retryOnError name loop done e = do
|
||||
then loop
|
||||
else done
|
||||
|
||||
rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
|
||||
rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ tmpPath err = do
|
||||
rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
|
||||
rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath err = do
|
||||
lift $ forM_ tmpPath (removePath <=< toFSFilePath)
|
||||
withStore' c $ \db -> updateRcvFileError db rcvFileId (show err)
|
||||
notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFERR err)
|
||||
notify c rcvFileEntityId $ RFERR err
|
||||
|
||||
runXFTPRcvLocalWorker :: AgentClient -> Worker -> AM ()
|
||||
runXFTPRcvLocalWorker c Worker {doWork} = do
|
||||
@@ -280,8 +279,8 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
|
||||
runXFTPOperation :: AgentConfig -> AM ()
|
||||
runXFTPOperation AgentConfig {rcvFilesTTL} =
|
||||
withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $
|
||||
\f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath, redirect} ->
|
||||
decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId (redirectEntityId <$> redirect) tmpPath
|
||||
\f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
|
||||
decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath
|
||||
decryptFile :: RcvFile -> AM ()
|
||||
decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do
|
||||
let CryptoFile savePath cfArgs = saveFile
|
||||
@@ -347,7 +346,7 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do
|
||||
batchFiles :: (DB.Connection -> DBRcvFileId -> IO a) -> [RcvFile] -> AM' [Either AgentErrorType a]
|
||||
batchFiles f rcvFiles = withStoreBatch' c $ \db -> map (\RcvFile {rcvFileId} -> f db rcvFileId) rcvFiles
|
||||
|
||||
notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m ()
|
||||
notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> AEvent e -> m ()
|
||||
notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd)
|
||||
|
||||
xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId
|
||||
@@ -461,14 +460,14 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
|
||||
pure srv
|
||||
where
|
||||
tryCreate = do
|
||||
triedHosts <- newTVarIO S.empty
|
||||
usedSrvs <- newTVarIO ([] :: [XFTPServer])
|
||||
let AgentClient {xftpServers} = c
|
||||
userSrvCount <- liftIO $ length <$> TM.lookupIO userId xftpServers
|
||||
withRetryIntervalCount (riFast ri) $ \n _ loop -> do
|
||||
liftIO $ waitWhileSuspended c
|
||||
liftIO $ waitForUserNetwork c
|
||||
let triedAllSrvs = n > userSrvCount
|
||||
createWithNextSrv triedHosts
|
||||
createWithNextSrv usedSrvs
|
||||
`catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop triedAllSrvs e) (throwE e) e
|
||||
where
|
||||
-- we don't do closeXFTPServerClient here to not risk closing connection for concurrent chunk upload
|
||||
@@ -477,10 +476,10 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
|
||||
when (triedAllSrvs && serverHostError e) $ notify c sndFileEntityId $ SFWARN e
|
||||
liftIO $ assertAgentForeground c
|
||||
loop
|
||||
createWithNextSrv triedHosts = do
|
||||
createWithNextSrv usedSrvs = do
|
||||
deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId
|
||||
when deleted $ throwE $ FILE NO_FILE
|
||||
withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do
|
||||
withNextSrv c userId usedSrvs [] $ \srvAuth -> do
|
||||
replica <- agentXFTPNewChunk c ch numRecipients' srvAuth
|
||||
pure (replica, srvAuth)
|
||||
|
||||
@@ -546,8 +545,8 @@ runXFTPSndWorker c srv Worker {doWork} = do
|
||||
withStore' c $ \db -> updateSndFileComplete db sndFileId
|
||||
where
|
||||
addRecipients :: SndFileChunk -> SndFileChunkReplica -> AM SndFileChunkReplica
|
||||
addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {sndChunkReplicaId, rcvIdsKeys}
|
||||
| length rcvIdsKeys > numRecipients = throwE $ INTERNAL ("too many recipients, sndChunkReplicaId = " <> show sndChunkReplicaId)
|
||||
addRecipients ch@SndFileChunk {numRecipients} cr@SndFileChunkReplica {rcvIdsKeys}
|
||||
| length rcvIdsKeys > numRecipients = throwE $ INTERNAL "too many recipients"
|
||||
| length rcvIdsKeys == numRecipients = pure cr
|
||||
| otherwise = do
|
||||
let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients
|
||||
|
||||
@@ -22,13 +22,13 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Word (Word32)
|
||||
import qualified Data.X509 as X
|
||||
import qualified Data.X509.Validation as XV
|
||||
import qualified Network.HTTP.Types as N
|
||||
import qualified Network.HTTP2.Client as H
|
||||
import Simplex.FileTransfer.Protocol
|
||||
import Simplex.FileTransfer.Server.Env (supportedXFTPhandshakes)
|
||||
import Simplex.FileTransfer.Transport
|
||||
import Simplex.Messaging.Client
|
||||
( NetworkConfig (..),
|
||||
@@ -36,8 +36,8 @@ import Simplex.Messaging.Client
|
||||
TransportSession,
|
||||
chooseTransportHost,
|
||||
defaultNetworkConfig,
|
||||
proxyUsername,
|
||||
transportClientConfig,
|
||||
clientSocksCredentials,
|
||||
unexpectedResponse,
|
||||
)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -50,9 +50,8 @@ import Simplex.Messaging.Protocol
|
||||
ProtocolServer (..),
|
||||
RecipientId,
|
||||
SenderId,
|
||||
pattern NoEntity,
|
||||
)
|
||||
import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.Client
|
||||
@@ -98,21 +97,21 @@ defaultXFTPClientConfig =
|
||||
clientALPN = Just supportedXFTPhandshakes
|
||||
}
|
||||
|
||||
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
|
||||
getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} proxySessTs disconnected = runExceptT $ do
|
||||
let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
|
||||
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
|
||||
getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do
|
||||
let username = proxyUsername transportSession
|
||||
ProtocolServer _ host port keyHash = srv
|
||||
useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
|
||||
let tcConfig = (transportClientConfig xftpNetworkConfig useHost False) {alpn = clientALPN}
|
||||
let tcConfig = (transportClientConfig xftpNetworkConfig useHost) {alpn = clientALPN}
|
||||
http2Config = xftpHTTP2Config tcConfig config
|
||||
clientVar <- newTVarIO Nothing
|
||||
let usePort = if null port then "443" else port
|
||||
clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected
|
||||
http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client socksCreds useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
|
||||
http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
|
||||
let HTTP2Client {sessionId, sessionALPN} = http2Client
|
||||
v = VersionXFTP 1
|
||||
thServerVRange = versionToRange v
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True}
|
||||
logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
|
||||
thParams@THandleParams {thVersion} <- case sessionALPN of
|
||||
Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
|
||||
@@ -172,7 +171,7 @@ xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfi
|
||||
xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} =
|
||||
defaultHTTP2ClientConfig
|
||||
{ bodyHeadSize = xftpBlockSize,
|
||||
suportedTLSParams = defaultSupportedParams,
|
||||
suportedTLSParams = supportedParameters,
|
||||
connTimeout = tcpConnectTimeout,
|
||||
transportConfig
|
||||
}
|
||||
@@ -223,7 +222,7 @@ createXFTPChunk ::
|
||||
Maybe BasicAuth ->
|
||||
ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
|
||||
createXFTPChunk c spKey file rcps auth_ =
|
||||
sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_) Nothing >>= \case
|
||||
sendXFTPCommand c spKey "" (FNEW file rcps auth_) Nothing >>= \case
|
||||
(FRSndIds sId rIds, body) -> noFile body (sId, rIds)
|
||||
(r, _) -> throwE $ unexpectedResponse r
|
||||
|
||||
@@ -279,7 +278,7 @@ pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
pingXFTP c@XFTPClient {thParams} = do
|
||||
t <-
|
||||
liftEither . first PCETransportError $
|
||||
xftpEncodeTransmission thParams ("", NoEntity, FileCmd SFRecipient PING)
|
||||
xftpEncodeTransmission thParams ("", "", FileCmd SFRecipient PING)
|
||||
(r, _) <- sendXFTPTransmission c t Nothing
|
||||
case r of
|
||||
FRPong -> pure ()
|
||||
|
||||
@@ -16,7 +16,6 @@ import Data.Bifunctor (first)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Simplex.FileTransfer.Client
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
|
||||
@@ -31,7 +30,6 @@ type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient)
|
||||
|
||||
data XFTPClientAgent = XFTPClientAgent
|
||||
{ xftpClients :: TMap XFTPServer XFTPClientVar,
|
||||
startedAt :: UTCTime,
|
||||
config :: XFTPClientAgentConfig
|
||||
}
|
||||
|
||||
@@ -58,20 +56,19 @@ data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError
|
||||
newXFTPAgent :: XFTPClientAgentConfig -> IO XFTPClientAgent
|
||||
newXFTPAgent config = do
|
||||
xftpClients <- TM.emptyIO
|
||||
startedAt <- getCurrentTime
|
||||
pure XFTPClientAgent {xftpClients, startedAt, config}
|
||||
pure XFTPClientAgent {xftpClients, config}
|
||||
|
||||
type ME a = ExceptT XFTPClientAgentError IO a
|
||||
|
||||
getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
|
||||
getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
|
||||
getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
|
||||
atomically getClientVar >>= either newXFTPClient waitForXFTPClient
|
||||
where
|
||||
connectClient :: ME XFTPClient
|
||||
connectClient =
|
||||
ExceptT $
|
||||
first (XFTPClientAgentError srv)
|
||||
<$> getXFTPClient (1, srv, Nothing) (xftpConfig config) startedAt clientDisconnected
|
||||
<$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected
|
||||
|
||||
clientDisconnected :: XFTPClient -> IO ()
|
||||
clientDisconnected _ = do
|
||||
|
||||
@@ -44,7 +44,7 @@ import Data.List (foldl', sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Data.Word (Word32)
|
||||
|
||||
@@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@@ -55,7 +53,7 @@ import Data.List (foldl', sortOn)
|
||||
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 qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
@@ -141,9 +139,12 @@ data FileChunkReplica = FileChunkReplica
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: XFTPFileId}
|
||||
newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: ByteString}
|
||||
deriving (Eq, Show)
|
||||
deriving newtype (StrEncoding)
|
||||
|
||||
instance StrEncoding ChunkReplicaId where
|
||||
strEncode (ChunkReplicaId fid) = strEncode fid
|
||||
strP = ChunkReplicaId <$> strP
|
||||
|
||||
instance FromJSON ChunkReplicaId where
|
||||
parseJSON = strParseJSON "ChunkReplicaId"
|
||||
@@ -152,6 +153,10 @@ instance ToJSON ChunkReplicaId where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
instance FromField ChunkReplicaId where fromField f = ChunkReplicaId <$> fromField f
|
||||
|
||||
instance ToField ChunkReplicaId where toField (ChunkReplicaId s) = toField s
|
||||
|
||||
data YAMLFileDescription = YAMLFileDescription
|
||||
{ party :: FileParty,
|
||||
size :: String,
|
||||
|
||||
@@ -41,7 +41,6 @@ import Simplex.Messaging.Protocol
|
||||
ProtocolType (..),
|
||||
RcvPublicAuthKey,
|
||||
RcvPublicDhKey,
|
||||
EntityId (..),
|
||||
RecipientId,
|
||||
SenderId,
|
||||
SentRawTransmission,
|
||||
@@ -171,7 +170,7 @@ data FileInfo = FileInfo
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type XFTPFileId = EntityId
|
||||
type XFTPFileId = ByteString
|
||||
|
||||
instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where
|
||||
type Tag (FileCommand p) = FileCommandTag p
|
||||
@@ -192,7 +191,7 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand
|
||||
fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials (auth, _, EntityId fileId, _) cmd = case cmd of
|
||||
checkCredentials (auth, _, fileId, _) cmd = case cmd of
|
||||
-- FNEW must not have signature and chunk ID
|
||||
FNEW {}
|
||||
| isNothing auth -> Left $ CMD NO_AUTH
|
||||
@@ -302,7 +301,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
|
||||
PEBlock -> BLOCK
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
|
||||
checkCredentials (_, _, entId, _) cmd = case cmd of
|
||||
FRSndIds {} -> noEntity
|
||||
-- ERR response does not always have entity ID
|
||||
FRErr _ -> Right cmd
|
||||
|
||||
@@ -9,7 +9,6 @@
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
@@ -33,11 +32,11 @@ import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
|
||||
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import Data.Word (Word32)
|
||||
import qualified Data.X509 as X
|
||||
import GHC.IO.Handle (hSetNewlineMode)
|
||||
import GHC.IORef (atomicSwapIORef)
|
||||
import GHC.Stats (getRTSStats)
|
||||
import qualified Network.HTTP.Types as N
|
||||
import qualified Network.HTTP2.Server as H
|
||||
@@ -53,20 +52,18 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (CorrId (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
|
||||
import Simplex.Messaging.Protocol (CorrId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth)
|
||||
import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
|
||||
import Simplex.Messaging.Server.Control (CPClientRole (..))
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemTime)
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ALPN, SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.Buffer (trimCR)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
|
||||
import Simplex.Messaging.Transport.HTTP2.Server
|
||||
import Simplex.Messaging.Transport.Server (runLocalTCPServer)
|
||||
import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials)
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
import System.Exit (exitFailure)
|
||||
@@ -92,35 +89,36 @@ data XFTPTransportRequest = XFTPTransportRequest
|
||||
runXFTPServer :: XFTPServerConfig -> IO ()
|
||||
runXFTPServer cfg = do
|
||||
started <- newEmptyTMVarIO
|
||||
runXFTPServerBlocking started cfg $ Just supportedXFTPhandshakes
|
||||
runXFTPServerBlocking started cfg
|
||||
|
||||
runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> Maybe [ALPN] -> IO ()
|
||||
runXFTPServerBlocking started cfg alpn_ = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started alpn_)
|
||||
runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
|
||||
runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
|
||||
|
||||
data Handshake
|
||||
= HandshakeSent C.PrivateKeyX25519
|
||||
| HandshakeAccepted (THandleParams XFTPVersion 'TServer)
|
||||
|
||||
xftpServer :: XFTPServerConfig -> TMVar Bool -> Maybe [ALPN] -> M ()
|
||||
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started alpn_ = do
|
||||
xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
|
||||
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
|
||||
mapM_ (expireServerFiles Nothing) fileExpiration
|
||||
restoreServerStats
|
||||
raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
|
||||
where
|
||||
runServer :: M ()
|
||||
runServer = do
|
||||
srvCreds@(chain, pk) <- asks tlsServerCreds
|
||||
serverParams <- asks tlsServerParams
|
||||
let (chain, pk) = tlsServerCredentials serverParams
|
||||
signKey <- liftIO $ case C.x509ToPrivate (pk, []) >>= C.privKey of
|
||||
Right pk' -> pure pk'
|
||||
Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure
|
||||
env <- ask
|
||||
sessions <- liftIO TM.emptyIO
|
||||
let cleanup sessionId = atomically $ TM.delete sessionId sessions
|
||||
liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds alpn_ transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
|
||||
liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
|
||||
reqBody <- getHTTP2Body r xftpBlockSize
|
||||
let v = VersionXFTP 1
|
||||
thServerVRange = versionToRange v
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True}
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True}
|
||||
req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
|
||||
flip runReaderT env $ case sessionALPN of
|
||||
Nothing -> processRequest req0
|
||||
@@ -181,7 +179,6 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
stopServer = do
|
||||
withFileLog closeStoreLog
|
||||
saveServerStats
|
||||
logInfo "Server stopped"
|
||||
|
||||
expireFilesThread_ :: XFTPServerConfig -> [M ()]
|
||||
expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
|
||||
@@ -210,17 +207,17 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
withFile statsFilePath AppendMode $ \h -> liftIO $ do
|
||||
hSetBuffering h LineBuffering
|
||||
ts <- getCurrentTime
|
||||
fromTime' <- atomicSwapIORef fromTime ts
|
||||
filesCreated' <- atomicSwapIORef filesCreated 0
|
||||
fileRecipients' <- atomicSwapIORef fileRecipients 0
|
||||
filesUploaded' <- atomicSwapIORef filesUploaded 0
|
||||
filesExpired' <- atomicSwapIORef filesExpired 0
|
||||
filesDeleted' <- atomicSwapIORef filesDeleted 0
|
||||
files <- liftIO $ periodStatCounts filesDownloaded ts
|
||||
fileDownloads' <- atomicSwapIORef fileDownloads 0
|
||||
fileDownloadAcks' <- atomicSwapIORef fileDownloadAcks 0
|
||||
filesCount' <- readIORef filesCount
|
||||
filesSize' <- readIORef filesSize
|
||||
fromTime' <- atomically $ swapTVar fromTime ts
|
||||
filesCreated' <- atomically $ swapTVar filesCreated 0
|
||||
fileRecipients' <- atomically $ swapTVar fileRecipients 0
|
||||
filesUploaded' <- atomically $ swapTVar filesUploaded 0
|
||||
filesExpired' <- atomically $ swapTVar filesExpired 0
|
||||
filesDeleted' <- atomically $ swapTVar filesDeleted 0
|
||||
files <- atomically $ periodStatCounts filesDownloaded ts
|
||||
fileDownloads' <- atomically $ swapTVar fileDownloads 0
|
||||
fileDownloadAcks' <- atomically $ swapTVar fileDownloadAcks 0
|
||||
filesCount' <- readTVarIO filesCount
|
||||
filesSize' <- readTVarIO filesSize
|
||||
hPutStrLn h $
|
||||
intercalate
|
||||
","
|
||||
@@ -250,7 +247,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
u <- askUnliftIO
|
||||
liftIO $ do
|
||||
labelMyThread "control port server"
|
||||
runLocalTCPServer cpStarted port $ runCPClient u
|
||||
runTCPServer cpStarted port $ runCPClient u
|
||||
where
|
||||
runCPClient :: UnliftIO (ReaderT XFTPEnv IO) -> Socket -> IO ()
|
||||
runCPClient u sock = do
|
||||
@@ -312,7 +309,7 @@ data ServerFile = ServerFile
|
||||
|
||||
processRequest :: XFTPTransportRequest -> M ()
|
||||
processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
|
||||
| B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
|
||||
| B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
|
||||
| otherwise = do
|
||||
case xftpDecodeTransmission thParams bodyHead of
|
||||
Right (sig_, signed, (corrId, fId, cmdOrErr)) ->
|
||||
@@ -325,7 +322,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
|
||||
Left e -> send (FRErr e) Nothing
|
||||
where
|
||||
send resp = sendXFTPResponse (corrId, fId, resp)
|
||||
Left e -> sendXFTPResponse ("", NoEntity, FRErr e) Nothing
|
||||
Left e -> sendXFTPResponse ("", "", FRErr e) Nothing
|
||||
where
|
||||
sendXFTPResponse (corrId, fId, resp) serverFile_ = do
|
||||
let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
|
||||
@@ -400,7 +397,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
r <- runExceptT $ do
|
||||
sizes <- asks $ allowedChunkSizes . config
|
||||
unless (size file `elem` sizes) $ throwE SIZE
|
||||
ts <- liftIO getFileTime
|
||||
ts <- liftIO getSystemTime
|
||||
-- TODO validate body empty
|
||||
sId <- ExceptT $ addFileRetry st file 3 ts
|
||||
rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
|
||||
@@ -408,12 +405,12 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
logAddFile sl sId file ts
|
||||
logAddRecipients sl sId rcps
|
||||
stats <- asks serverStats
|
||||
lift $ incFileStat filesCreated
|
||||
liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
|
||||
atomically $ modifyTVar' (filesCreated stats) (+ 1)
|
||||
atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
|
||||
let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
|
||||
pure $ FRSndIds sId rIds
|
||||
pure $ either FRErr id r
|
||||
addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId)
|
||||
addFileRetry :: FileStore -> FileInfo -> Int -> SystemTime -> M (Either XFTPErrorType XFTPFileId)
|
||||
addFileRetry st file n ts =
|
||||
retryAdd n $ \sId -> runExceptT $ do
|
||||
ExceptT $ addFile st sId file ts
|
||||
@@ -438,7 +435,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
|
||||
lift $ withFileLog $ \sl -> logAddRecipients sl sId rcps
|
||||
stats <- asks serverStats
|
||||
liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
|
||||
atomically $ modifyTVar' (fileRecipients stats) (+ length rks)
|
||||
let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
|
||||
pure $ FRRcvIds rIds
|
||||
pure $ either FRErr id r
|
||||
@@ -466,19 +463,19 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
\used -> let used' = used + fromIntegral size in if used' <= quota then (True, used') else (False, used)
|
||||
receive = do
|
||||
path <- asks $ filesPath . config
|
||||
let fPath = path </> B.unpack (B64.encode $ unEntityId senderId)
|
||||
let fPath = path </> B.unpack (B64.encode senderId)
|
||||
receiveChunk (XFTPRcvChunkSpec fPath size digest) >>= \case
|
||||
Right () -> do
|
||||
stats <- asks serverStats
|
||||
withFileLog $ \sl -> logPutFile sl senderId fPath
|
||||
atomically $ writeTVar filePath (Just fPath)
|
||||
incFileStat filesUploaded
|
||||
incFileStat filesCount
|
||||
liftIO $ atomicModifyIORef'_ (filesSize stats) (+ fromIntegral size)
|
||||
atomically $ modifyTVar' (filesUploaded stats) (+ 1)
|
||||
atomically $ modifyTVar' (filesCount stats) (+ 1)
|
||||
atomically $ modifyTVar' (filesSize stats) (+ fromIntegral size)
|
||||
pure FROk
|
||||
Left e -> do
|
||||
us <- asks $ usedStorage . store
|
||||
atomically $ modifyTVar' us $ subtract (fromIntegral size)
|
||||
atomically . modifyTVar' us $ subtract (fromIntegral size)
|
||||
liftIO $ whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError
|
||||
pure $ FRErr e
|
||||
receiveChunk spec = do
|
||||
@@ -497,8 +494,8 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
case LC.cbInit dhSecret cbNonce of
|
||||
Right sbState -> do
|
||||
stats <- asks serverStats
|
||||
incFileStat fileDownloads
|
||||
liftIO $ updatePeriodStats (filesDownloaded stats) senderId
|
||||
atomically $ modifyTVar' (fileDownloads stats) (+ 1)
|
||||
atomically $ updatePeriodStats (filesDownloaded stats) senderId
|
||||
pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
|
||||
_ -> pure (FRErr INTERNAL, Nothing)
|
||||
_ -> pure (FRErr NO_FILE, Nothing)
|
||||
@@ -514,7 +511,8 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
withFileLog (`logAckFile` rId)
|
||||
st <- asks store
|
||||
atomically $ deleteRecipient st rId fr
|
||||
incFileStat fileDownloadAcks
|
||||
stats <- asks serverStats
|
||||
atomically $ modifyTVar' (fileDownloadAcks stats) (+ 1)
|
||||
pure FROk
|
||||
|
||||
deleteServerFile_ :: FileRec -> M (Either XFTPErrorType ())
|
||||
@@ -526,14 +524,11 @@ deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do
|
||||
ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats))
|
||||
st <- asks store
|
||||
void $ atomically $ deleteFile st senderId
|
||||
lift $ incFileStat filesDeleted
|
||||
atomically $ modifyTVar' (filesDeleted stats) (+ 1)
|
||||
where
|
||||
deletedStats stats = do
|
||||
liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)
|
||||
liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
|
||||
|
||||
getFileTime :: IO RoundedSystemTime
|
||||
getFileTime = getRoundedSystemTime fileTimePrecision
|
||||
atomically $ modifyTVar' (filesCount stats) (subtract 1)
|
||||
atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
|
||||
|
||||
expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
|
||||
expireServerFiles itemDelay expCfg = do
|
||||
@@ -559,21 +554,24 @@ expireServerFiles itemDelay expCfg = do
|
||||
delete st sId = do
|
||||
withFileLog (`logDeleteFile` sId)
|
||||
void . atomically $ deleteFile st sId -- will not update usedStorage if sId isn't in store
|
||||
incFileStat filesExpired
|
||||
FileServerStats {filesExpired} <- asks serverStats
|
||||
atomically $ modifyTVar' filesExpired (+ 1)
|
||||
|
||||
randomId :: Int -> M ByteString
|
||||
randomId n = atomically . C.randomBytes n =<< asks random
|
||||
|
||||
getFileId :: M XFTPFileId
|
||||
getFileId = fmap EntityId . randomId =<< asks (fileIdSize . config)
|
||||
getFileId = do
|
||||
size <- asks (fileIdSize . config)
|
||||
atomically . C.randomBytes size =<< asks random
|
||||
|
||||
withFileLog :: (StoreLog 'WriteMode -> IO a) -> M ()
|
||||
withFileLog action = liftIO . mapM_ action =<< asks storeLog
|
||||
|
||||
incFileStat :: (FileServerStats -> IORef Int) -> M ()
|
||||
incFileStat :: (FileServerStats -> TVar Int) -> M ()
|
||||
incFileStat statSel = do
|
||||
stats <- asks serverStats
|
||||
liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1)
|
||||
atomically $ modifyTVar (statSel stats) (+ 1)
|
||||
|
||||
saveServerStats :: M ()
|
||||
saveServerStats =
|
||||
@@ -596,7 +594,7 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
|
||||
FileStore {files, usedStorage} <- asks store
|
||||
_filesCount <- M.size <$> readTVarIO files
|
||||
_filesSize <- readTVarIO usedStorage
|
||||
liftIO $ setFileServerStats s d {_filesCount, _filesSize}
|
||||
atomically $ setFileServerStats s d {_filesCount, _filesSize}
|
||||
renameFile f $ f <> ".bak"
|
||||
logInfo "server stats restored"
|
||||
when (statsFilesCount /= _filesCount) $ logWarn $ "Files count differs: stats: " <> tshow statsFilesCount <> ", store: " <> tshow _filesCount
|
||||
|
||||
@@ -4,14 +4,16 @@
|
||||
module Simplex.FileTransfer.Server.Control where
|
||||
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Simplex.FileTransfer.Protocol (XFTPFileId)
|
||||
import Data.ByteString (ByteString)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BasicAuth)
|
||||
|
||||
data CPClientRole = CPRNone | CPRUser | CPRAdmin
|
||||
|
||||
data ControlProtocol
|
||||
= CPAuth BasicAuth
|
||||
| CPStatsRTS
|
||||
| CPDelete XFTPFileId
|
||||
| CPDelete ByteString
|
||||
| CPHelp
|
||||
| CPQuit
|
||||
| CPSkip
|
||||
|
||||
@@ -28,7 +28,8 @@ import Simplex.FileTransfer.Transport (VersionRangeXFTP)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential)
|
||||
import Simplex.Messaging.Transport (ALPN)
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadFingerprint, loadTLSServerParams)
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import System.IO (IOMode (..))
|
||||
import UnliftIO.STM
|
||||
@@ -56,7 +57,10 @@ data XFTPServerConfig = XFTPServerConfig
|
||||
fileTimeout :: Int,
|
||||
-- | time after which inactive clients can be disconnected and check interval, seconds
|
||||
inactiveClientExpiration :: Maybe ExpirationConfig,
|
||||
xftpCredentials :: ServerCredentials,
|
||||
-- CA certificate private key is not needed for initialization
|
||||
caCertificateFile :: FilePath,
|
||||
privateKeyFile :: FilePath,
|
||||
certificateFile :: FilePath,
|
||||
-- | XFTP client-server protocol version range
|
||||
xftpServerVRange :: VersionRangeXFTP,
|
||||
-- stats config - see SMP server config
|
||||
@@ -71,7 +75,7 @@ data XFTPServerConfig = XFTPServerConfig
|
||||
defaultInactiveClientExpiration :: ExpirationConfig
|
||||
defaultInactiveClientExpiration =
|
||||
ExpirationConfig
|
||||
{ ttl = 21600, -- seconds, 6 hours
|
||||
{ ttl = 43200, -- seconds, 12 hours
|
||||
checkInterval = 3600 -- seconds, 1 hours
|
||||
}
|
||||
|
||||
@@ -81,7 +85,7 @@ data XFTPEnv = XFTPEnv
|
||||
storeLog :: Maybe (StoreLog 'WriteMode),
|
||||
random :: TVar ChaChaDRG,
|
||||
serverIdentity :: C.KeyHash,
|
||||
tlsServerCreds :: T.Credential,
|
||||
tlsServerParams :: T.ServerParams,
|
||||
serverStats :: FileServerStats
|
||||
}
|
||||
|
||||
@@ -95,8 +99,11 @@ defaultFileExpiration =
|
||||
checkInterval = 2 * 3600 -- seconds, 2 hours
|
||||
}
|
||||
|
||||
supportedXFTPhandshakes :: [ALPN]
|
||||
supportedXFTPhandshakes = ["xftp/1"]
|
||||
|
||||
newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
|
||||
newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCredentials} = do
|
||||
newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
|
||||
random <- C.newRandom
|
||||
store <- newFileStore
|
||||
storeLog <- mapM (`readWriteFileStore` store) storeLogFile
|
||||
@@ -105,10 +112,10 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCrede
|
||||
forM_ fileSizeQuota $ \quota -> do
|
||||
logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
|
||||
when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
|
||||
tlsServerCreds <- loadServerCredential xftpCredentials
|
||||
Fingerprint fp <- loadFingerprint xftpCredentials
|
||||
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
|
||||
Fingerprint fp <- loadFingerprint caCertificateFile
|
||||
serverStats <- newFileServerStats =<< getCurrentTime
|
||||
pure XFTPEnv {config, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
|
||||
pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
countUsedStorage :: M.Map k FileRec -> Int64
|
||||
countUsedStorage = M.foldl' (\acc FileRec {fileInfo = FileInfo {size}} -> acc + fromIntegral size) 0
|
||||
|
||||
@@ -19,7 +19,7 @@ import Options.Applicative
|
||||
import Simplex.FileTransfer.Chunks
|
||||
import Simplex.FileTransfer.Description (FileSize (..))
|
||||
import Simplex.FileTransfer.Server (runXFTPServer)
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration)
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes)
|
||||
import Simplex.FileTransfer.Transport (supportedFileServerVRange)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
@@ -28,7 +28,7 @@ import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||
import System.FilePath (combine)
|
||||
@@ -51,9 +51,7 @@ xftpServerCLI cfgPath logPath = do
|
||||
True -> readIniFile iniFile >>= either exitError runServer
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
Delete -> do
|
||||
confirmOrExit
|
||||
"WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
"Server NOT deleted"
|
||||
confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
deleteDirIfExists cfgPath
|
||||
deleteDirIfExists logPath
|
||||
putStrLn "Deleted configuration and log files"
|
||||
@@ -103,7 +101,6 @@ xftpServerCLI cfgPath logPath = do
|
||||
\\n\
|
||||
\# control_port_admin_password:\n\
|
||||
\# control_port_user_password:\n\
|
||||
\\n\
|
||||
\[TRANSPORT]\n\
|
||||
\# host is only used to print server address on start\n"
|
||||
<> ("host: " <> T.pack host <> "\n")
|
||||
@@ -176,12 +173,9 @@ xftpServerCLI cfgPath logPath = do
|
||||
{ ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
|
||||
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
|
||||
},
|
||||
xftpCredentials =
|
||||
ServerCredentials
|
||||
{ caCertificateFile = Just $ c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c serverCrtFile
|
||||
},
|
||||
caCertificateFile = c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c serverCrtFile,
|
||||
xftpServerVRange = supportedFileServerVRange,
|
||||
logStatsInterval = logStats $> 86400, -- seconds
|
||||
logStatsStartTime = 0, -- seconds from 00:00 UTC
|
||||
@@ -189,7 +183,8 @@ xftpServerCLI cfgPath logPath = do
|
||||
serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
|
||||
transportConfig =
|
||||
defaultTransportServerConfig
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
|
||||
alpn = Just supportedXFTPhandshakes
|
||||
},
|
||||
responseDelay = 0
|
||||
}
|
||||
|
||||
@@ -7,24 +7,25 @@ module Simplex.FileTransfer.Server.Stats where
|
||||
import Control.Applicative ((<|>))
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.IORef
|
||||
import Data.Int (Int64)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (SenderId)
|
||||
import Simplex.Messaging.Server.Stats (PeriodStats, PeriodStatsData, getPeriodStatsData, newPeriodStats, setPeriodStats)
|
||||
import UnliftIO.STM
|
||||
|
||||
data FileServerStats = FileServerStats
|
||||
{ fromTime :: IORef UTCTime,
|
||||
filesCreated :: IORef Int,
|
||||
fileRecipients :: IORef Int,
|
||||
filesUploaded :: IORef Int,
|
||||
filesExpired :: IORef Int,
|
||||
filesDeleted :: IORef Int,
|
||||
filesDownloaded :: PeriodStats,
|
||||
fileDownloads :: IORef Int,
|
||||
fileDownloadAcks :: IORef Int,
|
||||
filesCount :: IORef Int,
|
||||
filesSize :: IORef Int64
|
||||
{ fromTime :: TVar UTCTime,
|
||||
filesCreated :: TVar Int,
|
||||
fileRecipients :: TVar Int,
|
||||
filesUploaded :: TVar Int,
|
||||
filesExpired :: TVar Int,
|
||||
filesDeleted :: TVar Int,
|
||||
filesDownloaded :: PeriodStats SenderId,
|
||||
fileDownloads :: TVar Int,
|
||||
fileDownloadAcks :: TVar Int,
|
||||
filesCount :: TVar Int,
|
||||
filesSize :: TVar Int64
|
||||
}
|
||||
|
||||
data FileServerStatsData = FileServerStatsData
|
||||
@@ -34,7 +35,7 @@ data FileServerStatsData = FileServerStatsData
|
||||
_filesUploaded :: Int,
|
||||
_filesExpired :: Int,
|
||||
_filesDeleted :: Int,
|
||||
_filesDownloaded :: PeriodStatsData,
|
||||
_filesDownloaded :: PeriodStatsData SenderId,
|
||||
_fileDownloads :: Int,
|
||||
_fileDownloadAcks :: Int,
|
||||
_filesCount :: Int,
|
||||
@@ -44,48 +45,47 @@ data FileServerStatsData = FileServerStatsData
|
||||
|
||||
newFileServerStats :: UTCTime -> IO FileServerStats
|
||||
newFileServerStats ts = do
|
||||
fromTime <- newIORef ts
|
||||
filesCreated <- newIORef 0
|
||||
fileRecipients <- newIORef 0
|
||||
filesUploaded <- newIORef 0
|
||||
filesExpired <- newIORef 0
|
||||
filesDeleted <- newIORef 0
|
||||
fromTime <- newTVarIO ts
|
||||
filesCreated <- newTVarIO 0
|
||||
fileRecipients <- newTVarIO 0
|
||||
filesUploaded <- newTVarIO 0
|
||||
filesExpired <- newTVarIO 0
|
||||
filesDeleted <- newTVarIO 0
|
||||
filesDownloaded <- newPeriodStats
|
||||
fileDownloads <- newIORef 0
|
||||
fileDownloadAcks <- newIORef 0
|
||||
filesCount <- newIORef 0
|
||||
filesSize <- newIORef 0
|
||||
fileDownloads <- newTVarIO 0
|
||||
fileDownloadAcks <- newTVarIO 0
|
||||
filesCount <- newTVarIO 0
|
||||
filesSize <- newTVarIO 0
|
||||
pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize}
|
||||
|
||||
getFileServerStatsData :: FileServerStats -> IO FileServerStatsData
|
||||
getFileServerStatsData s = do
|
||||
_fromTime <- readIORef $ fromTime (s :: FileServerStats)
|
||||
_filesCreated <- readIORef $ filesCreated s
|
||||
_fileRecipients <- readIORef $ fileRecipients s
|
||||
_filesUploaded <- readIORef $ filesUploaded s
|
||||
_filesExpired <- readIORef $ filesExpired s
|
||||
_filesDeleted <- readIORef $ filesDeleted s
|
||||
_fromTime <- readTVarIO $ fromTime (s :: FileServerStats)
|
||||
_filesCreated <- readTVarIO $ filesCreated s
|
||||
_fileRecipients <- readTVarIO $ fileRecipients s
|
||||
_filesUploaded <- readTVarIO $ filesUploaded s
|
||||
_filesExpired <- readTVarIO $ filesExpired s
|
||||
_filesDeleted <- readTVarIO $ filesDeleted s
|
||||
_filesDownloaded <- getPeriodStatsData $ filesDownloaded s
|
||||
_fileDownloads <- readIORef $ fileDownloads s
|
||||
_fileDownloadAcks <- readIORef $ fileDownloadAcks s
|
||||
_filesCount <- readIORef $ filesCount s
|
||||
_filesSize <- readIORef $ filesSize s
|
||||
_fileDownloads <- readTVarIO $ fileDownloads s
|
||||
_fileDownloadAcks <- readTVarIO $ fileDownloadAcks s
|
||||
_filesCount <- readTVarIO $ filesCount s
|
||||
_filesSize <- readTVarIO $ filesSize s
|
||||
pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize}
|
||||
|
||||
-- this function is not thread safe, it is used on server start only
|
||||
setFileServerStats :: FileServerStats -> FileServerStatsData -> IO ()
|
||||
setFileServerStats :: FileServerStats -> FileServerStatsData -> STM ()
|
||||
setFileServerStats s d = do
|
||||
writeIORef (fromTime (s :: FileServerStats)) $! _fromTime (d :: FileServerStatsData)
|
||||
writeIORef (filesCreated s) $! _filesCreated d
|
||||
writeIORef (fileRecipients s) $! _fileRecipients d
|
||||
writeIORef (filesUploaded s) $! _filesUploaded d
|
||||
writeIORef (filesExpired s) $! _filesExpired d
|
||||
writeIORef (filesDeleted s) $! _filesDeleted d
|
||||
writeTVar (fromTime (s :: FileServerStats)) $! _fromTime (d :: FileServerStatsData)
|
||||
writeTVar (filesCreated s) $! _filesCreated d
|
||||
writeTVar (fileRecipients s) $! _fileRecipients d
|
||||
writeTVar (filesUploaded s) $! _filesUploaded d
|
||||
writeTVar (filesExpired s) $! _filesExpired d
|
||||
writeTVar (filesDeleted s) $! _filesDeleted d
|
||||
setPeriodStats (filesDownloaded s) $! _filesDownloaded d
|
||||
writeIORef (fileDownloads s) $! _fileDownloads d
|
||||
writeIORef (fileDownloadAcks s) $! _fileDownloadAcks d
|
||||
writeIORef (filesCount s) $! _filesCount d
|
||||
writeIORef (filesSize s) $! _filesSize d
|
||||
writeTVar (fileDownloads s) $! _fileDownloads d
|
||||
writeTVar (fileDownloadAcks s) $! _fileDownloadAcks d
|
||||
writeTVar (filesCount s) $! _filesCount d
|
||||
writeTVar (filesSize s) $! _filesSize d
|
||||
|
||||
instance StrEncoding FileServerStatsData where
|
||||
strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} =
|
||||
|
||||
@@ -17,7 +17,6 @@ module Simplex.FileTransfer.Server.Store
|
||||
expiredFilePath,
|
||||
getFile,
|
||||
ackFile,
|
||||
fileTimePrecision,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -26,12 +25,12 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Int (Int64)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Time.Clock.System (SystemTime (..))
|
||||
import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId)
|
||||
import Simplex.FileTransfer.Transport (XFTPErrorType (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..))
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (ifM, ($>>=))
|
||||
@@ -47,14 +46,10 @@ data FileRec = FileRec
|
||||
fileInfo :: FileInfo,
|
||||
filePath :: TVar (Maybe FilePath),
|
||||
recipientIds :: TVar (Set RecipientId),
|
||||
createdAt :: RoundedSystemTime
|
||||
createdAt :: SystemTime
|
||||
}
|
||||
|
||||
fileTimePrecision :: Int64
|
||||
fileTimePrecision = 3600 -- truncate creation time to 1 hour
|
||||
|
||||
data FileRecipient = FileRecipient RecipientId RcvPublicAuthKey
|
||||
deriving (Show)
|
||||
|
||||
instance StrEncoding FileRecipient where
|
||||
strEncode (FileRecipient rId rKey) = strEncode rId <> ":" <> strEncode rKey
|
||||
@@ -67,14 +62,14 @@ newFileStore = do
|
||||
usedStorage <- newTVarIO 0
|
||||
pure FileStore {files, recipients, usedStorage}
|
||||
|
||||
addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> STM (Either XFTPErrorType ())
|
||||
addFile :: FileStore -> SenderId -> FileInfo -> SystemTime -> STM (Either XFTPErrorType ())
|
||||
addFile FileStore {files} sId fileInfo createdAt =
|
||||
ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
|
||||
f <- newFileRec sId fileInfo createdAt
|
||||
TM.insert sId f files
|
||||
pure $ Right ()
|
||||
|
||||
newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec
|
||||
newFileRec :: SenderId -> FileInfo -> SystemTime -> STM FileRec
|
||||
newFileRec senderId fileInfo createdAt = do
|
||||
recipientIds <- newTVar S.empty
|
||||
filePath <- newTVar Nothing
|
||||
@@ -125,8 +120,8 @@ getFile st party fId = case party of
|
||||
expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe (Maybe FilePath))
|
||||
expiredFilePath FileStore {files} sId old =
|
||||
TM.lookup sId files
|
||||
$>>= \FileRec {filePath, createdAt = RoundedSystemTime createdAt} ->
|
||||
if createdAt + fileTimePrecision < old
|
||||
$>>= \FileRec {filePath, createdAt} ->
|
||||
if systemSeconds createdAt < old
|
||||
then Just <$> readTVar filePath
|
||||
else pure Nothing
|
||||
|
||||
|
||||
@@ -28,22 +28,22 @@ 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 Data.Time.Clock.System (SystemTime)
|
||||
import Simplex.FileTransfer.Protocol (FileInfo (..))
|
||||
import Simplex.FileTransfer.Server.Store
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
|
||||
import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
import Simplex.Messaging.Util (bshow, whenM)
|
||||
import System.Directory (doesFileExist, renameFile)
|
||||
import System.IO
|
||||
|
||||
data FileStoreLogRecord
|
||||
= AddFile SenderId FileInfo RoundedSystemTime
|
||||
= AddFile SenderId FileInfo SystemTime
|
||||
| PutFile SenderId FilePath
|
||||
| AddRecipients SenderId (NonEmpty FileRecipient)
|
||||
| DeleteFile SenderId
|
||||
| AckFile RecipientId
|
||||
deriving (Show)
|
||||
|
||||
instance StrEncoding FileStoreLogRecord where
|
||||
strEncode = \case
|
||||
@@ -64,7 +64,7 @@ instance StrEncoding FileStoreLogRecord where
|
||||
logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
|
||||
logFileStoreRecord = writeStoreLogRecord
|
||||
|
||||
logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> IO ()
|
||||
logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> SystemTime -> IO ()
|
||||
logAddFile s = logFileStoreRecord s .:. AddFile
|
||||
|
||||
logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
|
||||
@@ -80,7 +80,13 @@ logAckFile :: StoreLog 'WriteMode -> RecipientId -> IO ()
|
||||
logAckFile s = logFileStoreRecord s . AckFile
|
||||
|
||||
readWriteFileStore :: FilePath -> FileStore -> IO (StoreLog 'WriteMode)
|
||||
readWriteFileStore = readWriteStoreLog readFileStore writeFileStore
|
||||
readWriteFileStore f st = do
|
||||
whenM (doesFileExist f) $ do
|
||||
readFileStore f st
|
||||
renameFile f $ f <> ".bak"
|
||||
s <- openWriteStoreLog f
|
||||
writeFileStore s st
|
||||
pure s
|
||||
|
||||
readFileStore :: FilePath -> FileStore -> IO ()
|
||||
readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f
|
||||
|
||||
@@ -12,7 +12,6 @@ module Simplex.FileTransfer.Transport
|
||||
( supportedFileServerVRange,
|
||||
authCmdsXFTPVersion,
|
||||
xftpClientHandshakeStub,
|
||||
supportedXFTPhandshakes,
|
||||
XFTPClientHandshake (..),
|
||||
-- xftpClientHandshake,
|
||||
XFTPServerHandshake (..),
|
||||
@@ -58,7 +57,7 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol (CommandError)
|
||||
import Simplex.Messaging.Transport (ALPN, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport (SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.File
|
||||
import Simplex.Messaging.Util (bshow, tshow)
|
||||
import Simplex.Messaging.Version
|
||||
@@ -102,9 +101,6 @@ supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
|
||||
xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
|
||||
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwE TEVersion
|
||||
|
||||
supportedXFTPhandshakes :: [ALPN]
|
||||
supportedXFTPhandshakes = ["xftp/1"]
|
||||
|
||||
data XFTPServerHandshake = XFTPServerHandshake
|
||||
{ xftpVersionRange :: VersionRangeXFTP,
|
||||
sessionId :: SessionId,
|
||||
|
||||
@@ -25,9 +25,9 @@ import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol (XFTPServer)
|
||||
import System.FilePath ((</>))
|
||||
|
||||
type RcvFileId = ByteString -- Agent entity ID
|
||||
type RcvFileId = ByteString
|
||||
|
||||
type SndFileId = ByteString -- Agent entity ID
|
||||
type SndFileId = ByteString
|
||||
|
||||
authTagSize :: Int64
|
||||
authTagSize = fromIntegral C.authTagSize
|
||||
|
||||
+230
-293
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
@@ -54,17 +53,15 @@ module Simplex.Messaging.Agent
|
||||
deleteConnectionAsync,
|
||||
deleteConnectionsAsync,
|
||||
createConnection,
|
||||
changeConnectionUser,
|
||||
prepareConnectionToJoin,
|
||||
prepareConnectionToAccept,
|
||||
joinConnection,
|
||||
allowConnection,
|
||||
acceptContact,
|
||||
rejectContact,
|
||||
subscribeConnection,
|
||||
subscribeConnections,
|
||||
getConnectionMessages,
|
||||
getNotificationConns,
|
||||
getConnectionMessage,
|
||||
getNotificationMessage,
|
||||
resubscribeConnection,
|
||||
resubscribeConnections,
|
||||
sendMessage,
|
||||
@@ -120,8 +117,6 @@ module Simplex.Messaging.Agent
|
||||
debugAgentLocks,
|
||||
getAgentSubscriptions,
|
||||
logConnection,
|
||||
-- for tests
|
||||
withAgentEnv,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -132,11 +127,11 @@ import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Bifunctor (bimap, first, second)
|
||||
import Data.Bifunctor (bimap, first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Composition ((.:), (.:.), (.::), (.::.))
|
||||
import Data.Either (isRight, partitionEithers, rights)
|
||||
import Data.Either (isRight, rights)
|
||||
import Data.Foldable (foldl', toList)
|
||||
import Data.Functor (($>))
|
||||
import Data.Functor.Identity
|
||||
@@ -170,21 +165,22 @@ import Simplex.Messaging.Agent.Store
|
||||
import Simplex.Messaging.Agent.Store.SQLite
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
|
||||
import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse)
|
||||
import Simplex.Messaging.Client (ProtocolClient (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP)
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId)
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Parsers (parse)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (SMPVersion)
|
||||
import Simplex.Messaging.Transport (SMPVersion, THandleParams (sessionId))
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.RemoteControl.Client
|
||||
@@ -334,14 +330,9 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync'
|
||||
|
||||
-- | Create SMP agent connection (NEW command)
|
||||
createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
|
||||
createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId enableNtfs
|
||||
createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId "" enableNtfs
|
||||
{-# INLINE createConnection #-}
|
||||
|
||||
-- | Changes the user id associated with a connection
|
||||
changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE ()
|
||||
changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConnectionUser' c oldUserId connId newUserId
|
||||
{-# INLINE changeConnectionUser #-}
|
||||
|
||||
-- | Create SMP agent connection without queue (to be joined with joinConnection passing connection ID).
|
||||
-- This method is required to prevent race condition when confirmation from peer is received before
|
||||
-- the caller of joinConnection saves connection ID to the database.
|
||||
@@ -350,13 +341,10 @@ changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConne
|
||||
prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId
|
||||
prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs
|
||||
|
||||
-- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID).
|
||||
prepareConnectionToAccept :: AgentClient -> Bool -> ConfirmationId -> PQSupport -> AE ConnId
|
||||
prepareConnectionToAccept c enableNtfs = withAgentEnv c .: newConnToAccept c "" enableNtfs
|
||||
|
||||
-- | Join SMP agent connection (JOIN command).
|
||||
joinConnection :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
|
||||
joinConnection c userId connId enableNtfs = withAgentEnv c .:: joinConn c userId connId enableNtfs
|
||||
joinConnection :: AgentClient -> UserId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
|
||||
joinConnection c userId Nothing enableNtfs = withAgentEnv c .:: joinConn c userId "" False enableNtfs
|
||||
joinConnection c userId (Just connId) enableNtfs = withAgentEnv c .:: joinConn c userId connId True enableNtfs
|
||||
{-# INLINE joinConnection #-}
|
||||
|
||||
-- | Allow connection to continue after CONF notification (LET command)
|
||||
@@ -365,8 +353,8 @@ allowConnection c = withAgentEnv c .:. allowConnection' c
|
||||
{-# INLINE allowConnection #-}
|
||||
|
||||
-- | Accept contact after REQ notification (ACPT command)
|
||||
acceptContact :: AgentClient -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
|
||||
acceptContact c connId enableNtfs = withAgentEnv c .:: acceptContact' c connId enableNtfs
|
||||
acceptContact :: AgentClient -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
|
||||
acceptContact c enableNtfs = withAgentEnv c .:: acceptContact' c "" enableNtfs
|
||||
{-# INLINE acceptContact #-}
|
||||
|
||||
-- | Reject contact (RJCT command)
|
||||
@@ -384,15 +372,15 @@ subscribeConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentE
|
||||
subscribeConnections c = withAgentEnv c . subscribeConnections' c
|
||||
{-# INLINE subscribeConnections #-}
|
||||
|
||||
-- | Get messages for connections (GET commands)
|
||||
getConnectionMessages :: AgentClient -> NonEmpty ConnId -> IO (NonEmpty (Maybe SMPMsgMeta))
|
||||
getConnectionMessages c = withAgentEnv' c . getConnectionMessages' c
|
||||
{-# INLINE getConnectionMessages #-}
|
||||
-- | Get connection message (GET command)
|
||||
getConnectionMessage :: AgentClient -> ConnId -> AE (Maybe SMPMsgMeta)
|
||||
getConnectionMessage c = withAgentEnv c . getConnectionMessage' c
|
||||
{-# INLINE getConnectionMessage #-}
|
||||
|
||||
-- | Get connections for received notification
|
||||
getNotificationConns :: AgentClient -> C.CbNonce -> ByteString -> AE (NonEmpty NotificationInfo)
|
||||
getNotificationConns c = withAgentEnv c .: getNotificationConns' c
|
||||
{-# INLINE getNotificationConns #-}
|
||||
-- | Get connection message for received notification
|
||||
getNotificationMessage :: AgentClient -> C.CbNonce -> ByteString -> AE (NotificationInfo, Maybe SMPMsgMeta)
|
||||
getNotificationMessage c = withAgentEnv c .: getNotificationMessage' c
|
||||
{-# INLINE getNotificationMessage #-}
|
||||
|
||||
resubscribeConnection :: AgentClient -> ConnId -> AE ()
|
||||
resubscribeConnection c = withAgentEnv c . resubscribeConnection' c
|
||||
@@ -479,14 +467,14 @@ testProtocolServer c userId srv = withAgentEnv' c $ case protocolTypeI @p of
|
||||
|
||||
-- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
|
||||
setNetworkConfig :: AgentClient -> NetworkConfig -> IO ()
|
||||
setNetworkConfig c@AgentClient {useNetworkConfig, proxySessTs} cfg' = do
|
||||
(spChanged, changed) <- atomically $ do
|
||||
setNetworkConfig c@AgentClient {useNetworkConfig} cfg' = do
|
||||
changed <- atomically $ do
|
||||
(_, cfg) <- readTVar useNetworkConfig
|
||||
let changed = cfg /= cfg'
|
||||
!cfgSlow = slowNetworkConfig cfg'
|
||||
when changed $ writeTVar useNetworkConfig (cfgSlow, cfg')
|
||||
pure (socksProxy cfg /= socksProxy cfg', changed)
|
||||
when spChanged $ getCurrentTime >>= atomically . writeTVar proxySessTs
|
||||
if cfg == cfg'
|
||||
then pure False
|
||||
else
|
||||
let cfgSlow = slowNetworkConfig cfg'
|
||||
in True <$ (cfgSlow `seq` writeTVar useNetworkConfig (cfgSlow, cfg'))
|
||||
when changed $ reconnectAllServers c
|
||||
|
||||
setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO ()
|
||||
@@ -654,15 +642,15 @@ deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueue
|
||||
|
||||
newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId
|
||||
newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do
|
||||
connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
|
||||
connId <- newConnNoQueues c userId "" enableNtfs cMode (CR.connPQEncryption pqInitKeys)
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) pqInitKeys subMode
|
||||
pure connId
|
||||
|
||||
newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
|
||||
newConnNoQueues c userId enableNtfs cMode pqSupport = do
|
||||
newConnNoQueues :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
|
||||
newConnNoQueues c userId connId enableNtfs cMode pqSupport = do
|
||||
g <- asks random
|
||||
connAgentVersion <- asks $ maxVersion . smpAgentVRange . config
|
||||
let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
|
||||
let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
|
||||
withStore c $ \db -> createNewConn db g cData cMode
|
||||
|
||||
joinConnAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
|
||||
@@ -749,24 +737,19 @@ switchConnectionAsync' c corrId connId =
|
||||
pure . connectionStats $ DuplexConnection cData rqs' sqs
|
||||
_ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
|
||||
|
||||
newConn :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c)
|
||||
newConn c userId enableNtfs cMode clientData pqInitKeys subMode = do
|
||||
srv <- getSMPServer c userId
|
||||
connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
|
||||
cReq <- newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
|
||||
pure (connId, cReq)
|
||||
newConn :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c)
|
||||
newConn c userId connId enableNtfs cMode clientData pqInitKeys subMode =
|
||||
getSMPServer c userId >>= newConnSrv c userId connId False enableNtfs cMode clientData pqInitKeys subMode
|
||||
|
||||
changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM ()
|
||||
changeConnectionUser' c oldUserId connId newUserId = do
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
case conn of
|
||||
NewConnection {} -> updateConn
|
||||
RcvConnection {} -> updateConn
|
||||
_ -> throwE $ CMD PROHIBITED "changeConnectionUser: established connection"
|
||||
where
|
||||
updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
|
||||
newConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c)
|
||||
newConnSrv c userId connId hasNewConn enableNtfs cMode clientData pqInitKeys subMode srv = do
|
||||
connId' <-
|
||||
if hasNewConn
|
||||
then pure connId
|
||||
else newConnNoQueues c userId connId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
|
||||
newRcvConnSrv c userId connId' enableNtfs cMode clientData pqInitKeys subMode srv
|
||||
|
||||
newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c)
|
||||
newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c)
|
||||
newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
|
||||
case (cMode, pqInitKeys) of
|
||||
(SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv"
|
||||
@@ -779,15 +762,15 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
|
||||
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
|
||||
when enableNtfs $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
|
||||
let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
|
||||
case cMode of
|
||||
SCMContact -> pure $ CRContactUri crData
|
||||
SCMContact -> pure (connId, CRContactUri crData)
|
||||
SCMInvitation -> do
|
||||
g <- asks random
|
||||
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
|
||||
withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
|
||||
pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
|
||||
pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange)
|
||||
|
||||
newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId
|
||||
newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
|
||||
@@ -807,26 +790,16 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
|
||||
cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
|
||||
withStore c $ \db -> createNewConn db g cData SCMInvitation
|
||||
|
||||
newConnToAccept :: AgentClient -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId
|
||||
newConnToAccept c connId enableNtfs invId pqSup = do
|
||||
Invitation {connReq, contactConnId} <- withStore c (`getInvitation` invId)
|
||||
withStore c (`getConn` contactConnId) >>= \case
|
||||
SomeConn _ (ContactConnection ConnData {userId} _) ->
|
||||
newConnToJoin c userId connId enableNtfs connReq pqSup
|
||||
_ -> throwE $ CMD PROHIBITED "newConnToAccept"
|
||||
joinConn :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (ConnId, SndQueueSecured)
|
||||
joinConn c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode = do
|
||||
srv <- case cReq of
|
||||
CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ ->
|
||||
getNextServer c userId [qServer q]
|
||||
_ -> getSMPServer c userId
|
||||
joinConnSrv c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode srv
|
||||
|
||||
joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
|
||||
joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
|
||||
srv <- getNextSMPServer c userId [qServer cReqQueue]
|
||||
joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv
|
||||
where
|
||||
cReqQueue :: SMPQueueUri
|
||||
cReqQueue = case cReq of
|
||||
CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> q
|
||||
CRContactUri ConnReqUriData {crSmpQueues = q :| _} -> q
|
||||
|
||||
startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448)
|
||||
startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup =
|
||||
startJoinInvitation :: UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, NewSndQueue, C.PublicKeyX25519, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448)
|
||||
startJoinInvitation userId connId sq_ enableNtfs cReqUri pqSup =
|
||||
lift (compatibleInvitationUri cReqUri) >>= \case
|
||||
Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_), Compatible connAgentVersion) -> do
|
||||
g <- asks random
|
||||
@@ -839,14 +812,11 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup =
|
||||
rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams
|
||||
-- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out
|
||||
-- e2ePubKey is always present, it's Maybe historically
|
||||
q <- case sq_ of
|
||||
Just sq@SndQueue {e2ePubKey = Just _k} -> pure (sq :: SndQueue) {dbQueueId = DBNewQueue}
|
||||
_ -> lift $ fst <$> newSndQueue userId "" qInfo
|
||||
(q, e2ePubKey) <- case sq_ of
|
||||
Just sq@SndQueue {e2ePubKey = Just k} -> pure ((sq :: SndQueue) {dbQueueId = DBNewQueue}, k)
|
||||
_ -> lift $ newSndQueue userId "" qInfo
|
||||
let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
|
||||
sq' <- withStore c $ \db -> runExceptT $ do
|
||||
liftIO $ createRatchet db connId rc
|
||||
maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_
|
||||
pure (cData, sq', e2eSndParams)
|
||||
pure (cData, q, e2ePubKey, rc, e2eSndParams)
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
|
||||
connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport))
|
||||
@@ -879,25 +849,34 @@ versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport
|
||||
versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_
|
||||
{-# INLINE versionPQSupport_ #-}
|
||||
|
||||
joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
|
||||
joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
|
||||
joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, SndQueueSecured)
|
||||
joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
|
||||
withInvLock c (strEncode inv) "joinConnSrv" $ do
|
||||
SomeConn cType conn <- withStore c (`getConn` connId)
|
||||
case conn of
|
||||
NewConnection _ -> doJoin Nothing
|
||||
SndConnection _ sq -> doJoin $ Just sq
|
||||
_ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType
|
||||
where
|
||||
doJoin :: Maybe SndQueue -> AM SndQueueSecured
|
||||
doJoin sq_ = do
|
||||
(cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup
|
||||
secureConfirmQueue c cData sq srv cInfo (Just e2eSndParams) subMode
|
||||
joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
|
||||
(cData, q, _, rc, e2eSndParams) <- startJoinInvitation userId connId Nothing enableNtfs inv pqSup
|
||||
g <- asks random
|
||||
(connId', sq) <- withStore c $ \db -> runExceptT $ do
|
||||
r@(connId', _) <-
|
||||
if hasNewConn
|
||||
then (connId,) <$> ExceptT (updateNewConnSnd db connId q)
|
||||
else ExceptT $ createSndConn db g cData q
|
||||
liftIO $ createRatchet db connId' rc
|
||||
pure r
|
||||
let cData' = (cData :: ConnData) {connId = connId'}
|
||||
-- joinConnSrv is only used on user interaction, and its failure is permanent,
|
||||
-- otherwise we would need to manage retries here to avoid SndQueue recreated with a different key,
|
||||
-- similar to how joinConnAsync does that.
|
||||
tryError (secureConfirmQueue c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case
|
||||
Right sqSecured -> pure (connId', sqSecured)
|
||||
Left e -> do
|
||||
-- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md
|
||||
void $ withStore' c $ \db -> deleteConn db Nothing connId'
|
||||
throwE e
|
||||
joinConnSrv c userId connId hasNewConn enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
|
||||
lift (compatibleContactUri cReqUri) >>= \case
|
||||
Just (qInfo, vrsn) -> do
|
||||
cReq <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv
|
||||
void $ sendInvitation c userId connId qInfo vrsn cReq cInfo
|
||||
pure False
|
||||
(connId', cReq) <- newConnSrv c userId connId hasNewConn enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv
|
||||
void $ sendInvitation c userId qInfo vrsn cReq cInfo
|
||||
pure (connId', False)
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
|
||||
joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
|
||||
@@ -910,8 +889,11 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo
|
||||
where
|
||||
doJoin :: Maybe SndQueue -> AM SndQueueSecured
|
||||
doJoin sq_ = do
|
||||
(cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport
|
||||
secureConfirmQueueAsync c cData sq srv cInfo (Just e2eSndParams) subMode
|
||||
(cData, sq, _, rc, e2eSndParams) <- startJoinInvitation userId connId sq_ enableNtfs inv pqSupport
|
||||
sq' <- withStore c $ \db -> runExceptT $ do
|
||||
liftIO $ createRatchet db connId rc
|
||||
maybe (ExceptT $ updateNewConnSnd db connId sq) pure sq_
|
||||
secureConfirmQueueAsync c cData sq' srv cInfo (Just e2eSndParams) subMode
|
||||
joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do
|
||||
throwE $ CMD PROHIBITED "joinConnSrvAsync"
|
||||
|
||||
@@ -925,7 +907,7 @@ createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVers
|
||||
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
|
||||
when enableNtfs $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
|
||||
pure qInfo
|
||||
|
||||
-- | Approve confirmation (LET command) in Reader monad
|
||||
@@ -939,13 +921,13 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne
|
||||
_ -> throwE $ CMD PROHIBITED "allowConnection"
|
||||
|
||||
-- | Accept contact (ACPT command) in Reader monad
|
||||
acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
|
||||
acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (ConnId, SndQueueSecured)
|
||||
acceptContact' c connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do
|
||||
Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId)
|
||||
withStore c (`getConn` contactConnId) >>= \case
|
||||
SomeConn _ (ContactConnection ConnData {userId} _) -> do
|
||||
withStore' c $ \db -> acceptInvitation db invId ownConnInfo
|
||||
joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do
|
||||
joinConn c userId connId False enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do
|
||||
withStore' c (`unacceptInvitation` invId)
|
||||
throwE err
|
||||
_ -> throwE $ CMD PROHIBITED "acceptContact"
|
||||
@@ -976,12 +958,12 @@ subscribeConnections' c connIds = do
|
||||
let (errs, cs) = M.mapEither id conns
|
||||
errs' = M.map (Left . storeError) errs
|
||||
(subRs, rcvQs) = M.mapEither rcvQueueOrResult cs
|
||||
resumeDelivery cs
|
||||
lift $ resumeConnCmds c $ M.keys cs
|
||||
mapM_ (mapM_ (\(cData, sqs) -> mapM_ (lift . resumeMsgDelivery c cData) sqs) . sndQueue) cs
|
||||
mapM_ (resumeConnCmds c) $ M.keys cs
|
||||
rcvRs <- lift $ connResults . fst <$> subscribeQueues c (concat $ M.elems rcvQs)
|
||||
ns <- asks ntfSupervisor
|
||||
tkn <- readTVarIO (ntfTkn ns)
|
||||
lift $ when (instantNotifications tkn) . void . forkIO . void $ sendNtfCreate ns rcvRs cs
|
||||
when (instantNotifications tkn) . void . lift . forkIO . void . runExceptT $ sendNtfCreate ns rcvRs conns
|
||||
let rs = M.unions ([errs', subRs, rcvRs] :: [Map ConnId (Either AgentErrorType ())])
|
||||
notifyResultError rs
|
||||
pure rs
|
||||
@@ -1013,19 +995,15 @@ subscribeConnections' c connIds = do
|
||||
order (Active, _) = 2
|
||||
order (_, Right _) = 3
|
||||
order _ = 4
|
||||
sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType ()) -> Map ConnId SomeConn -> AM' ()
|
||||
sendNtfCreate ns rcvRs cs = do
|
||||
let oks = M.keysSet $ M.filter (either temporaryAgentError $ const True) rcvRs
|
||||
cs' = M.restrictKeys cs oks
|
||||
(csCreate, csDelete) = M.partition (\(SomeConn _ conn) -> enableNtfs $ toConnData conn) cs'
|
||||
sendNtfCmd NSCCreate csCreate
|
||||
sendNtfCmd NSCSmpDelete csDelete
|
||||
where
|
||||
sendNtfCmd cmd cs' = forM_ (L.nonEmpty $ M.keys cs') $ \cids -> atomically $ writeTBQueue (ntfSubQ ns) (cmd, cids)
|
||||
resumeDelivery :: Map ConnId SomeConn -> AM ()
|
||||
resumeDelivery conns = do
|
||||
conns' <- M.restrictKeys conns . S.fromList <$> withStore' c getConnectionsForDelivery
|
||||
lift $ mapM_ (mapM_ (\(cData, sqs) -> mapM_ (resumeMsgDelivery c cData) sqs) . sndQueue) conns'
|
||||
sendNtfCreate :: NtfSupervisor -> Map ConnId (Either AgentErrorType ()) -> Map ConnId (Either StoreError SomeConn) -> AM ()
|
||||
sendNtfCreate ns rcvRs conns =
|
||||
forM_ (M.assocs rcvRs) $ \case
|
||||
(connId, Right _) -> forM_ (M.lookup connId conns) $ \case
|
||||
Right (SomeConn _ conn) -> do
|
||||
let cmd = if enableNtfs $ toConnData conn then NSCCreate else NSCDelete
|
||||
atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
sndQueue :: SomeConn -> Maybe (ConnData, NonEmpty SndQueue)
|
||||
sndQueue (SomeConn _ conn) = case conn of
|
||||
DuplexConnection cData _ sqs -> Just (cData, sqs)
|
||||
@@ -1050,57 +1028,28 @@ resubscribeConnections' c connIds = do
|
||||
-- union is left-biased, so results returned by subscribeConnections' take precedence
|
||||
(`M.union` r) <$> subscribeConnections' c connIds'
|
||||
|
||||
getConnectionMessages' :: AgentClient -> NonEmpty ConnId -> AM' (NonEmpty (Maybe SMPMsgMeta))
|
||||
getConnectionMessages' c = mapM getMsg
|
||||
where
|
||||
getMsg :: ConnId -> AM' (Maybe SMPMsgMeta)
|
||||
getMsg connId =
|
||||
getConnectionMessage connId `catchAgentError'` \e -> do
|
||||
logError $ "Error loading message: " <> tshow e
|
||||
pure Nothing
|
||||
getConnectionMessage :: ConnId -> AM (Maybe SMPMsgMeta)
|
||||
getConnectionMessage connId = do
|
||||
whenM (atomically $ hasActiveSubscription c connId) . throwE $ CMD PROHIBITED "getConnectionMessage: subscribed"
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
case conn of
|
||||
DuplexConnection _ (rq :| _) _ -> getQueueMessage c rq
|
||||
RcvConnection _ rq -> getQueueMessage c rq
|
||||
ContactConnection _ rq -> getQueueMessage c rq
|
||||
SndConnection _ _ -> throwE $ CONN SIMPLEX
|
||||
NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionMessage: NewConnection"
|
||||
getConnectionMessage' :: AgentClient -> ConnId -> AM (Maybe SMPMsgMeta)
|
||||
getConnectionMessage' c connId = do
|
||||
whenM (atomically $ hasActiveSubscription c connId) . throwE $ CMD PROHIBITED "getConnectionMessage: subscribed"
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
case conn of
|
||||
DuplexConnection _ (rq :| _) _ -> getQueueMessage c rq
|
||||
RcvConnection _ rq -> getQueueMessage c rq
|
||||
ContactConnection _ rq -> getQueueMessage c rq
|
||||
SndConnection _ _ -> throwE $ CONN SIMPLEX
|
||||
NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionMessage: NewConnection"
|
||||
|
||||
getNotificationConns' :: AgentClient -> C.CbNonce -> ByteString -> AM (NonEmpty NotificationInfo)
|
||||
getNotificationConns' c nonce encNtfInfo =
|
||||
getNotificationMessage' :: AgentClient -> C.CbNonce -> ByteString -> AM (NotificationInfo, Maybe SMPMsgMeta)
|
||||
getNotificationMessage' c nonce encNtfInfo = do
|
||||
withStore' c getActiveNtfToken >>= \case
|
||||
Just NtfToken {ntfDhSecret = Just dhSecret} -> do
|
||||
ntfData <- liftEither $ agentCbDecrypt dhSecret nonce encNtfInfo
|
||||
pnMsgs <- liftEither (parse pnMessagesP (INTERNAL "error parsing PNMessageData") ntfData)
|
||||
let (initNtfs, lastNtf) = (L.init pnMsgs, L.last pnMsgs)
|
||||
rs <-
|
||||
lift $ withStoreBatch c $ \db ->
|
||||
let initNtfInfos = map (getInitNtfInfo db) initNtfs
|
||||
lastNtfInfo = Just . fst <$$> getNtfInfo db lastNtf
|
||||
in initNtfInfos <> [lastNtfInfo]
|
||||
let (errs, ntfInfos_) = partitionEithers rs
|
||||
logError $ "Error(s) loading notifications: " <> tshow errs
|
||||
case L.nonEmpty $ catMaybes ntfInfos_ of
|
||||
Just r -> pure r
|
||||
Nothing -> throwE $ INTERNAL "getNotificationConns: couldn't get conn info"
|
||||
_ -> throwE $ CMD PROHIBITED "getNotificationConns"
|
||||
where
|
||||
getNtfInfo :: DB.Connection -> PNMessageData -> IO (Either AgentErrorType (NotificationInfo, Maybe UTCTime))
|
||||
getNtfInfo db PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = runExceptT $ do
|
||||
(ntfConnId, rcvNtfDhSecret, lastBrokerTs_) <- liftError' storeError $ getNtfRcvQueue db smpQueue
|
||||
let ntfMsgMeta = eitherToMaybe $ smpDecode =<< first show (C.cbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta)
|
||||
ntfInfo = NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta}
|
||||
pure (ntfInfo, lastBrokerTs_)
|
||||
getInitNtfInfo :: DB.Connection -> PNMessageData -> IO (Either AgentErrorType (Maybe NotificationInfo))
|
||||
getInitNtfInfo db msgData = runExceptT $ do
|
||||
(nftInfo, lastBrokerTs_) <- ExceptT $ getNtfInfo db msgData
|
||||
pure $ case (ntfMsgMeta nftInfo, lastBrokerTs_) of
|
||||
(Just SMP.NMsgMeta {msgTs}, Just lastBrokerTs)
|
||||
| systemToUTCTime msgTs > lastBrokerTs -> Just nftInfo
|
||||
_ -> Nothing
|
||||
ntfData <- agentCbDecrypt dhSecret nonce encNtfInfo
|
||||
PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} <- liftEither (parse strP (INTERNAL "error parsing PNMessageData") ntfData)
|
||||
(ntfConnId, rcvNtfDhSecret) <- withStore c (`getNtfRcvQueue` smpQueue)
|
||||
ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchAgentError` \_ -> pure Nothing
|
||||
msgMeta <- getConnectionMessage' c ntfConnId
|
||||
pure (NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta}, msgMeta)
|
||||
_ -> throwE $ CMD PROHIBITED "getNotificationMessage"
|
||||
|
||||
-- | Send message to the connection (SEND command) in Reader monad
|
||||
sendMessage' :: AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> AM (AgentMsgId, PQEncryption)
|
||||
@@ -1133,8 +1082,8 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do
|
||||
where
|
||||
getConn_ :: DB.Connection -> TVar (Maybe (Either AgentErrorType SomeConn)) -> MsgReq -> IO (Either AgentErrorType (MsgReq, SomeConn))
|
||||
getConn_ db prev req@(connId, _, _, _) =
|
||||
(req,)
|
||||
<$$> if B.null connId
|
||||
(req,) <$$>
|
||||
if B.null connId
|
||||
then fromMaybe (Left $ INTERNAL "sendMessagesB_: empty prev connId") <$> readTVarIO prev
|
||||
else do
|
||||
conn <- first storeError <$> getConn db connId
|
||||
@@ -1163,48 +1112,50 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do
|
||||
enqueueCommand :: AgentClient -> ACorrId -> ConnId -> Maybe SMPServer -> AgentCommand -> AM ()
|
||||
enqueueCommand c corrId connId server aCommand = do
|
||||
withStore c $ \db -> createCommand db corrId connId server aCommand
|
||||
lift . void $ getAsyncCmdWorker True c connId server
|
||||
lift . void $ getAsyncCmdWorker True c server
|
||||
|
||||
resumeSrvCmds :: AgentClient -> ConnId -> Maybe SMPServer -> AM' ()
|
||||
resumeSrvCmds = void .:. getAsyncCmdWorker False
|
||||
resumeSrvCmds :: AgentClient -> Maybe SMPServer -> AM' ()
|
||||
resumeSrvCmds = void .: getAsyncCmdWorker False
|
||||
{-# INLINE resumeSrvCmds #-}
|
||||
|
||||
resumeConnCmds :: AgentClient -> [ConnId] -> AM' ()
|
||||
resumeConnCmds c connIds = do
|
||||
connSrvs <- rights . zipWith (second . (,)) connIds <$> withStoreBatch' c (\db -> fmap (getPendingCommandServers db) connIds)
|
||||
mapM_ (\(connId, srvs) -> mapM_ (resumeSrvCmds c connId) srvs) connSrvs
|
||||
resumeConnCmds :: AgentClient -> ConnId -> AM ()
|
||||
resumeConnCmds c connId =
|
||||
unlessM connQueued $
|
||||
withStore' c (`getPendingCommandServers` connId)
|
||||
>>= mapM_ (lift . resumeSrvCmds c)
|
||||
where
|
||||
connQueued = atomically $ isJust <$> TM.lookupInsert connId True (connCmdsQueued c)
|
||||
|
||||
getAsyncCmdWorker :: Bool -> AgentClient -> ConnId -> Maybe SMPServer -> AM' Worker
|
||||
getAsyncCmdWorker hasWork c connId server =
|
||||
getAgentWorker "async_cmd" hasWork c (connId, server) (asyncCmdWorkers c) (runCommandProcessing c connId server)
|
||||
getAsyncCmdWorker :: Bool -> AgentClient -> Maybe SMPServer -> AM' Worker
|
||||
getAsyncCmdWorker hasWork c server =
|
||||
getAgentWorker "async_cmd" hasWork c server (asyncCmdWorkers c) (runCommandProcessing c server)
|
||||
|
||||
data CommandCompletion = CCMoved | CCCompleted
|
||||
|
||||
runCommandProcessing :: AgentClient -> ConnId -> Maybe SMPServer -> Worker -> AM ()
|
||||
runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
runCommandProcessing :: AgentClient -> Maybe SMPServer -> Worker -> AM ()
|
||||
runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
|
||||
ri <- asks $ messageRetryInterval . config -- different retry interval?
|
||||
forever $ do
|
||||
atomically $ endAgentOperation c AOSndNetwork
|
||||
lift $ waitForWork doWork
|
||||
liftIO $ throwWhenInactive c
|
||||
atomically $ beginAgentOperation c AOSndNetwork
|
||||
withWork c doWork (\db -> getPendingServerCommand db connId server_) $ runProcessCmd (riFast ri)
|
||||
withWork c doWork (`getPendingServerCommand` server_) $ runProcessCmd (riFast ri)
|
||||
where
|
||||
runProcessCmd ri cmd = do
|
||||
pending <- newTVarIO []
|
||||
processCmd ri cmd pending
|
||||
mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending
|
||||
processCmd :: RetryInterval -> PendingCommand -> TVar [ATransmission] -> AM ()
|
||||
processCmd ri PendingCommand {cmdId, corrId, userId, command} pendingCmds = case command of
|
||||
processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} pendingCmds = case command of
|
||||
AClientCommand cmd -> case cmd of
|
||||
NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
|
||||
triedHosts <- newTVarIO S.empty
|
||||
tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do
|
||||
cReq <- newRcvConnSrv c userId connId enableNtfs cMode Nothing pqEnc subMode srv
|
||||
usedSrvs <- newTVarIO ([] :: [SMPServer])
|
||||
tryCommand . withNextSrv c userId usedSrvs [] $ \srv -> do
|
||||
(_, cReq) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing pqEnc subMode srv
|
||||
notify $ INV (ACR cMode cReq)
|
||||
JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do
|
||||
triedHosts <- newTVarIO S.empty
|
||||
tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> do
|
||||
let initUsed = [qServer q]
|
||||
usedSrvs <- newTVarIO initUsed
|
||||
tryCommand . withNextSrv c userId usedSrvs initUsed $ \srv -> do
|
||||
sqSecured <- joinConnSrvAsync c userId connId enableNtfs cReq connInfo pqEnc subMode srv
|
||||
notify $ JOINED sqSecured
|
||||
LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
|
||||
@@ -1220,27 +1171,16 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
AInternalCommand cmd -> case cmd of
|
||||
ICAckDel rId srvMsgId msgId -> withServer $ \srv -> tryWithLock "ICAckDel" $ ack srv rId srvMsgId >> withStore' c (\db -> deleteMsg db connId msgId)
|
||||
ICAck rId srvMsgId -> withServer $ \srv -> tryWithLock "ICAck" $ ack srv rId srvMsgId
|
||||
ICAllowSecure _rId senderKey -> withServer' . tryMoveableWithLock "ICAllowSecure" $ do
|
||||
ICAllowSecure _rId senderKey -> withServer' . tryWithLock "ICAllowSecure" $ do
|
||||
(SomeConn _ conn, AcceptedConfirmation {senderConf, ownConnInfo}) <-
|
||||
withStore c $ \db -> runExceptT $ (,) <$> ExceptT (getConn db connId) <*> ExceptT (getAcceptedConfirmation db connId)
|
||||
case conn of
|
||||
RcvConnection cData rq -> do
|
||||
mapM_ (secure rq) senderKey
|
||||
mapM_ (connectReplyQueues c cData ownConnInfo Nothing) (L.nonEmpty $ smpReplyQueues senderConf)
|
||||
pure CCCompleted
|
||||
-- duplex connection is matched to handle SKEY retries
|
||||
DuplexConnection cData _ (sq :| _) -> do
|
||||
tryAgentError (mapM_ (connectReplyQueues c cData ownConnInfo (Just sq)) (L.nonEmpty $ smpReplyQueues senderConf)) >>= \case
|
||||
Right () -> pure CCCompleted
|
||||
Left e
|
||||
| temporaryOrHostError e && Just server /= server_ -> do
|
||||
-- In case the server is different we update server to remove command from this (connId, srv) queue
|
||||
withStore c $ \db -> updateCommandServer db cmdId server
|
||||
lift . void $ getAsyncCmdWorker True c connId (Just server)
|
||||
pure CCMoved
|
||||
| otherwise -> throwE e
|
||||
where
|
||||
server = qServer sq
|
||||
DuplexConnection cData _ (sq :| _) ->
|
||||
mapM_ (connectReplyQueues c cData ownConnInfo (Just sq)) (L.nonEmpty $ smpReplyQueues senderConf)
|
||||
_ -> throwE $ INTERNAL $ "incorrect connection type " <> show (internalCmdTag cmd)
|
||||
ICDuplexSecure _rId senderKey -> withServer' . tryWithLock "ICDuplexSecure" . withDuplexConn $ \(DuplexConnection cData (rq :| _) (sq :| _)) -> do
|
||||
secure rq senderKey
|
||||
@@ -1287,7 +1227,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
withStore' c $ \db -> deleteConnRcvQueue db rq'
|
||||
when (enableNtfs cData) $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
|
||||
let conn' = DuplexConnection cData (rq'' :| rqs') sqs
|
||||
notify $ SWITCH QDRcv SPCompleted $ connectionStats conn'
|
||||
_ -> internalErr "ICQDelete: cannot delete the only queue in connection"
|
||||
@@ -1313,18 +1253,15 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
withStore c (`getConn` connId) >>= \case
|
||||
SomeConn _ conn@DuplexConnection {} -> a conn
|
||||
_ -> internalErr "command requires duplex connection"
|
||||
tryCommand action = tryMoveableCommand (action $> CCCompleted)
|
||||
tryMoveableCommand action = withRetryInterval ri $ \_ loop -> do
|
||||
tryCommand action = withRetryInterval ri $ \_ loop -> do
|
||||
liftIO $ waitWhileSuspended c
|
||||
liftIO $ waitForUserNetwork c
|
||||
tryAgentError action >>= \case
|
||||
tryError action >>= \case
|
||||
Left e
|
||||
| temporaryOrHostError e -> retrySndOp c loop
|
||||
| otherwise -> cmdError e
|
||||
Right CCCompleted -> withStore' c (`deleteCommand` cmdId)
|
||||
Right CCMoved -> pure () -- command processing moved to another command queue
|
||||
Right () -> withStore' c (`deleteCommand` cmdId)
|
||||
tryWithLock name = tryCommand . withConnLock c connId name
|
||||
tryMoveableWithLock name = tryMoveableCommand . withConnLock c connId name
|
||||
internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command)
|
||||
cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId)
|
||||
notify :: forall e. AEntityI e => AEvent e -> AM ()
|
||||
@@ -1372,7 +1309,7 @@ enqueueMessageB c reqs = do
|
||||
storeSentMsg db cfg req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do
|
||||
let AgentConfig {smpAgentVRange, e2eEncryptVRange} = cfg
|
||||
internalTs <- liftIO getCurrentTime
|
||||
(internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
|
||||
(internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
|
||||
let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
|
||||
agentMsg = AgentMessage privHeader aMessage
|
||||
agentMsgStr = smpEncode agentMsg
|
||||
@@ -1652,8 +1589,8 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s
|
||||
checkRQSwchStatus rq RSSwitchStarted
|
||||
clientVRange <- asks $ smpClientVRange . config
|
||||
-- try to get the server that is different from all queues, or at least from the primary rcv queue
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextServer c userId [server] else pure srvAuth
|
||||
(q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe False
|
||||
let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq'
|
||||
@@ -1709,21 +1646,14 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni
|
||||
_ -> throwE $ CMD PROHIBITED "synchronizeRatchet: not duplex"
|
||||
|
||||
ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM ()
|
||||
ackQueueMessage c rq@RcvQueue {userId, connId, server} srvMsgId = do
|
||||
ackQueueMessage c rq@RcvQueue {userId, server} srvMsgId = do
|
||||
atomically $ incSMPServerStat c userId server ackAttempts
|
||||
tryAgentError (sendAck c rq srvMsgId) >>= \case
|
||||
Right _ -> sendMsgNtf ackMsgs
|
||||
Left (SMP _ SMP.NO_MSG) -> sendMsgNtf ackNoMsgErrs
|
||||
Right _ -> atomically $ incSMPServerStat c userId server ackMsgs
|
||||
Left (SMP _ SMP.NO_MSG) -> atomically $ incSMPServerStat c userId server ackNoMsgErrs
|
||||
Left e -> do
|
||||
unless (temporaryOrHostError e) $ atomically $ incSMPServerStat c userId server ackOtherErrs
|
||||
throwE e
|
||||
where
|
||||
sendMsgNtf stat = do
|
||||
atomically $ incSMPServerStat c userId server stat
|
||||
whenM (liftIO $ hasGetLock c rq) $ do
|
||||
atomically $ releaseGetLock c rq
|
||||
brokerTs_ <- eitherToMaybe <$> tryAgentError (withStore c $ \db -> getRcvMsgBrokerTs db connId srvMsgId)
|
||||
atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ MSGNTF srvMsgId brokerTs_)
|
||||
|
||||
-- | Suspend SMP agent connection (OFF command) in Reader monad
|
||||
suspendConnection' :: AgentClient -> ConnId -> AM ()
|
||||
@@ -1751,6 +1681,12 @@ connRcvQueues = \case
|
||||
SndConnection _ _ -> []
|
||||
NewConnection _ -> []
|
||||
|
||||
disableConn :: AgentClient -> ConnId -> AM' ()
|
||||
disableConn c connId = do
|
||||
atomically $ removeSubscription c connId
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCDelete)
|
||||
|
||||
-- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure.
|
||||
deleteConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections' = deleteConnections_ getConns False False
|
||||
@@ -1777,7 +1713,7 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do
|
||||
(delRs, rcvQs) = M.mapEither rcvQueues cs
|
||||
rqs = concat $ M.elems rcvQs
|
||||
connIds' = M.keys rcvQs
|
||||
lift $ forM_ (L.nonEmpty connIds') unsubConnIds
|
||||
lift . forM_ connIds' $ disableConn c
|
||||
-- ! delRs is not used to notify about the result in any of the calling functions,
|
||||
-- ! it is only used to check results count in deleteConnections_;
|
||||
-- ! if it was used to notify about the result, it might be necessary to differentiate
|
||||
@@ -1791,12 +1727,6 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do
|
||||
rcvQueues (SomeConn _ conn) = case connRcvQueues conn of
|
||||
[] -> Left $ Right ()
|
||||
rqs -> Right rqs
|
||||
unsubConnIds :: NonEmpty ConnId -> AM' ()
|
||||
unsubConnIds connIds' = do
|
||||
forM_ connIds' $ \connId ->
|
||||
atomically $ removeSubscription c connId
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ writeTBQueue (ntfSubQ ns) (NSCDeleteSub, connIds')
|
||||
notify = atomically . writeTBQueue (subQ c)
|
||||
|
||||
deleteConnQueues :: AgentClient -> Bool -> Bool -> [RcvQueue] -> AM' (Map ConnId (Either AgentErrorType ()))
|
||||
@@ -1937,12 +1867,16 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
|
||||
cron <- asks $ ntfCron . config
|
||||
agentNtfEnableCron c tknId tkn cron
|
||||
when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
|
||||
when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete
|
||||
when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCDelete
|
||||
-- possible improvement: get updated token status from the server, or maybe TCRON could return the current status
|
||||
pure ntfTknStatus
|
||||
| otherwise -> replaceToken tknId
|
||||
-- deprecated
|
||||
(Just _tknId, Just NTADelete) -> deleteToken c tkn $> NTExpired
|
||||
(Just tknId, Just NTADelete) -> do
|
||||
agentNtfDeleteToken c tknId tkn
|
||||
withStore' c (`removeNtfToken` tkn)
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ nsRemoveNtfToken ns
|
||||
pure NTExpired
|
||||
_ -> pure ntfTknStatus
|
||||
withStore' c $ \db -> updateNtfMode db tkn suppliedNtfMode
|
||||
pure status
|
||||
@@ -2015,8 +1949,8 @@ deleteNtfToken' :: AgentClient -> DeviceToken -> AM ()
|
||||
deleteNtfToken' c deviceToken =
|
||||
withStore' c getSavedNtfToken >>= \case
|
||||
Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do
|
||||
when (deviceToken /= savedDeviceToken) $ logWarn "deleteNtfToken: different token"
|
||||
deleteToken c tkn
|
||||
when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "deleteNtfToken: different token"
|
||||
deleteToken_ c tkn
|
||||
deleteNtfSubs c NSCSmpDelete
|
||||
_ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"
|
||||
|
||||
@@ -2048,8 +1982,21 @@ toggleConnectionNtfs' c connId enable = do
|
||||
| otherwise = do
|
||||
withStore' c $ \db -> setConnectionNtfs db connId enable
|
||||
ns <- asks ntfSupervisor
|
||||
let cmd = if enable then NSCCreate else NSCSmpDelete
|
||||
atomically $ sendNtfSubCommand ns (cmd, [connId])
|
||||
let cmd = if enable then NSCCreate else NSCDelete
|
||||
atomically $ sendNtfSubCommand ns (connId, cmd)
|
||||
|
||||
deleteToken_ :: AgentClient -> NtfToken -> AM ()
|
||||
deleteToken_ c tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
|
||||
ns <- asks ntfSupervisor
|
||||
forM_ ntfTokenId $ \tknId -> do
|
||||
let ntfTknAction = Just NTADelete
|
||||
withStore' c $ \db -> updateNtfToken db tkn ntfTknStatus ntfTknAction
|
||||
atomically $ nsUpdateToken ns tkn {ntfTknStatus, ntfTknAction}
|
||||
agentNtfDeleteToken c tknId tkn `catchAgentError` \case
|
||||
NTF _ AUTH -> pure ()
|
||||
e -> throwE e
|
||||
withStore' c $ \db -> removeNtfToken db tkn
|
||||
atomically $ nsRemoveNtfToken ns
|
||||
|
||||
withToken :: AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
|
||||
withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
|
||||
@@ -2083,24 +2030,13 @@ deleteNtfSubs c deleteCmd = do
|
||||
sendNtfConnCommands :: AgentClient -> NtfSupervisorCommand -> AM ()
|
||||
sendNtfConnCommands c cmd = do
|
||||
ns <- asks ntfSupervisor
|
||||
connIds <- liftIO $ S.toList <$> getSubscriptions c
|
||||
rs <- lift $ withStoreBatch' c (\db -> map (getConnData db) connIds)
|
||||
let (connIds', cErrs) = enabledNtfConns (zip connIds rs)
|
||||
forM_ (L.nonEmpty connIds') $ \connIds'' ->
|
||||
atomically $ writeTBQueue (ntfSubQ ns) (cmd, connIds'')
|
||||
unless (null cErrs) $ atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ ERRS cErrs)
|
||||
where
|
||||
enabledNtfConns :: [(ConnId, Either AgentErrorType (Maybe (ConnData, ConnectionMode)))] -> ([ConnId], [(ConnId, AgentErrorType)])
|
||||
enabledNtfConns = foldr addEnabledConn ([], [])
|
||||
where
|
||||
addEnabledConn ::
|
||||
(ConnId, Either AgentErrorType (Maybe (ConnData, ConnectionMode))) ->
|
||||
([ConnId], [(ConnId, AgentErrorType)]) ->
|
||||
([ConnId], [(ConnId, AgentErrorType)])
|
||||
addEnabledConn cData_ (cIds, errs) = case cData_ of
|
||||
(_, Right (Just (ConnData {connId, enableNtfs}, _))) -> if enableNtfs then (connId : cIds, errs) else (cIds, errs)
|
||||
(connId, Right Nothing) -> (cIds, (connId, INTERNAL "no connection data") : errs)
|
||||
(connId, Left e) -> (cIds, (connId, e) : errs)
|
||||
connIds <- liftIO $ getSubscriptions c
|
||||
forM_ connIds $ \connId -> do
|
||||
withStore' c (`getConnData` connId) >>= \case
|
||||
Just (ConnData {enableNtfs}, _) ->
|
||||
when enableNtfs . atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
|
||||
_ ->
|
||||
atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ ERR $ INTERNAL "no connection data")
|
||||
|
||||
setNtfServers :: AgentClient -> [NtfServer] -> IO ()
|
||||
setNtfServers c = atomically . writeTVar (ntfServers c)
|
||||
@@ -2161,13 +2097,9 @@ debugAgentLocks AgentClient {connLocks = cs, invLocks = is, deleteLock = d} = do
|
||||
getLocks ls = atomically $ M.mapKeys (B.unpack . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls)
|
||||
|
||||
getSMPServer :: AgentClient -> UserId -> AM SMPServerWithAuth
|
||||
getSMPServer c userId = getNextSMPServer c userId []
|
||||
getSMPServer c userId = withUserServers c userId pickServer
|
||||
{-# INLINE getSMPServer #-}
|
||||
|
||||
getNextSMPServer :: AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth
|
||||
getNextSMPServer c userId = getNextServer c userId storageSrvs
|
||||
{-# INLINE getNextSMPServer #-}
|
||||
|
||||
subscriber :: AgentClient -> AM' ()
|
||||
subscriber c@AgentClient {msgQ} = forever $ do
|
||||
t <- atomically $ readTBQueue msgQ
|
||||
@@ -2180,12 +2112,12 @@ cleanupManager c@AgentClient {subQ} = do
|
||||
liftIO $ threadDelay' delay
|
||||
int <- asks (cleanupInterval . config)
|
||||
ttl <- asks $ storedMsgDataTTL . config
|
||||
forever $ waitActive $ do
|
||||
forever $ do
|
||||
liftIO $ waitUntilActive c
|
||||
run ERR deleteConns
|
||||
run ERR $ withStore' c (`deleteRcvMsgHashesExpired` ttl)
|
||||
run ERR $ withStore' c (`deleteSndMsgsExpired` ttl)
|
||||
run ERR $ withStore' c (`deleteRatchetKeyHashesExpired` ttl)
|
||||
run ERR $ withStore' c (`deleteExpiredNtfTokensToDelete` ttl)
|
||||
run RFERR deleteRcvFilesExpired
|
||||
run RFERR deleteRcvFilesDeleted
|
||||
run RFERR deleteRcvFilesTmpPaths
|
||||
@@ -2201,7 +2133,6 @@ cleanupManager c@AgentClient {subQ} = do
|
||||
step <- asks $ cleanupStepInterval . config
|
||||
liftIO $ threadDelay step
|
||||
-- we are catching it to avoid CRITICAL errors in tests when this is the only remaining handle to active
|
||||
waitActive :: ReaderT Env IO a -> AM' ()
|
||||
waitActive a = liftIO (E.tryAny $ waitUntilActive c) >>= either (\_ -> pure ()) (\_ -> void a)
|
||||
deleteConns =
|
||||
withLock (deleteLock c) "cleanupManager" $ do
|
||||
@@ -2243,7 +2174,7 @@ cleanupManager c@AgentClient {subQ} = do
|
||||
deleteExpiredReplicasForDeletion = do
|
||||
rcvFilesTTL <- asks $ rcvFilesTTL . config
|
||||
withStore' c (`deleteDeletedSndChunkReplicasExpired` rcvFilesTTL)
|
||||
notify :: forall e. AEntityI e => AEntityId -> AEvent e -> AM ()
|
||||
notify :: forall e. AEntityI e => EntityId -> AEvent e -> AM ()
|
||||
notify entId cmd = atomically $ writeTBQueue subQ ("", entId, AEvt (sAEntity @e) cmd)
|
||||
|
||||
data ACKd = ACKd | ACKPending
|
||||
@@ -2324,9 +2255,12 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
atomically $ incSMPServerStat c userId srv recvMsgs
|
||||
void . handleNotifyAck $ do
|
||||
msg' <- decryptSMPMessage rq msg
|
||||
handleNotifyAck $ case msg' of
|
||||
ack' <- handleNotifyAck $ case msg' of
|
||||
SMP.ClientRcvMsgBody {msgTs = srvTs, msgFlags, msgBody} -> processClientMsg srvTs msgFlags msgBody
|
||||
SMP.ClientRcvMsgQuota {} -> queueDrained >> ack
|
||||
whenM (liftIO $ hasGetLock c rq) $
|
||||
notify (MSGNTF $ SMP.rcvMessageMeta srvMsgId msg')
|
||||
pure ack'
|
||||
where
|
||||
queueDrained = case conn of
|
||||
DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ A_QCONT (sndAddress rq)
|
||||
@@ -2377,7 +2311,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
HELLO -> helloMsg srvMsgId msgMeta conn'' >> ackDel msgId
|
||||
-- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command
|
||||
A_MSG body -> do
|
||||
logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret' srvMsgId
|
||||
logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
|
||||
notify $ MSG msgMeta msgFlags body
|
||||
pure ACKPending
|
||||
A_RCVD rcpts -> qDuplex conn'' "RCVD" $ messagesRcvd rcpts msgMeta
|
||||
@@ -2387,7 +2321,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
QUSE qs -> qDuplexAckDel conn'' "QUSE" $ qUseMsg srvMsgId qs
|
||||
-- no action needed for QTEST
|
||||
-- any message in the new queue will mark it active and trigger deletion of the old queue
|
||||
QTEST _ -> logServer "<--" c srv rId ("MSG <QTEST>:" <> logSecret' srvMsgId) >> ackDel msgId
|
||||
QTEST _ -> logServer "<--" c srv rId ("MSG <QTEST>:" <> logSecret srvMsgId) >> ackDel msgId
|
||||
EREADY _ -> qDuplexAckDel conn'' "EREADY" $ ereadyMsg rcPrev
|
||||
where
|
||||
qDuplexAckDel :: Connection c -> String -> (Connection 'CDuplex -> AM ()) -> AM ACKd
|
||||
@@ -2410,7 +2344,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
| otherwise ->
|
||||
liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
|
||||
AgentMessage _ (A_MSG body) -> do
|
||||
logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret' srvMsgId
|
||||
logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
|
||||
notify $ MSG msgMeta msgFlags body
|
||||
pure ACKPending
|
||||
_ -> ack
|
||||
@@ -2481,14 +2415,17 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
handleNotifyAck :: AM ACKd -> AM ACKd
|
||||
handleNotifyAck m = m `catchAgentError` \e -> notify (ERR e) >> ack
|
||||
SMP.END ->
|
||||
atomically (ifM (activeClientSession c tSess sessId) (removeSubscription c connId $> True) (pure False))
|
||||
atomically (TM.lookup tSess (smpClients c) $>>= (tryReadTMVar . sessionVar) >>= processEND)
|
||||
>>= notifyEnd
|
||||
where
|
||||
processEND = \case
|
||||
Just (Right clnt)
|
||||
| sessId == sessionId (thParams $ connectedClient clnt) ->
|
||||
removeSubscription c connId $> True
|
||||
_ -> pure False
|
||||
notifyEnd removed
|
||||
| removed = notify END >> logServer "<--" c srv rId "END"
|
||||
| otherwise = logServer "<--" c srv rId "END from disconnected client - ignored"
|
||||
-- Possibly, we need to add some flag to connection that it was deleted
|
||||
SMP.DELD -> atomically (removeSubscription c connId) >> notify DELD
|
||||
SMP.ERR e -> notify $ ERR $ SMP (B.unpack $ strEncode srv) e
|
||||
r -> unexpected r
|
||||
where
|
||||
@@ -2513,7 +2450,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
|
||||
decryptClientMessage :: C.DhSecretX25519 -> SMP.ClientMsgEnvelope -> AM (SMP.PrivHeader, AgentMsgEnvelope)
|
||||
decryptClientMessage e2eDh SMP.ClientMsgEnvelope {cmNonce, cmEncBody} = do
|
||||
clientMsg <- liftEither $ agentCbDecrypt e2eDh cmNonce cmEncBody
|
||||
clientMsg <- agentCbDecrypt e2eDh cmNonce cmEncBody
|
||||
SMP.ClientMessage privHeader clientBody <- parseMessage clientMsg
|
||||
agentEnvelope <- parseMessage clientBody
|
||||
-- Version check is removed here, because when connecting via v1 contact address the agent still sends v2 message,
|
||||
@@ -2529,7 +2466,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
|
||||
smpConfirmation :: SMP.MsgId -> Connection c -> Maybe C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM ()
|
||||
smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
|
||||
logServer "<--" c srv rId $ "MSG <CONF>:" <> logSecret' srvMsgId
|
||||
logServer "<--" c srv rId $ "MSG <CONF>:" <> logSecret srvMsgId
|
||||
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
|
||||
let ConnData {pqSupport} = toConnData conn'
|
||||
unless
|
||||
@@ -2598,7 +2535,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
|
||||
helloMsg :: SMP.MsgId -> MsgMeta -> Connection c -> AM ()
|
||||
helloMsg srvMsgId MsgMeta {pqEncryption} conn' = do
|
||||
logServer "<--" c srv rId $ "MSG <HELLO>:" <> logSecret' srvMsgId
|
||||
logServer "<--" c srv rId $ "MSG <HELLO>:" <> logSecret srvMsgId
|
||||
case status of
|
||||
Active -> prohibited "hello: active"
|
||||
_ ->
|
||||
@@ -2622,7 +2559,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
continueSending srvMsgId addr (DuplexConnection _ _ sqs) =
|
||||
case findQ addr sqs of
|
||||
Just sq -> do
|
||||
logServer "<--" c srv rId $ "MSG <QCONT>:" <> logSecret' srvMsgId
|
||||
logServer "<--" c srv rId $ "MSG <QCONT>:" <> logSecret srvMsgId
|
||||
atomically $
|
||||
TM.lookup (qAddress sq) (smpDeliveryWorkers c)
|
||||
>>= mapM_ (\(_, retryLock) -> tryPutTMVar retryLock ())
|
||||
@@ -2631,7 +2568,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
|
||||
messagesRcvd :: NonEmpty AMessageReceipt -> MsgMeta -> Connection 'CDuplex -> AM ACKd
|
||||
messagesRcvd rcpts msgMeta@MsgMeta {broker = (srvMsgId, _)} _ = do
|
||||
logServer "<--" c srv rId $ "MSG <RCPT>:" <> logSecret' srvMsgId
|
||||
logServer "<--" c srv rId $ "MSG <RCPT>:" <> logSecret srvMsgId
|
||||
rs <- forM rcpts $ \rcpt -> clientReceipt rcpt `catchAgentError` \e -> notify (ERR e) $> Nothing
|
||||
case L.nonEmpty . catMaybes $ L.toList rs of
|
||||
Just rs' -> notify (RCVD msgMeta rs') $> ACKPending
|
||||
@@ -2671,7 +2608,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
sq2 <- withStore c $ \db -> do
|
||||
liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs
|
||||
addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
logServer "<--" c srv rId $ "MSG <QADD>:" <> logSecret' srvMsgId <> " " <> logSecret (senderId queueAddress)
|
||||
logServer "<--" c srv rId $ "MSG <QADD>:" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress)
|
||||
let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
|
||||
void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPublicKey)]
|
||||
sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY
|
||||
@@ -2692,7 +2629,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
Just rq'@RcvQueue {rcvId, e2ePrivKey = dhPrivKey, smpClientVersion = cVer, status = status'}
|
||||
| status' == New || status' == Confirmed -> do
|
||||
checkRQSwchStatus rq RSSendingQADD
|
||||
logServer "<--" c srv rId $ "MSG <QKEY>:" <> logSecret' srvMsgId <> " " <> logSecret senderId
|
||||
logServer "<--" c srv rId $ "MSG <QKEY>:" <> logSecret srvMsgId <> " " <> logSecret senderId
|
||||
let dhSecret = C.dh' dhPublicKey dhPrivKey
|
||||
withStore' c $ \db -> setRcvQueueConfirmedE2E db rq' dhSecret $ min cVer cVer'
|
||||
enqueueCommand c "" connId (Just smpServer) $ AInternalCommand $ ICQSecure rcvId senderKey
|
||||
@@ -2713,7 +2650,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
case find ((replaceQId ==) . dbQId) sqs of
|
||||
Just sq1 -> do
|
||||
checkSQSwchStatus sq1 SSSendingQKEY
|
||||
logServer "<--" c srv rId $ "MSG <QUSE>:" <> logSecret' srvMsgId <> " " <> logSecret (snd addr)
|
||||
logServer "<--" c srv rId $ "MSG <QUSE>:" <> logSecret srvMsgId <> " " <> logSecret (snd addr)
|
||||
withStore' c $ \db -> setSndQueueStatus db sq' Secured
|
||||
let sq'' = (sq' :: SndQueue) {status = Secured}
|
||||
-- sending QTEST to the new queue only, the old one will be removed if sent successfully
|
||||
@@ -2737,7 +2674,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId
|
||||
|
||||
smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM ()
|
||||
smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData _) cInfo = do
|
||||
logServer "<--" c srv rId $ "MSG <KEY>:" <> logSecret' srvMsgId
|
||||
logServer "<--" c srv rId $ "MSG <KEY>:" <> logSecret srvMsgId
|
||||
case conn' of
|
||||
ContactConnection {} -> do
|
||||
-- show connection request even if invitaion via contact address is not compatible.
|
||||
@@ -2882,7 +2819,7 @@ secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv
|
||||
currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config
|
||||
withStore c $ \db -> runExceptT $ do
|
||||
let agentMsgBody = smpEncode aMessage
|
||||
(_, internalSndId, _) <- ExceptT $ updateSndIds db connId
|
||||
(_, internalSndId, _) <- liftIO $ updateSndIds db connId
|
||||
liftIO $ updateSndMsgHash db connId internalSndId (C.sha256Hash agentMsgBody)
|
||||
let pqEnc = CR.pqSupportToEnc pqSupport
|
||||
(encConnInfo, _) <- agentRatchetEncrypt db cData agentMsgBody e2eEncConnInfoLength (Just pqEnc) currentE2EVersion
|
||||
@@ -2915,7 +2852,7 @@ storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq
|
||||
currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config
|
||||
withStore c $ \db -> runExceptT $ do
|
||||
internalTs <- liftIO getCurrentTime
|
||||
(internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
|
||||
(internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
|
||||
let agentMsgStr = smpEncode agentMsg
|
||||
internalHash = C.sha256Hash agentMsgStr
|
||||
pqEnc = CR.pqSupportToEnc pqSupport
|
||||
@@ -2941,7 +2878,7 @@ enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do
|
||||
storeRatchetKey :: VersionSMPA -> AM InternalId
|
||||
storeRatchetKey agentVersion = withStore c $ \db -> runExceptT $ do
|
||||
internalTs <- liftIO getCurrentTime
|
||||
(internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId
|
||||
(internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
|
||||
let agentMsg = AgentRatchetInfo ""
|
||||
agentMsgStr = smpEncode agentMsg
|
||||
internalHash = C.sha256Hash agentMsgStr
|
||||
|
||||
@@ -12,7 +12,6 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
@@ -30,7 +29,6 @@ module Simplex.Messaging.Agent.Client
|
||||
withConnLocks,
|
||||
withInvLock,
|
||||
withLockMap,
|
||||
getMapLock,
|
||||
ipAddressProtected,
|
||||
closeAgentClient,
|
||||
closeProtocolServerClients,
|
||||
@@ -57,10 +55,8 @@ module Simplex.Messaging.Agent.Client
|
||||
secureQueue,
|
||||
secureSndQueue,
|
||||
enableQueueNotifications,
|
||||
EnableQueueNtfReq (..),
|
||||
enableQueuesNtfs,
|
||||
disableQueueNotifications,
|
||||
DisableQueueNtfReq,
|
||||
disableQueuesNtfs,
|
||||
sendAgentMessage,
|
||||
getQueueInfo,
|
||||
@@ -71,9 +67,7 @@ module Simplex.Messaging.Agent.Client
|
||||
agentNtfDeleteToken,
|
||||
agentNtfEnableCron,
|
||||
agentNtfCreateSubscription,
|
||||
agentNtfCreateSubscriptions,
|
||||
agentNtfCheckSubscription,
|
||||
agentNtfCheckSubscriptions,
|
||||
agentNtfDeleteSubscription,
|
||||
agentXFTPDownloadChunk,
|
||||
agentXFTPNewChunk,
|
||||
@@ -88,12 +82,10 @@ module Simplex.Messaging.Agent.Client
|
||||
deleteQueues,
|
||||
logServer,
|
||||
logSecret,
|
||||
logSecret',
|
||||
removeSubscription,
|
||||
hasActiveSubscription,
|
||||
hasPendingSubscription,
|
||||
hasGetLock,
|
||||
releaseGetLock,
|
||||
activeClientSession,
|
||||
agentClientStore,
|
||||
agentDRG,
|
||||
@@ -121,7 +113,6 @@ module Simplex.Messaging.Agent.Client
|
||||
hasWorkToDo,
|
||||
hasWorkToDo',
|
||||
withWork,
|
||||
withWorkItems,
|
||||
agentOperations,
|
||||
agentOperationBracket,
|
||||
waitUntilActive,
|
||||
@@ -149,6 +140,7 @@ module Simplex.Messaging.Agent.Client
|
||||
userServers,
|
||||
pickServer,
|
||||
getNextServer,
|
||||
withUserServers,
|
||||
withNextSrv,
|
||||
incSMPServerStat,
|
||||
incSMPServerStat',
|
||||
@@ -156,7 +148,6 @@ module Simplex.Messaging.Agent.Client
|
||||
incXFTPServerStat',
|
||||
incXFTPServerSizeStat,
|
||||
incNtfServerStat,
|
||||
incNtfServerStat',
|
||||
AgentWorkersDetails (..),
|
||||
getAgentWorkersDetails,
|
||||
AgentWorkersSummary (..),
|
||||
@@ -172,7 +163,7 @@ module Simplex.Messaging.Agent.Client
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent (ThreadId, killThread)
|
||||
import Control.Concurrent (ThreadId, forkIO)
|
||||
import Control.Concurrent.Async (Async, uninterruptibleCancel)
|
||||
import Control.Concurrent.STM (retry)
|
||||
import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..))
|
||||
@@ -192,12 +183,12 @@ import qualified Data.ByteString.Char8 as B
|
||||
import Data.Either (isRight, partitionEithers)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find, foldl', partition)
|
||||
import Data.List (deleteFirstsBy, foldl', partition, (\\))
|
||||
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 Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
@@ -237,7 +228,7 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse, sumT
|
||||
import Simplex.Messaging.Protocol
|
||||
( AProtocolType (..),
|
||||
BrokerMsg,
|
||||
EntityId (..),
|
||||
EntityId,
|
||||
ErrorType,
|
||||
MsgFlags (..),
|
||||
MsgId,
|
||||
@@ -250,6 +241,7 @@ import Simplex.Messaging.Protocol
|
||||
ProtocolServer (..),
|
||||
ProtocolType (..),
|
||||
ProtocolTypeI (..),
|
||||
QueueId,
|
||||
QueueIdsKeys (..),
|
||||
RcvMessage (..),
|
||||
RcvNtfPublicDhKey,
|
||||
@@ -263,7 +255,7 @@ import Simplex.Messaging.Protocol
|
||||
VersionSMPC,
|
||||
XFTPServer,
|
||||
XFTPServerWithAuth,
|
||||
pattern NoEntity,
|
||||
sameSrvAddr',
|
||||
)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
@@ -274,11 +266,10 @@ import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessio
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
import System.Mem.Weak (Weak, deRefWeak)
|
||||
import System.Mem.Weak (Weak)
|
||||
import System.Random (randomR)
|
||||
import UnliftIO (mapConcurrently, timeout)
|
||||
import UnliftIO.Async (async)
|
||||
import UnliftIO.Concurrent (forkIO, mkWeakThreadId)
|
||||
import UnliftIO.Directory (doesFileExist, getTemporaryDirectory, removeFile)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
@@ -321,7 +312,8 @@ data AgentClient = AgentClient
|
||||
removedSubs :: TMap (UserId, SMPServer, SMP.RecipientId) SMPClientError,
|
||||
workerSeq :: TVar Int,
|
||||
smpDeliveryWorkers :: TMap SndQAddr (Worker, TMVar ()),
|
||||
asyncCmdWorkers :: TMap (ConnId, Maybe SMPServer) Worker,
|
||||
asyncCmdWorkers :: TMap (Maybe SMPServer) Worker,
|
||||
connCmdsQueued :: TMap ConnId Bool,
|
||||
ntfNetworkOp :: TVar AgentOpState,
|
||||
rcvNetworkOp :: TVar AgentOpState,
|
||||
msgDeliveryOp :: TVar AgentOpState,
|
||||
@@ -339,7 +331,6 @@ data AgentClient = AgentClient
|
||||
smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ())),
|
||||
clientId :: Int,
|
||||
agentEnv :: Env,
|
||||
proxySessTs :: TVar UTCTime,
|
||||
smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats,
|
||||
xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats,
|
||||
ntfServersStats :: TMap (UserId, NtfServer) AgentNtfServerStats,
|
||||
@@ -381,15 +372,13 @@ getAgentWorker' toW fromW name hasWork c key ws work = do
|
||||
restart <- atomically $ getWorker >>= maybe (pure False) (shouldRestart e_ (toW w) t maxRestarts)
|
||||
when restart runWork
|
||||
shouldRestart e_ Worker {workerId = wId, doWork, action, restarts} t maxRestarts w'
|
||||
| wId == workerId (toW w') = do
|
||||
rc <- readTVar restarts
|
||||
isActive <- readTVar $ active c
|
||||
checkRestarts isActive $ updateRestartCount t rc
|
||||
| wId == workerId (toW w') =
|
||||
checkRestarts . updateRestartCount t =<< readTVar restarts
|
||||
| otherwise =
|
||||
pure False -- there is a new worker in the map, no action
|
||||
where
|
||||
checkRestarts isActive rc
|
||||
| isActive && restartCount rc < maxRestarts = do
|
||||
checkRestarts rc
|
||||
| restartCount rc < maxRestarts = do
|
||||
writeTVar restarts rc
|
||||
hasWorkToDo' doWork
|
||||
void $ tryPutTMVar action Nothing
|
||||
@@ -397,7 +386,7 @@ getAgentWorker' toW fromW name hasWork c key ws work = do
|
||||
pure True
|
||||
| otherwise = do
|
||||
TM.delete key ws
|
||||
when isActive $ notifyErr $ CRITICAL True
|
||||
notifyErr $ CRITICAL True
|
||||
pure False
|
||||
where
|
||||
notifyErr err = do
|
||||
@@ -420,7 +409,7 @@ runWorkerAsync Worker {action} work =
|
||||
(atomically . tryPutTMVar action) -- if it was running (or if start crashes), put it back and unlock (don't lock if it was just started)
|
||||
(\a -> when (isNothing a) start) -- start worker if it's not running
|
||||
where
|
||||
start = atomically . putTMVar action . Just =<< mkWeakThreadId =<< forkIO work
|
||||
start = atomically . putTMVar action . Just =<< async work
|
||||
|
||||
data AgentOperation = AONtfNetwork | AORcvNetwork | AOMsgDelivery | AOSndNetwork | AODatabase
|
||||
deriving (Eq, Show)
|
||||
@@ -468,7 +457,6 @@ newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> IO AgentClient
|
||||
newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs agentEnv = do
|
||||
let cfg = config agentEnv
|
||||
qSize = tbqSize cfg
|
||||
proxySessTs <- newTVarIO =<< getCurrentTime
|
||||
acThread <- newTVarIO Nothing
|
||||
active <- newTVarIO True
|
||||
subQ <- newTBQueueIO qSize
|
||||
@@ -490,6 +478,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
|
||||
workerSeq <- newTVarIO 0
|
||||
smpDeliveryWorkers <- TM.emptyIO
|
||||
asyncCmdWorkers <- TM.emptyIO
|
||||
connCmdsQueued <- TM.emptyIO
|
||||
ntfNetworkOp <- newTVarIO $ AgentOpState False 0
|
||||
rcvNetworkOp <- newTVarIO $ AgentOpState False 0
|
||||
msgDeliveryOp <- newTVarIO $ AgentOpState False 0
|
||||
@@ -499,7 +488,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
|
||||
getMsgLocks <- TM.emptyIO
|
||||
connLocks <- TM.emptyIO
|
||||
invLocks <- TM.emptyIO
|
||||
deleteLock <- createLockIO
|
||||
deleteLock <- atomically createLock
|
||||
smpSubWorkers <- TM.emptyIO
|
||||
smpServersStats <- TM.emptyIO
|
||||
xftpServersStats <- TM.emptyIO
|
||||
@@ -528,6 +517,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
|
||||
workerSeq,
|
||||
smpDeliveryWorkers,
|
||||
asyncCmdWorkers,
|
||||
connCmdsQueued,
|
||||
ntfNetworkOp,
|
||||
rcvNetworkOp,
|
||||
msgDeliveryOp,
|
||||
@@ -541,7 +531,6 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs a
|
||||
smpSubWorkers,
|
||||
clientId,
|
||||
agentEnv,
|
||||
proxySessTs,
|
||||
smpServersStats,
|
||||
xftpServersStats,
|
||||
ntfServersStats,
|
||||
@@ -617,7 +606,7 @@ getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
|
||||
getSMPProxyClient :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
|
||||
getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} proxySrv_ destSess@(userId, destSrv, qId) = do
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
proxySrv <- maybe (getNextServer c userId proxySrvs [destSrv]) pure proxySrv_
|
||||
proxySrv <- maybe (getNextServer c userId [destSrv]) pure proxySrv_
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getClientVar proxySrv ts) >>= \(tSess, auth, v) ->
|
||||
either (newProxyClient tSess auth ts) (waitForProxyClient tSess auth) v
|
||||
@@ -666,7 +655,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
|
||||
Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
|
||||
|
||||
smpConnectClient :: AgentClient -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
|
||||
smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _) prs v =
|
||||
smpConnectClient c@AgentClient {smpClients, msgQ} tSess@(_, srv, _) prs v =
|
||||
newProtocolClient c tSess smpClients connectClient v
|
||||
`catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e
|
||||
where
|
||||
@@ -676,8 +665,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _)
|
||||
g <- asks random
|
||||
env <- ask
|
||||
liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
|
||||
ts <- readTVarIO proxySessTs
|
||||
smp <- ExceptT $ getProtocolClient g tSess cfg (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
|
||||
smp <- ExceptT $ getProtocolClient g tSess cfg (Just msgQ) $ smpClientDisconnected c tSess env v' prs
|
||||
pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
|
||||
|
||||
smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
|
||||
@@ -766,7 +754,7 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
|
||||
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
|
||||
|
||||
getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient
|
||||
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do
|
||||
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv, _) = do
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getSessVar workerSeq tSess ntfClients ts)
|
||||
@@ -778,9 +766,8 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tS
|
||||
connectClient v = do
|
||||
cfg <- lift $ getClientConfig c ntfCfg
|
||||
g <- asks random
|
||||
ts <- readTVarIO proxySessTs
|
||||
liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $
|
||||
getProtocolClient g tSess cfg Nothing ts $
|
||||
getProtocolClient g tSess cfg Nothing $
|
||||
clientDisconnected v
|
||||
|
||||
clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
|
||||
@@ -790,7 +777,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tS
|
||||
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
|
||||
|
||||
getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
|
||||
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do
|
||||
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(_, srv, _) = do
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getSessVar workerSeq tSess xftpClients ts)
|
||||
@@ -802,9 +789,8 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs}
|
||||
connectClient v = do
|
||||
cfg <- asks $ xftpCfg . config
|
||||
xftpNetworkConfig <- getNetworkConfig c
|
||||
ts <- readTVarIO proxySessTs
|
||||
liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $
|
||||
X.getXFTPClient tSess cfg {xftpNetworkConfig} ts $
|
||||
X.getXFTPClient tSess cfg {xftpNetworkConfig} $
|
||||
clientDisconnected v
|
||||
|
||||
clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
|
||||
@@ -905,6 +891,7 @@ closeAgentClient c = do
|
||||
atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect
|
||||
clearWorkers smpDeliveryWorkers >>= mapM_ (cancelWorker . fst)
|
||||
clearWorkers asyncCmdWorkers >>= mapM_ cancelWorker
|
||||
clear connCmdsQueued
|
||||
atomically . RQ.clear $ activeSubs c
|
||||
atomically . RQ.clear $ pendingSubs c
|
||||
clear subscrConns
|
||||
@@ -920,7 +907,7 @@ closeAgentClient c = do
|
||||
cancelWorker :: Worker -> IO ()
|
||||
cancelWorker Worker {doWork, action} = do
|
||||
noWorkToDo doWork
|
||||
atomically (tryTakeTMVar action) >>= mapM_ (mapM_ $ deRefWeak >=> mapM_ killThread)
|
||||
atomically (tryTakeTMVar action) >>= mapM_ (mapM_ uninterruptibleCancel)
|
||||
|
||||
waitUntilActive :: AgentClient -> IO ()
|
||||
waitUntilActive AgentClient {active} = unlessM (readTVarIO active) $ atomically $ unlessM (readTVar active) retry
|
||||
@@ -1010,7 +997,7 @@ withClient_ c tSess@(_, srv, _) action = do
|
||||
where
|
||||
logServerError :: AgentErrorType -> AM a
|
||||
logServerError e = do
|
||||
logServer "<--" c srv NoEntity $ bshow e
|
||||
logServer "<--" c srv "" $ bshow e
|
||||
throwE e
|
||||
|
||||
withProxySession :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
|
||||
@@ -1027,32 +1014,32 @@ withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do
|
||||
proxySrv = showServer . protocolClientServer' . protocolClient
|
||||
logServerError :: SMPConnectedClient -> AgentErrorType -> AM a
|
||||
logServerError cl e = do
|
||||
logServer ("<-- " <> proxySrv cl <> " <") c destSrv NoEntity $ bshow e
|
||||
logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ bshow e
|
||||
throwE e
|
||||
|
||||
withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a
|
||||
withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> AM a) -> AM a
|
||||
withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
|
||||
logServer' "-->" c srv entId cmdStr
|
||||
logServer "-->" c srv entId cmdStr
|
||||
res <- withClient_ c tSess action
|
||||
logServer' "<--" c srv entId "OK"
|
||||
logServer "<--" c srv entId "OK"
|
||||
return res
|
||||
|
||||
withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
|
||||
withClient c tSess action = withClient_ c tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
|
||||
{-# INLINE withClient #-}
|
||||
|
||||
withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
|
||||
withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
|
||||
withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
|
||||
{-# INLINE withLogClient #-}
|
||||
|
||||
withSMPClient :: SMPQueueRec q => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a
|
||||
withSMPClient c q cmdStr action = do
|
||||
tSess <- mkSMPTransportSession c q
|
||||
withLogClient c tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient
|
||||
withLogClient c tSess (queueId q) cmdStr $ action . connectedClient
|
||||
|
||||
sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
|
||||
sendOrProxySMPMessage c userId destSrv connId cmdStr spKey_ senderId msgFlags msg =
|
||||
sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendViaProxy sendDirectly
|
||||
sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
|
||||
sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg =
|
||||
sendOrProxySMPCommand c userId destSrv cmdStr senderId sendViaProxy sendDirectly
|
||||
where
|
||||
sendViaProxy smp proxySess = do
|
||||
atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts
|
||||
@@ -1066,15 +1053,14 @@ sendOrProxySMPCommand ::
|
||||
AgentClient ->
|
||||
UserId ->
|
||||
SMPServer ->
|
||||
ConnId ->
|
||||
ByteString ->
|
||||
SMP.SenderId ->
|
||||
(SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) ->
|
||||
(SMPClient -> ExceptT SMPClientError IO ()) ->
|
||||
AM (Maybe SMPServer)
|
||||
sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
|
||||
tSess <- mkTransportSession c userId destSrv connId
|
||||
ifM shouldUseProxy (sendViaProxy Nothing tSess) (sendDirectly tSess $> Nothing)
|
||||
sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
|
||||
sess <- mkTransportSession c userId destSrv senderId
|
||||
ifM shouldUseProxy (sendViaProxy Nothing sess) (sendDirectly sess $> Nothing)
|
||||
where
|
||||
shouldUseProxy = do
|
||||
cfg <- getNetworkConfig c
|
||||
@@ -1091,9 +1077,9 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
|
||||
SPFAllow -> True
|
||||
SPFAllowProtected -> ipAddressProtected cfg destSrv
|
||||
SPFProhibit -> False
|
||||
unknownServer = liftIO $ maybe True (\srvs -> all (`S.notMember` knownHosts srvs) destHosts) <$> TM.lookupIO userId (smpServers c)
|
||||
unknownServer = liftIO $ maybe True (notElem destSrv . knownSrvs) <$> TM.lookupIO userId (smpServers c)
|
||||
sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer)
|
||||
sendViaProxy proxySrv_ destSess@(_, _, connId_) = do
|
||||
sendViaProxy proxySrv_ destSess@(_, _, qId) = do
|
||||
r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
|
||||
r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess
|
||||
let proxySrv = protocolClientServer' smp
|
||||
@@ -1120,7 +1106,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
|
||||
-- checks that the current proxied relay session is the same one that was used to send the message and removes it
|
||||
deleteRelaySession =
|
||||
( TM.lookup destSess (smpProxiedRelays c)
|
||||
$>>= \(ProtoServerWithAuth srv _) -> tryReadSessVar (userId, srv, connId_) (smpClients c)
|
||||
$>>= \(ProtoServerWithAuth srv _) -> tryReadSessVar (userId, srv, qId) (smpClients c)
|
||||
)
|
||||
>>= \case
|
||||
Just (Right (SMPConnectedClient smp' prs))
|
||||
@@ -1140,7 +1126,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
|
||||
| serverHostError e -> ifM directAllowed (sendDirectly destSess $> Nothing) (throwE e)
|
||||
| otherwise -> throwE e
|
||||
sendDirectly tSess =
|
||||
withLogClient_ c tSess (unEntityId senderId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
|
||||
withLogClient_ c tSess senderId ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
|
||||
r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp
|
||||
case r of
|
||||
Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect
|
||||
@@ -1153,18 +1139,18 @@ ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts
|
||||
isOnionHost = \case THOnionHost _ -> True; _ -> False
|
||||
|
||||
withNtfClient :: AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a
|
||||
withNtfClient c srv (EntityId entId) = withLogClient c (0, srv, Nothing) entId
|
||||
withNtfClient c srv = withLogClient c (0, srv, Nothing)
|
||||
|
||||
withXFTPClient ::
|
||||
ProtocolServerClient v err msg =>
|
||||
AgentClient ->
|
||||
(UserId, ProtoServer msg, ByteString) ->
|
||||
(UserId, ProtoServer msg, EntityId) ->
|
||||
ByteString ->
|
||||
(Client msg -> ExceptT (ProtocolClientError err) IO b) ->
|
||||
AM b
|
||||
withXFTPClient c (userId, srv, sessEntId) cmdStr action = do
|
||||
tSess <- mkTransportSession c userId srv sessEntId
|
||||
withLogClient c tSess sessEntId cmdStr action
|
||||
withXFTPClient c (userId, srv, entityId) cmdStr action = do
|
||||
tSess <- mkTransportSession c userId srv entityId
|
||||
withLogClient c tSess entityId cmdStr action
|
||||
|
||||
liftClient :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a
|
||||
liftClient protocolError_ = liftError . protocolClientError protocolError_
|
||||
@@ -1211,8 +1197,7 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
g <- asks random
|
||||
liftIO $ do
|
||||
let tSess = (userId, srv, Nothing)
|
||||
ts <- readTVarIO $ proxySessTs c
|
||||
getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case
|
||||
getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case
|
||||
Right smp -> do
|
||||
rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g
|
||||
(sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
|
||||
@@ -1242,8 +1227,7 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
rcvPath <- getTempFilePath workDir
|
||||
liftIO $ do
|
||||
let tSess = (userId, srv, Nothing)
|
||||
ts <- readTVarIO $ proxySessTs c
|
||||
X.getXFTPClient tSess cfg {xftpNetworkConfig} ts (\_ -> pure ()) >>= \case
|
||||
X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
|
||||
Right xftp -> withTestChunk filePath $ do
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
@@ -1287,8 +1271,7 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do
|
||||
g <- asks random
|
||||
liftIO $ do
|
||||
let tSess = (userId, srv, Nothing)
|
||||
ts <- readTVarIO $ proxySessTs c
|
||||
getProtocolClient g tSess cfg Nothing ts (\_ -> pure ()) >>= \case
|
||||
getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case
|
||||
Right ntf -> do
|
||||
(nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
|
||||
(dhKey, _) <- atomically $ C.generateKeyPair g
|
||||
@@ -1309,12 +1292,12 @@ getXFTPWorkPath = do
|
||||
workDir <- readTVarIO =<< asks (xftpWorkDir . xftpAgent)
|
||||
maybe getTemporaryDirectory pure workDir
|
||||
|
||||
mkTransportSession :: MonadIO m => AgentClient -> UserId -> ProtoServer msg -> ByteString -> m (TransportSession msg)
|
||||
mkTransportSession c userId srv sessEntId = mkTSession userId srv sessEntId <$> getSessionMode c
|
||||
mkTransportSession :: MonadIO m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg)
|
||||
mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c
|
||||
{-# INLINE mkTransportSession #-}
|
||||
|
||||
mkTSession :: UserId -> ProtoServer msg -> ByteString -> TransportSessionMode -> TransportSession msg
|
||||
mkTSession userId srv sessEntId mode = (userId, srv, if mode == TSMEntity then Just sessEntId else Nothing)
|
||||
mkTSession :: UserId -> ProtoServer msg -> EntityId -> TransportSessionMode -> TransportSession msg
|
||||
mkTSession userId srv entityId mode = (userId, srv, if mode == TSMEntity then Just entityId else Nothing)
|
||||
{-# INLINE mkTSession #-}
|
||||
|
||||
mkSMPTransportSession :: (SMPQueueRec q, MonadIO m) => AgentClient -> q -> m SMPTransportSession
|
||||
@@ -1336,12 +1319,12 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode sender
|
||||
rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g
|
||||
(dhKey, privDhKey) <- atomically $ C.generateKeyPair g
|
||||
(e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
|
||||
logServer "-->" c srv NoEntity "NEW"
|
||||
logServer "-->" c srv "" "NEW"
|
||||
tSess <- mkTransportSession c userId srv connId
|
||||
(sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <-
|
||||
withClient c tSess $ \(SMPConnectedClient smp _) ->
|
||||
(sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure
|
||||
liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
|
||||
liftIO . logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
|
||||
let rq =
|
||||
RcvQueue
|
||||
{ userId,
|
||||
@@ -1386,7 +1369,6 @@ temporaryAgentError = \case
|
||||
PROXY _ _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> tempBrokerError e
|
||||
PROXY _ _ (ProxyProtocolError (SMP.PROXY SMP.NO_SESSION)) -> True
|
||||
INACTIVE -> True
|
||||
CRITICAL True _ -> True -- critical errors that do not show restart button are likely to be permanent
|
||||
_ -> False
|
||||
where
|
||||
tempBrokerError = \case
|
||||
@@ -1426,7 +1408,7 @@ subscribeQueues c qs = do
|
||||
checkQueue rq = do
|
||||
prohibited <- liftIO $ hasGetLock c rq
|
||||
pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq
|
||||
subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError ())
|
||||
subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
|
||||
subscribeQueues_ env session smp qs' = do
|
||||
let (userId, srv, _) = transportSession' smp
|
||||
atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs'
|
||||
@@ -1457,33 +1439,31 @@ activeClientSession c tSess sessId = sameSess <$> tryReadSessVar tSess (smpClien
|
||||
Just (Right (SMPConnectedClient smp _)) -> sessId == sessionId (thParams smp)
|
||||
_ -> False
|
||||
|
||||
type BatchResponses q e r = NonEmpty (q, Either e r)
|
||||
type BatchResponses e r = NonEmpty (RcvQueue, Either e r)
|
||||
|
||||
-- Please note: this function does not preserve order of results to be the same as the order of arguments,
|
||||
-- it includes arguments in the results instead.
|
||||
sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> [q] -> AM' [(q, Either AgentErrorType r)]
|
||||
sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> AM' [(RcvQueue, Either AgentErrorType r)]
|
||||
sendTSessionBatches statCmd toRQ action c qs =
|
||||
concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
|
||||
where
|
||||
batchQueues :: AM' [(SMPTransportSession, NonEmpty q)]
|
||||
batchQueues = do
|
||||
mode <- getSessionMode c
|
||||
pure . M.assocs $ foldr (batch mode) M.empty qs
|
||||
pure . M.assocs $ foldl' (batch mode) M.empty qs
|
||||
where
|
||||
batch mode q m =
|
||||
batch mode m q =
|
||||
let tSess = mkSMPTSession (toRQ q) mode
|
||||
in M.alter (Just . maybe [q] (q <|)) tSess m
|
||||
sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r)
|
||||
sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses AgentErrorType r)
|
||||
sendClientBatch (tSess@(_, srv, _), qs') =
|
||||
tryAgentError' (getSMPServerClient c tSess) >>= \case
|
||||
Left e -> pure $ L.map (,Left e) qs'
|
||||
Left e -> pure $ L.map ((,Left e) . toRQ) qs'
|
||||
Right (SMPConnectedClient smp _) -> liftIO $ do
|
||||
logServer' "-->" c srv (bshow (length qs') <> " queues") statCmd
|
||||
logServer "-->" c srv (bshow (length qs') <> " queues") statCmd
|
||||
L.map agentError <$> action smp qs'
|
||||
where
|
||||
agentError = second . first $ protocolClientError SMP $ clientServer smp
|
||||
|
||||
sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError ())
|
||||
sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
|
||||
sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
|
||||
where
|
||||
queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
|
||||
@@ -1532,39 +1512,32 @@ getSubscriptions :: AgentClient -> IO (Set ConnId)
|
||||
getSubscriptions = readTVarIO . subscrConns
|
||||
{-# INLINE getSubscriptions #-}
|
||||
|
||||
logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> EntityId -> ByteString -> m ()
|
||||
logServer dir c srv = logServer' dir c srv . unEntityId
|
||||
logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> QueueId -> ByteString -> m ()
|
||||
logServer dir AgentClient {clientId} srv qId cmdStr =
|
||||
logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
|
||||
{-# INLINE logServer #-}
|
||||
|
||||
logServer' :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> ByteString -> ByteString -> m ()
|
||||
logServer' dir AgentClient {clientId} srv qStr cmdStr =
|
||||
logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret' qStr, cmdStr]
|
||||
|
||||
showServer :: ProtocolServer s -> ByteString
|
||||
showServer ProtocolServer {host, port} =
|
||||
strEncode host <> B.pack (if null port then "" else ':' : port)
|
||||
{-# INLINE showServer #-}
|
||||
|
||||
logSecret :: EntityId -> ByteString
|
||||
logSecret = logSecret' . unEntityId
|
||||
logSecret :: ByteString -> ByteString
|
||||
logSecret bs = B64.encode $ B.take 3 bs
|
||||
{-# INLINE logSecret #-}
|
||||
|
||||
logSecret' :: ByteString -> ByteString
|
||||
logSecret' = B64.encode . B.take 3
|
||||
{-# INLINE logSecret' #-}
|
||||
|
||||
sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer)
|
||||
sendConfirmation c sq@SndQueue {userId, server, connId, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
|
||||
sendConfirmation c sq@SndQueue {userId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
|
||||
let (privHdr, spKey) = if sndSecure then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing)
|
||||
clientMsg = SMP.ClientMessage privHdr agentConfirmation
|
||||
msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
|
||||
sendOrProxySMPMessage c userId server connId "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
|
||||
sendOrProxySMPMessage c userId server "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
|
||||
sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
|
||||
|
||||
sendInvitation :: AgentClient -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
|
||||
sendInvitation c userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
|
||||
sendInvitation :: AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
|
||||
sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
|
||||
msg <- mkInvitation
|
||||
sendOrProxySMPMessage c userId smpServer connId "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
|
||||
sendOrProxySMPMessage c userId smpServer "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
|
||||
where
|
||||
mkInvitation :: AM ByteString
|
||||
-- this is only encrypted with per-queue E2E, not with double ratchet
|
||||
@@ -1590,7 +1563,7 @@ getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
|
||||
|
||||
decryptSMPMessage :: RcvQueue -> SMP.RcvMessage -> AM SMP.ClientRcvMsgBody
|
||||
decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} =
|
||||
liftEither $ parse SMP.clientRcvMsgBodyP (AGENT A_MESSAGE) =<< decrypt body
|
||||
liftEither . parse SMP.clientRcvMsgBodyP (AGENT A_MESSAGE) =<< decrypt body
|
||||
where
|
||||
decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
|
||||
|
||||
@@ -1600,8 +1573,8 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
|
||||
secureSMPQueue smp rcvPrivateKey rcvId senderKey
|
||||
|
||||
secureSndQueue :: AgentClient -> SndQueue -> AM ()
|
||||
secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} =
|
||||
void $ sendOrProxySMPCommand c userId server connId "SKEY <key>" sndId secureViaProxy secureDirectly
|
||||
secureSndQueue c SndQueue {userId, server, sndId, sndPrivateKey, sndPublicKey} =
|
||||
void $ sendOrProxySMPCommand c userId server "SKEY <key>" sndId secureViaProxy secureDirectly
|
||||
where
|
||||
-- TODO track statistics
|
||||
secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey
|
||||
@@ -1612,44 +1585,28 @@ enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtf
|
||||
withSMPClient c rq "NKEY <nkey>" $ \smp ->
|
||||
enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
|
||||
|
||||
data EnableQueueNtfReq = EnableQueueNtfReq
|
||||
{ eqnrNtfSub :: NtfSubscription,
|
||||
eqnrRq :: RcvQueue,
|
||||
eqnrAuthKeyPair :: C.AAuthKeyPair,
|
||||
eqnrRcvKeyPair :: C.KeyPairX25519
|
||||
}
|
||||
|
||||
enableQueuesNtfs :: AgentClient -> [EnableQueueNtfReq] -> AM' [(EnableQueueNtfReq, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
|
||||
enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_
|
||||
enableQueuesNtfs :: AgentClient -> [(RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)] -> AM' [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
|
||||
enableQueuesNtfs = sendTSessionBatches "NKEY" fst3 enableQueues_
|
||||
where
|
||||
enableQueues_ :: SMPClient -> NonEmpty EnableQueueNtfReq -> IO (NonEmpty (EnableQueueNtfReq, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
|
||||
enableQueues_ smp qs' = L.zip qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
|
||||
queueCreds :: EnableQueueNtfReq -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
|
||||
queueCreds EnableQueueNtfReq {eqnrRq, eqnrAuthKeyPair, eqnrRcvKeyPair} =
|
||||
let RcvQueue {rcvPrivateKey, rcvId} = eqnrRq
|
||||
(ntfPublicKey, _) = eqnrAuthKeyPair
|
||||
(rcvNtfPubDhKey, _) = eqnrRcvKeyPair
|
||||
in (rcvPrivateKey, rcvId, ntfPublicKey, rcvNtfPubDhKey)
|
||||
fst3 (x, _, _) = x
|
||||
enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
|
||||
enableQueues_ smp qs' = L.zipWith ((,) . fst3) qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
|
||||
queueCreds :: (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)
|
||||
queueCreds (RcvQueue {rcvPrivateKey, rcvId}, notifierKey, rcvNtfPublicDhKey) = (rcvPrivateKey, rcvId, notifierKey, rcvNtfPublicDhKey)
|
||||
|
||||
disableQueueNotifications :: AgentClient -> RcvQueue -> AM ()
|
||||
disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
|
||||
withSMPClient c rq "NDEL" $ \smp ->
|
||||
disableSMPQueueNotifications smp rcvPrivateKey rcvId
|
||||
|
||||
type DisableQueueNtfReq = (NtfSubscription, RcvQueue)
|
||||
|
||||
disableQueuesNtfs :: AgentClient -> [DisableQueueNtfReq] -> AM' [(DisableQueueNtfReq, Either AgentErrorType ())]
|
||||
disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
|
||||
where
|
||||
disableQueues_ :: SMPClient -> NonEmpty DisableQueueNtfReq -> IO (NonEmpty (DisableQueueNtfReq, Either (ProtocolClientError ErrorType) ()))
|
||||
disableQueues_ smp qs' = L.zip qs' <$> disableSMPQueuesNtfs smp (L.map queueCreds qs')
|
||||
queueCreds :: DisableQueueNtfReq -> (SMP.RcvPrivateAuthKey, SMP.RecipientId)
|
||||
queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvPrivateKey, rcvId)
|
||||
disableQueuesNtfs :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
|
||||
disableQueuesNtfs = sendTSessionBatches "NDEL" id $ sendBatch disableSMPQueuesNtfs
|
||||
|
||||
sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
|
||||
sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =
|
||||
withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp ->
|
||||
ackSMPMessage smp rcvPrivateKey rcvId msgId
|
||||
sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do
|
||||
withSMPClient c rq ("ACK:" <> logSecret msgId) $ \smp ->
|
||||
ackSMPMessage smp rcvPrivateKey rcvId msgId
|
||||
atomically $ releaseGetLock c rq
|
||||
|
||||
hasGetLock :: AgentClient -> RcvQueue -> IO Bool
|
||||
hasGetLock c RcvQueue {server, rcvId} =
|
||||
@@ -1681,10 +1638,10 @@ deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c
|
||||
pure rs
|
||||
|
||||
sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer)
|
||||
sendAgentMessage c sq@SndQueue {userId, server, connId, sndId, sndPrivateKey} msgFlags agentMsg = do
|
||||
sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags agentMsg = do
|
||||
let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
|
||||
msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
|
||||
sendOrProxySMPMessage c userId server connId "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
|
||||
sendOrProxySMPMessage c userId server "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
|
||||
|
||||
data ServerQueueInfo = ServerQueueInfo
|
||||
{ server :: SMPServer,
|
||||
@@ -1703,7 +1660,7 @@ getQueueInfo c rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientN
|
||||
let ntfId = enc . (\ClientNtfCreds {notifierId} -> notifierId) <$> clientNtfCreds
|
||||
pure ServerQueueInfo {server, rcvId = enc rcvId, sndId = enc sndId, ntfId, status = serializeQueueStatus status, info}
|
||||
where
|
||||
enc = decodeLatin1 . B64.encode . unEntityId
|
||||
enc = decodeLatin1 . B64.encode
|
||||
|
||||
agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
|
||||
agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
|
||||
@@ -1721,8 +1678,8 @@ agentNtfReplaceToken :: AgentClient -> NtfTokenId -> NtfToken -> DeviceToken ->
|
||||
agentNtfReplaceToken c tknId NtfToken {ntfServer, ntfPrivKey} token =
|
||||
withNtfClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token
|
||||
|
||||
agentNtfDeleteToken :: AgentClient -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM ()
|
||||
agentNtfDeleteToken c ntfServer ntfPrivKey tknId =
|
||||
agentNtfDeleteToken :: AgentClient -> NtfTokenId -> NtfToken -> AM ()
|
||||
agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} =
|
||||
withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
|
||||
|
||||
agentNtfEnableCron :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM ()
|
||||
@@ -1733,34 +1690,10 @@ agentNtfCreateSubscription :: AgentClient -> NtfTokenId -> NtfToken -> SMPQueueN
|
||||
agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
|
||||
withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
|
||||
|
||||
agentNtfCreateSubscriptions :: AgentClient -> NtfToken -> NonEmpty (NewNtfEntity 'Subscription) -> AM' (NonEmpty (Either AgentErrorType NtfSubscriptionId))
|
||||
agentNtfCreateSubscriptions = withNtfBatch "SNEW" ntfCreateSubscriptions
|
||||
|
||||
agentNtfCheckSubscription :: AgentClient -> NtfToken -> NtfSubscriptionId -> AM NtfSubStatus
|
||||
agentNtfCheckSubscription c NtfToken {ntfServer, ntfPrivKey} subId =
|
||||
agentNtfCheckSubscription :: AgentClient -> NtfSubscriptionId -> NtfToken -> AM NtfSubStatus
|
||||
agentNtfCheckSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
|
||||
withNtfClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
|
||||
|
||||
agentNtfCheckSubscriptions :: AgentClient -> NtfToken -> NonEmpty NtfSubscriptionId -> AM' (NonEmpty (Either AgentErrorType NtfSubStatus))
|
||||
agentNtfCheckSubscriptions = withNtfBatch "SCHK" ntfCheckSubscriptions
|
||||
|
||||
-- This batch sends all commands to one ntf server (client can only use one server at a time)
|
||||
withNtfBatch ::
|
||||
ByteString ->
|
||||
(NtfClient -> C.APrivateAuthKey -> NonEmpty a -> IO (NonEmpty (Either NtfClientError r))) ->
|
||||
AgentClient ->
|
||||
NtfToken ->
|
||||
NonEmpty a ->
|
||||
AM' (NonEmpty (Either AgentErrorType r))
|
||||
withNtfBatch cmdStr action c NtfToken {ntfServer, ntfPrivKey} subs = do
|
||||
let tSess = (0, ntfServer, Nothing)
|
||||
tryAgentError' (getNtfServerClient c tSess) >>= \case
|
||||
Left e -> pure $ L.map (\_ -> Left e) subs
|
||||
Right ntf -> liftIO $ do
|
||||
logServer' "-->" c ntfServer (bshow (length subs) <> " subscriptions") cmdStr
|
||||
L.map agentError <$> action ntf ntfPrivKey subs
|
||||
where
|
||||
agentError = first $ protocolClientError NTF $ clientServer ntf
|
||||
|
||||
agentNtfDeleteSubscription :: AgentClient -> NtfSubscriptionId -> NtfToken -> AM ()
|
||||
agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
|
||||
withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
|
||||
@@ -1775,10 +1708,10 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize},
|
||||
rKeys <- xftpRcvKeys n
|
||||
(sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
|
||||
let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
|
||||
logServer "-->" c srv NoEntity "FNEW"
|
||||
logServer "-->" c srv "" "FNEW"
|
||||
tSess <- mkTransportSession c userId srv chunkDigest
|
||||
(sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
|
||||
logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
|
||||
logServer "<--" c srv "" $ B.unwords ["SIDS", logSecret sndId]
|
||||
pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
|
||||
|
||||
agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM ()
|
||||
@@ -1802,7 +1735,7 @@ xftpRcvKeys n = do
|
||||
Just rKeys' -> pure rKeys'
|
||||
_ -> throwE $ INTERNAL "non-positive number of recipients"
|
||||
|
||||
xftpRcvIdsKeys :: NonEmpty EntityId -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey)
|
||||
xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey)
|
||||
xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
|
||||
|
||||
agentCbEncrypt :: SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> AM ByteString
|
||||
@@ -1830,9 +1763,9 @@ agentCbEncryptOnce clientVersion dhRcvPubKey msg = do
|
||||
|
||||
-- | NaCl crypto-box decrypt - both for messages received from the server
|
||||
-- and per-queue E2E encrypted messages from the sender that were inside.
|
||||
agentCbDecrypt :: C.DhSecretX25519 -> C.CbNonce -> ByteString -> Either AgentErrorType ByteString
|
||||
agentCbDecrypt :: C.DhSecretX25519 -> C.CbNonce -> ByteString -> AM ByteString
|
||||
agentCbDecrypt dhSecret nonce msg =
|
||||
first cryptoError $
|
||||
liftEither . first cryptoError $
|
||||
C.cbDecrypt dhSecret nonce msg
|
||||
|
||||
cryptoError :: C.CryptoError -> AgentErrorType
|
||||
@@ -1858,39 +1791,12 @@ withWork c doWork getWork action =
|
||||
withStore' c getWork >>= \case
|
||||
Right (Just r) -> action r
|
||||
Right Nothing -> noWork
|
||||
-- worker is stopped here (noWork) because the next iteration is likely to produce the same result
|
||||
Left e@SEWorkItemError {} -> noWork >> notifyErr (CRITICAL False) e
|
||||
Left e -> notifyErr INTERNAL e
|
||||
where
|
||||
noWork = liftIO $ noWorkToDo doWork
|
||||
notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e)
|
||||
|
||||
withWorkItems :: AgentClient -> TMVar () -> (DB.Connection -> IO (Either StoreError [Either StoreError a])) -> (NonEmpty a -> AM ()) -> AM ()
|
||||
withWorkItems c doWork getWork action = do
|
||||
withStore' c getWork >>= \case
|
||||
Right [] -> noWork
|
||||
Right rs -> do
|
||||
let (errs, items) = partitionEithers rs
|
||||
case L.nonEmpty items of
|
||||
Just items' -> action items'
|
||||
Nothing -> do
|
||||
let criticalErr = find workItemError errs
|
||||
forM_ criticalErr $ \err -> do
|
||||
notifyErr (CRITICAL False) err
|
||||
when (all workItemError errs) noWork
|
||||
unless (null errs) $
|
||||
atomically $
|
||||
writeTBQueue (subQ c) ("", "", AEvt SAENone $ ERRS $ map (\e -> ("", INTERNAL $ show e)) errs)
|
||||
Left e
|
||||
| workItemError e -> noWork >> notifyErr (CRITICAL False) e
|
||||
| otherwise -> notifyErr INTERNAL e
|
||||
where
|
||||
workItemError = \case
|
||||
SEWorkItemError {} -> True
|
||||
_ -> False
|
||||
noWork = liftIO $ noWorkToDo doWork
|
||||
notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e)
|
||||
|
||||
noWorkToDo :: TMVar () -> IO ()
|
||||
noWorkToDo = void . atomically . tryTakeTMVar
|
||||
{-# INLINE noWorkToDo #-}
|
||||
@@ -2015,7 +1921,6 @@ withStoreBatch' c actions = withStoreBatch c (fmap (fmap Right) . actions)
|
||||
storeError :: StoreError -> AgentErrorType
|
||||
storeError = \case
|
||||
SEConnNotFound -> CONN NOT_FOUND
|
||||
SEUserNotFound -> NO_USER
|
||||
SERatchetNotFound -> CONN NOT_FOUND
|
||||
SEConnDuplicate -> CONN DUPLICATE
|
||||
SEBadConnType CRcv -> CONN SIMPLEX
|
||||
@@ -2034,82 +1939,33 @@ userServers c = case protocolTypeI @p of
|
||||
SPXFTP -> xftpServers c
|
||||
{-# INLINE userServers #-}
|
||||
|
||||
pickServer :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
|
||||
pickServer :: forall p. NonEmpty (ProtoServerWithAuth p) -> AM (ProtoServerWithAuth p)
|
||||
pickServer = \case
|
||||
(_, srv) :| [] -> pure srv
|
||||
srv :| [] -> pure srv
|
||||
servers -> do
|
||||
gen <- asks randomServer
|
||||
atomically $ snd . (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
|
||||
atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
|
||||
|
||||
getNextServer ::
|
||||
(ProtocolTypeI p, UserProtocol p) =>
|
||||
AgentClient ->
|
||||
UserId ->
|
||||
(UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
|
||||
[ProtocolServer p] ->
|
||||
AM (ProtoServerWithAuth p)
|
||||
getNextServer c userId srvsSel usedSrvs = do
|
||||
srvs <- getUserServers_ c userId srvsSel
|
||||
snd <$> getNextServer_ srvs (usedOperatorsHosts srvs usedSrvs)
|
||||
getNextServer :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> [ProtocolServer p] -> AM (ProtoServerWithAuth p)
|
||||
getNextServer c userId usedSrvs = withUserServers c userId $ \srvs ->
|
||||
case L.nonEmpty $ deleteFirstsBy sameSrvAddr' (L.toList srvs) (map noAuthSrv usedSrvs) of
|
||||
Just srvs' -> pickServer srvs'
|
||||
_ -> pickServer srvs
|
||||
|
||||
usedOperatorsHosts :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) -> [ProtocolServer p] -> (Set (Maybe OperatorId), Set TransportHost)
|
||||
usedOperatorsHosts srvs usedSrvs = (usedOperators, usedHosts)
|
||||
where
|
||||
usedHosts = S.unions $ map serverHosts usedSrvs
|
||||
usedOperators = S.fromList $ mapMaybe usedOp $ L.toList srvs
|
||||
usedOp (op, srv) = if hasUsedHost srv then Just op else Nothing
|
||||
hasUsedHost (ProtoServerWithAuth srv _) = any (`S.member` usedHosts) $ serverHosts srv
|
||||
|
||||
getNextServer_ ::
|
||||
(ProtocolTypeI p, UserProtocol p) =>
|
||||
NonEmpty (Maybe OperatorId, ProtoServerWithAuth p) ->
|
||||
(Set (Maybe OperatorId), Set TransportHost) ->
|
||||
AM (NonEmpty (Maybe OperatorId, ProtoServerWithAuth p), ProtoServerWithAuth p)
|
||||
getNextServer_ servers (usedOperators, usedHosts) = do
|
||||
-- choose from servers of unused operators, when possible
|
||||
let otherOpsSrvs = filterOrAll ((`S.notMember` usedOperators) . fst) servers
|
||||
-- choose from servers with unused hosts when possible
|
||||
unusedSrvs = filterOrAll (isUnusedServer usedHosts) otherOpsSrvs
|
||||
(otherOpsSrvs,) <$> pickServer unusedSrvs
|
||||
where
|
||||
filterOrAll p srvs = fromMaybe srvs $ L.nonEmpty $ L.filter p srvs
|
||||
|
||||
isUnusedServer :: Set TransportHost -> (Maybe OperatorId, ProtoServerWithAuth p) -> Bool
|
||||
isUnusedServer usedHosts (_, ProtoServerWithAuth ProtocolServer {host} _) = all (`S.notMember` usedHosts) host
|
||||
|
||||
getUserServers_ ::
|
||||
(ProtocolTypeI p, UserProtocol p) =>
|
||||
AgentClient ->
|
||||
UserId ->
|
||||
(UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
|
||||
AM (NonEmpty (Maybe OperatorId, ProtoServerWithAuth p))
|
||||
getUserServers_ c userId srvsSel =
|
||||
withUserServers :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> (NonEmpty (ProtoServerWithAuth p) -> AM a) -> AM a
|
||||
withUserServers c userId action =
|
||||
liftIO (TM.lookupIO userId $ userServers c) >>= \case
|
||||
Just srvs -> pure $ srvsSel srvs
|
||||
Just srvs -> action $ enabledSrvs srvs
|
||||
_ -> throwE $ INTERNAL "unknown userId - no user servers"
|
||||
|
||||
-- This function checks used servers and operators every time to allow
|
||||
-- changing configuration while retry look is executing.
|
||||
-- This function is not thread safe.
|
||||
withNextSrv ::
|
||||
(ProtocolTypeI p, UserProtocol p) =>
|
||||
AgentClient ->
|
||||
UserId ->
|
||||
(UserServers p -> NonEmpty (Maybe OperatorId, ProtoServerWithAuth p)) ->
|
||||
TVar (Set TransportHost) ->
|
||||
[ProtocolServer p] ->
|
||||
(ProtoServerWithAuth p -> AM a) ->
|
||||
AM a
|
||||
withNextSrv c userId srvsSel triedHosts usedSrvs action = do
|
||||
srvs <- getUserServers_ c userId srvsSel
|
||||
let (usedOperators, usedHosts) = usedOperatorsHosts srvs usedSrvs
|
||||
tried <- readTVarIO triedHosts
|
||||
let triedOrUsed = S.union tried usedHosts
|
||||
(otherOpsSrvs, srvAuth@(ProtoServerWithAuth srv _)) <- getNextServer_ srvs (usedOperators, triedOrUsed)
|
||||
let newHosts = serverHosts srv
|
||||
unusedSrvs = L.filter (isUnusedServer $ S.union triedOrUsed newHosts) otherOpsSrvs
|
||||
!tried' = if null unusedSrvs then S.empty else S.union tried newHosts
|
||||
atomically $ writeTVar triedHosts tried'
|
||||
withNextSrv :: forall p a. (ProtocolTypeI p, UserProtocol p) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> (ProtoServerWithAuth p -> AM a) -> AM a
|
||||
withNextSrv c userId usedSrvs initUsed action = do
|
||||
used <- readTVarIO usedSrvs
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId used
|
||||
srvs_ <- liftIO $ TM.lookupIO userId $ userServers c
|
||||
let unused = maybe [] ((\\ used) . map protoServer . L.toList . enabledSrvs) srvs_
|
||||
used' = if null unused then initUsed else srv : used
|
||||
atomically $ writeTVar usedSrvs $! used'
|
||||
action srvAuth
|
||||
|
||||
incSMPServerStat :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> STM ()
|
||||
@@ -2135,13 +1991,9 @@ incXFTPServerStat_ = incServerStat (\AgentClient {xftpServersStats = s} -> s) ne
|
||||
{-# INLINE incXFTPServerStat_ #-}
|
||||
|
||||
incNtfServerStat :: AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> STM ()
|
||||
incNtfServerStat c userId srv sel = incNtfServerStat' c userId srv sel 1
|
||||
incNtfServerStat c userId srv sel = incServerStat (\AgentClient {ntfServersStats = s} -> s) newAgentNtfServerStats c userId srv sel 1
|
||||
{-# INLINE incNtfServerStat #-}
|
||||
|
||||
incNtfServerStat' :: AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> Int -> STM ()
|
||||
incNtfServerStat' = incServerStat (\AgentClient {ntfServersStats = s} -> s) newAgentNtfServerStats
|
||||
{-# INLINE incNtfServerStat' #-}
|
||||
|
||||
incServerStat :: Num n => (AgentClient -> TMap (UserId, ProtocolServer p) s) -> STM s -> AgentClient -> UserId -> ProtocolServer p -> (s -> TVar n) -> n -> STM ()
|
||||
incServerStat statsSel mkNewStats c userId srv sel n = do
|
||||
TM.lookup (userId, srv) (statsSel c) >>= \case
|
||||
|
||||
@@ -17,14 +17,11 @@ module Simplex.Messaging.Agent.Env.SQLite
|
||||
AgentConfig (..),
|
||||
InitialAgentServers (..),
|
||||
ServerCfg (..),
|
||||
ServerRoles (..),
|
||||
OperatorId,
|
||||
UserServers (..),
|
||||
NetworkConfig (..),
|
||||
presetServerCfg,
|
||||
allRoles,
|
||||
enabledServerCfg,
|
||||
mkUserServers,
|
||||
serverHosts,
|
||||
defaultAgentConfig,
|
||||
defaultReconnectInterval,
|
||||
tryAgentError,
|
||||
@@ -44,8 +41,6 @@ module Simplex.Messaging.Agent.Env.SQLite
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent (ThreadId)
|
||||
import Control.Exception (BlockedIndefinitelyOnSTM (..), SomeException, fromException)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
@@ -58,8 +53,6 @@ import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Time.Clock (NominalDiffTime, nominalDay)
|
||||
import Data.Time.Clock.System (SystemTime (..))
|
||||
import Data.Word (Word16)
|
||||
@@ -77,14 +70,14 @@ import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion)
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange)
|
||||
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth, ProtocolServer, ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (SMPVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Transport (SMPVersion, TLS, Transport (..))
|
||||
import Simplex.Messaging.Transport.Client (defaultSMPPort)
|
||||
import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
|
||||
import System.Mem.Weak (Weak)
|
||||
import System.Random (StdGen, newStdGen)
|
||||
import UnliftIO (Async, SomeException)
|
||||
import UnliftIO.STM
|
||||
|
||||
type AM' a = ReaderT Env IO a
|
||||
@@ -100,42 +93,29 @@ data InitialAgentServers = InitialAgentServers
|
||||
|
||||
data ServerCfg p = ServerCfg
|
||||
{ server :: ProtoServerWithAuth p,
|
||||
operator :: Maybe OperatorId,
|
||||
enabled :: Bool,
|
||||
roles :: ServerRoles
|
||||
preset :: Bool,
|
||||
tested :: Maybe Bool,
|
||||
enabled :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ServerRoles = ServerRoles
|
||||
{ storage :: Bool,
|
||||
proxy :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
enabledServerCfg :: ProtoServerWithAuth p -> ServerCfg p
|
||||
enabledServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True}
|
||||
|
||||
allRoles :: ServerRoles
|
||||
allRoles = ServerRoles True True
|
||||
|
||||
presetServerCfg :: Bool -> ServerRoles -> Maybe OperatorId -> ProtoServerWithAuth p -> ServerCfg p
|
||||
presetServerCfg enabled roles operator server =
|
||||
ServerCfg {server, operator, enabled, roles}
|
||||
presetServerCfg :: Bool -> ProtoServerWithAuth p -> ServerCfg p
|
||||
presetServerCfg enabled server = ServerCfg {server, preset = True, tested = Nothing, enabled}
|
||||
|
||||
data UserServers p = UserServers
|
||||
{ storageSrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
|
||||
proxySrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
|
||||
knownHosts :: Set TransportHost
|
||||
{ enabledSrvs :: NonEmpty (ProtoServerWithAuth p),
|
||||
knownSrvs :: NonEmpty (ProtocolServer p)
|
||||
}
|
||||
|
||||
type OperatorId = Int64
|
||||
|
||||
-- This function sets all servers as enabled in case all passed servers are disabled.
|
||||
mkUserServers :: NonEmpty (ServerCfg p) -> UserServers p
|
||||
mkUserServers srvs = UserServers {storageSrvs = filterSrvs storage, proxySrvs = filterSrvs proxy, knownHosts}
|
||||
mkUserServers srvs = UserServers {enabledSrvs, knownSrvs}
|
||||
where
|
||||
filterSrvs role = L.map (\ServerCfg {operator, server} -> (operator, server)) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled, roles} -> enabled && role roles) srvs
|
||||
knownHosts = S.unions $ L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> serverHosts srv) srvs
|
||||
|
||||
serverHosts :: ProtocolServer p -> Set TransportHost
|
||||
serverHosts ProtocolServer {host} = S.fromList $ L.toList host
|
||||
enabledSrvs = L.map (\ServerCfg {server} -> server) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled} -> enabled) srvs
|
||||
knownSrvs = L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> srv) srvs
|
||||
|
||||
data AgentConfig = AgentConfig
|
||||
{ tcpPort :: Maybe ServiceName,
|
||||
@@ -168,8 +148,6 @@ data AgentConfig = AgentConfig
|
||||
xftpMaxRecipientsPerRequest :: Int,
|
||||
deleteErrorCount :: Int,
|
||||
ntfCron :: Word16,
|
||||
ntfBatchSize :: Int,
|
||||
ntfSubFirstCheckInterval :: NominalDiffTime,
|
||||
ntfSubCheckInterval :: NominalDiffTime,
|
||||
caCertificateFile :: FilePath,
|
||||
privateKeyFile :: FilePath,
|
||||
@@ -213,9 +191,9 @@ defaultAgentConfig =
|
||||
rcvAuthAlg = C.AuthAlg C.SEd25519, -- this will stay as Ed25519
|
||||
sndAuthAlg = C.AuthAlg C.SEd25519, -- TODO replace with X25519 when switching to v7
|
||||
connIdBytes = 12,
|
||||
tbqSize = 128,
|
||||
smpCfg = defaultSMPClientConfig,
|
||||
ntfCfg = defaultNTFClientConfig,
|
||||
tbqSize = 64,
|
||||
smpCfg = defaultSMPClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
|
||||
ntfCfg = defaultNTFClientConfig {defaultTransport = ("443", transport @TLS)},
|
||||
xftpCfg = defaultXFTPClientConfig,
|
||||
reconnectInterval = defaultReconnectInterval,
|
||||
messageRetryInterval = defaultMessageRetryInterval,
|
||||
@@ -239,9 +217,7 @@ defaultAgentConfig =
|
||||
xftpMaxRecipientsPerRequest = 200,
|
||||
deleteErrorCount = 10,
|
||||
ntfCron = 20, -- minutes
|
||||
ntfBatchSize = 150,
|
||||
ntfSubFirstCheckInterval = nominalDay,
|
||||
ntfSubCheckInterval = 3 * nominalDay,
|
||||
ntfSubCheckInterval = nominalDay,
|
||||
-- CA certificate private key is not needed for initialization
|
||||
-- ! we do not generate these
|
||||
caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
|
||||
@@ -276,13 +252,12 @@ createAgentStore dbFilePath dbKey keepKey = createSQLiteStore dbFilePath dbKey k
|
||||
|
||||
data NtfSupervisor = NtfSupervisor
|
||||
{ ntfTkn :: TVar (Maybe NtfToken),
|
||||
ntfSubQ :: TBQueue (NtfSupervisorCommand, NonEmpty ConnId),
|
||||
ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),
|
||||
ntfWorkers :: TMap NtfServer Worker,
|
||||
ntfSMPWorkers :: TMap SMPServer Worker,
|
||||
ntfTknDelWorkers :: TMap NtfServer Worker
|
||||
ntfSMPWorkers :: TMap SMPServer Worker
|
||||
}
|
||||
|
||||
data NtfSupervisorCommand = NSCCreate | NSCSmpDelete | NSCDeleteSub
|
||||
data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
|
||||
deriving (Show)
|
||||
|
||||
newNtfSubSupervisor :: Natural -> IO NtfSupervisor
|
||||
@@ -291,8 +266,7 @@ newNtfSubSupervisor qSize = do
|
||||
ntfSubQ <- newTBQueueIO qSize
|
||||
ntfWorkers <- TM.emptyIO
|
||||
ntfSMPWorkers <- TM.emptyIO
|
||||
ntfTknDelWorkers <- TM.emptyIO
|
||||
pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers, ntfTknDelWorkers}
|
||||
pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
|
||||
|
||||
data XFTPAgent = XFTPAgent
|
||||
{ -- if set, XFTP file paths will be considered as relative to this directory
|
||||
@@ -332,15 +306,13 @@ agentFinally = allFinally mkInternal
|
||||
{-# INLINE agentFinally #-}
|
||||
|
||||
mkInternal :: SomeException -> AgentErrorType
|
||||
mkInternal e = case fromException e of
|
||||
Just BlockedIndefinitelyOnSTM -> CRITICAL True "Thread blocked indefinitely in STM transaction"
|
||||
_ -> INTERNAL $ show e
|
||||
mkInternal = INTERNAL . show
|
||||
{-# INLINE mkInternal #-}
|
||||
|
||||
data Worker = Worker
|
||||
{ workerId :: Int,
|
||||
doWork :: TMVar (),
|
||||
action :: TMVar (Maybe (Weak ThreadId)),
|
||||
action :: TMVar (Maybe (Async ())),
|
||||
restarts :: TVar RestartCount
|
||||
}
|
||||
|
||||
@@ -356,8 +328,6 @@ updateRestartCount t (RestartCount minute count) = do
|
||||
|
||||
$(pure [])
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''ServerRoles)
|
||||
|
||||
instance ProtocolTypeI p => ToJSON (ServerCfg p) where
|
||||
toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg)
|
||||
toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg)
|
||||
|
||||
@@ -1,7 +1,6 @@
|
||||
module Simplex.Messaging.Agent.Lock
|
||||
( Lock,
|
||||
createLock,
|
||||
createLockIO,
|
||||
withLock,
|
||||
withLock',
|
||||
withGetLock,
|
||||
@@ -25,10 +24,6 @@ createLock :: STM Lock
|
||||
createLock = newEmptyTMVar
|
||||
{-# INLINE createLock #-}
|
||||
|
||||
createLockIO :: IO Lock
|
||||
createLockIO = newEmptyTMVarIO
|
||||
{-# INLINE createLockIO #-}
|
||||
|
||||
withLock :: MonadUnliftIO m => Lock -> String -> ExceptT e m a -> ExceptT e m a
|
||||
withLock lock name = ExceptT . withLock' lock name . runExceptT
|
||||
{-# INLINE withLock #-}
|
||||
|
||||
@@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
@@ -15,7 +13,6 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
|
||||
nsRemoveNtfToken,
|
||||
sendNtfSubCommand,
|
||||
instantNotifications,
|
||||
deleteToken,
|
||||
closeNtfSupervisor,
|
||||
getNtfServer,
|
||||
)
|
||||
@@ -25,32 +22,23 @@ import Control.Logger.Simple (logError, logInfo)
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Either (fromRight, partitionEithers)
|
||||
import Data.Functor (($>))
|
||||
import Data.List (foldl')
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import Data.Time (UTCTime, addUTCTime, getCurrentTime)
|
||||
import Data.Time.Clock (diffUTCTime)
|
||||
import Simplex.Messaging.Agent.Client
|
||||
import Simplex.Messaging.Agent.Env.SQLite
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Protocol (AEvent (..), AEvt (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Agent.Stats
|
||||
import Simplex.Messaging.Agent.Store
|
||||
import Simplex.Messaging.Agent.Store.SQLite
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Protocol (NtfServer, sameSrvAddr)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow)
|
||||
import Simplex.Messaging.Protocol (NtfServer, SMPServer, sameSrvAddr)
|
||||
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, unlessM)
|
||||
import System.Random (randomR)
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent (forkIO)
|
||||
@@ -59,134 +47,91 @@ import qualified UnliftIO.Exception as E
|
||||
runNtfSupervisor :: AgentClient -> AM' ()
|
||||
runNtfSupervisor c = do
|
||||
ns <- asks ntfSupervisor
|
||||
runExceptT startTknDelete >>= \case
|
||||
Left e -> notifyErr e
|
||||
Right _ -> pure ()
|
||||
forever $ do
|
||||
cmd <- atomically . readTBQueue $ ntfSubQ ns
|
||||
handleErr . agentOperationBracket c AONtfNetwork waitUntilActive $
|
||||
runExceptT (processNtfCmd c cmd) >>= \case
|
||||
Left e -> notifyErr e
|
||||
cmd@(connId, _) <- atomically . readTBQueue $ ntfSubQ ns
|
||||
handleErr connId . agentOperationBracket c AONtfNetwork waitUntilActive $
|
||||
runExceptT (processNtfSub c cmd) >>= \case
|
||||
Left e -> notifyErr connId e
|
||||
Right _ -> return ()
|
||||
where
|
||||
startTknDelete :: AM ()
|
||||
startTknDelete = do
|
||||
pendingDelServers <- withStore' c getPendingDelTknServers
|
||||
lift . forM_ pendingDelServers $ getNtfTknDelWorker True c
|
||||
handleErr :: AM' () -> AM' ()
|
||||
handleErr = E.handle $ \(e :: E.SomeException) -> do
|
||||
handleErr :: ConnId -> AM' () -> AM' ()
|
||||
handleErr connId = E.handle $ \(e :: E.SomeException) -> do
|
||||
logError $ "runNtfSupervisor error " <> tshow e
|
||||
notifyErr e
|
||||
notifyErr e = notifyInternalError' c $ "runNtfSupervisor error " <> show e
|
||||
notifyErr connId e
|
||||
notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e
|
||||
|
||||
partitionErrs :: (a -> ConnId) -> [a] -> [Either AgentErrorType b] -> ([(ConnId, AgentErrorType)], [b])
|
||||
partitionErrs f xs = partitionEithers . zipWith (\x -> first (f x,)) xs
|
||||
{-# INLINE partitionErrs #-}
|
||||
|
||||
ntfSubConnId :: NtfSubscription -> ConnId
|
||||
ntfSubConnId NtfSubscription {connId} = connId
|
||||
|
||||
processNtfCmd :: AgentClient -> (NtfSupervisorCommand, NonEmpty ConnId) -> AM ()
|
||||
processNtfCmd c (cmd, connIds) = do
|
||||
logInfo $ "processNtfCmd - cmd = " <> tshow cmd
|
||||
let connIds' = L.toList connIds
|
||||
processNtfSub :: AgentClient -> (ConnId, NtfSupervisorCommand) -> AM ()
|
||||
processNtfSub c (connId, cmd) = do
|
||||
logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
|
||||
case cmd of
|
||||
NSCCreate -> do
|
||||
(cErrs, rqSubActions) <- lift $ partitionErrs id connIds' <$> withStoreBatch c (\db -> map (getQueueSub db) connIds')
|
||||
notifyErrs c cErrs
|
||||
logInfo $ "processNtfCmd, NSCCreate - length rqSubs = " <> tshow (length rqSubActions)
|
||||
let (ns, rs, css, cns) = partitionQueueSubActions rqSubActions
|
||||
createNewSubs ns
|
||||
resetSubs rs
|
||||
lift $ do
|
||||
mapM_ (getNtfSMPWorker True c) (S.fromList css)
|
||||
mapM_ (getNtfNTFWorker True c) (S.fromList cns)
|
||||
where
|
||||
getQueueSub ::
|
||||
DB.Connection ->
|
||||
ConnId ->
|
||||
IO (Either AgentErrorType (RcvQueue, Maybe NtfSupervisorSub))
|
||||
getQueueSub db connId = fmap (first storeError) $ runExceptT $ do
|
||||
rq <- ExceptT $ getPrimaryRcvQueue db connId
|
||||
sub <- liftIO $ getNtfSubscription db connId
|
||||
pure (rq, sub)
|
||||
createNewSubs :: [RcvQueue] -> AM ()
|
||||
createNewSubs rqs = do
|
||||
(a, RcvQueue {userId, server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
|
||||
a <- liftIO $ getNtfSubscription db connId
|
||||
q <- ExceptT $ getPrimaryRcvQueue db connId
|
||||
pure (a, q)
|
||||
logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
|
||||
case a of
|
||||
Nothing -> do
|
||||
withTokenServer $ \ntfServer -> do
|
||||
let newSubs = map (rqToNewSub ntfServer) rqs
|
||||
(cErrs, _) <- lift $ partitionErrs ntfSubConnId newSubs <$> withStoreBatch c (\db -> map (storeNewSub db) newSubs)
|
||||
notifyErrs c cErrs
|
||||
kickSMPWorkers rqs
|
||||
case clientNtfCreds of
|
||||
Just ClientNtfCreds {notifierId} -> do
|
||||
let newSub = newNtfSubscription userId connId smpServer (Just notifierId) ntfServer NASKey
|
||||
withStore c $ \db -> createNtfSubscription db newSub $ NSANtf NSACreate
|
||||
lift . void $ getNtfNTFWorker True c ntfServer
|
||||
Nothing -> do
|
||||
let newSub = newNtfSubscription userId connId smpServer Nothing ntfServer NASNew
|
||||
withStore c $ \db -> createNtfSubscription db newSub $ NSASMP NSASmpKey
|
||||
lift . void $ getNtfSMPWorker True c smpServer
|
||||
(Just (sub@NtfSubscription {ntfSubStatus, ntfServer = subNtfServer, smpServer = smpServer', ntfQueueId}, action_)) -> do
|
||||
case (clientNtfCreds, ntfQueueId) of
|
||||
(Just ClientNtfCreds {notifierId}, Just ntfQueueId')
|
||||
| sameSrvAddr smpServer smpServer' && notifierId == ntfQueueId' -> create
|
||||
| otherwise -> rotate
|
||||
(Nothing, Nothing) -> create
|
||||
_ -> rotate
|
||||
where
|
||||
rqToNewSub :: NtfServer -> RcvQueue -> NtfSubscription
|
||||
rqToNewSub ntfServer RcvQueue {userId, connId, server} = newNtfSubscription userId connId server Nothing ntfServer NASNew
|
||||
storeNewSub :: DB.Connection -> NtfSubscription -> IO (Either AgentErrorType ())
|
||||
storeNewSub db sub = first storeError <$> createNtfSubscription db sub (NSASMP NSASmpKey)
|
||||
resetSubs :: [(RcvQueue, NtfSubscription)] -> AM ()
|
||||
resetSubs rqSubs = do
|
||||
withTokenServer $ \ntfServer -> do
|
||||
let subsToReset = map (toResetSub ntfServer) rqSubs
|
||||
(cErrs, _) <- lift $ partitionErrs ntfSubConnId subsToReset <$> withStoreBatch' c (\db -> map (storeResetSub db) subsToReset)
|
||||
notifyErrs c cErrs
|
||||
let rqs = map fst rqSubs
|
||||
kickSMPWorkers rqs
|
||||
where
|
||||
toResetSub :: NtfServer -> (RcvQueue, NtfSubscription) -> NtfSubscription
|
||||
toResetSub ntfServer (rq, sub) =
|
||||
let RcvQueue {server = smpServer} = rq
|
||||
in sub {smpServer, ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
|
||||
storeResetSub :: DB.Connection -> NtfSubscription -> IO ()
|
||||
storeResetSub db sub = supervisorUpdateNtfSub db sub (NSASMP NSASmpKey)
|
||||
partitionQueueSubActions ::
|
||||
[(RcvQueue, Maybe NtfSupervisorSub)] ->
|
||||
( [RcvQueue], -- new subs
|
||||
[(RcvQueue, NtfSubscription)], -- reset subs
|
||||
[SMPServer], -- continue work (SMP)
|
||||
[NtfServer] -- continue work (Ntf)
|
||||
)
|
||||
partitionQueueSubActions = foldr decideSubWork ([], [], [], [])
|
||||
where
|
||||
-- sub = Nothing, needs to be created
|
||||
decideSubWork (rq, Nothing) (ns, rs, css, cns) = (rq : ns, rs, css, cns)
|
||||
decideSubWork (rq, Just (sub, subAction_)) (ns, rs, css, cns) =
|
||||
case (clientNtfCreds rq, ntfQueueId sub) of
|
||||
-- notifier ID created on SMP server (on ntf server subscription can be registered or not yet),
|
||||
-- need to clarify action
|
||||
(Just ClientNtfCreds {notifierId}, Just ntfQueueId')
|
||||
| sameSrvAddr (qServer rq) subSMPServer && notifierId == ntfQueueId' -> contOrReset
|
||||
| otherwise -> reset
|
||||
(Nothing, Nothing) -> contOrReset
|
||||
_ -> reset
|
||||
where
|
||||
NtfSubscription {ntfServer = subNtfServer, smpServer = subSMPServer} = sub
|
||||
contOrReset = case subAction_ of
|
||||
-- action was set to NULL after worker internal error
|
||||
Nothing -> reset
|
||||
Just (action, _)
|
||||
-- subscription was marked for deletion / is being deleted
|
||||
| isDeleteNtfSubAction action -> reset
|
||||
-- continue work on subscription (e.g. supervisor was repeatedly tasked with creating a subscription)
|
||||
| otherwise -> case action of
|
||||
NSASMP _ -> (ns, rs, qServer rq : css, cns)
|
||||
NSANtf _ -> (ns, rs, css, subNtfServer : cns)
|
||||
reset = (ns, (rq, sub) : rs, css, cns)
|
||||
create :: AM ()
|
||||
create = case action_ of
|
||||
-- action was set to NULL after worker internal error
|
||||
Nothing -> resetSubscription
|
||||
Just (action, _)
|
||||
-- subscription was marked for deletion / is being deleted
|
||||
| isDeleteNtfSubAction action -> do
|
||||
if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
|
||||
then resetSubscription
|
||||
else withTokenServer $ \ntfServer -> do
|
||||
withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NSANtf NSACreate)
|
||||
lift . void $ getNtfNTFWorker True c ntfServer
|
||||
| otherwise -> case action of
|
||||
NSANtf _ -> lift . void $ getNtfNTFWorker True c subNtfServer
|
||||
NSASMP _ -> lift . void $ getNtfSMPWorker True c smpServer
|
||||
rotate :: AM ()
|
||||
rotate = do
|
||||
withStore' c $ \db -> supervisorUpdateNtfSub db sub (NSANtf NSARotate)
|
||||
lift . void $ getNtfNTFWorker True c subNtfServer
|
||||
resetSubscription :: AM ()
|
||||
resetSubscription =
|
||||
withTokenServer $ \ntfServer -> do
|
||||
let sub' = sub {ntfQueueId = Nothing, ntfServer, ntfSubId = Nothing, ntfSubStatus = NASNew}
|
||||
withStore' c $ \db -> supervisorUpdateNtfSub db sub' (NSASMP NSASmpKey)
|
||||
lift . void $ getNtfSMPWorker True c smpServer
|
||||
NSCDelete -> do
|
||||
sub_ <- withStore' c $ \db -> do
|
||||
supervisorUpdateNtfAction db connId (NSANtf NSADelete)
|
||||
getNtfSubscription db connId
|
||||
logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
|
||||
case sub_ of
|
||||
(Just (NtfSubscription {ntfServer}, _)) -> lift . void $ getNtfNTFWorker True c ntfServer
|
||||
_ -> pure () -- err "NSCDelete - no subscription"
|
||||
NSCSmpDelete -> do
|
||||
(cErrs, rqs) <- lift $ partitionErrs id connIds' <$> withStoreBatch c (\db -> map (getQueue db) connIds')
|
||||
logInfo $ "processNtfCmd, NSCSmpDelete - length rqs = " <> tshow (length rqs)
|
||||
(cErrs', _) <- lift $ partitionErrs qConnId rqs <$> withStoreBatch' c (\db -> map (updateAction db) rqs)
|
||||
notifyErrs c (cErrs <> cErrs')
|
||||
kickSMPWorkers rqs
|
||||
where
|
||||
getQueue :: DB.Connection -> ConnId -> IO (Either AgentErrorType RcvQueue)
|
||||
getQueue db connId = first storeError <$> getPrimaryRcvQueue db connId
|
||||
updateAction :: DB.Connection -> RcvQueue -> IO ()
|
||||
updateAction db rq = supervisorUpdateNtfAction db (qConnId rq) (NSASMP NSASmpDelete)
|
||||
NSCDeleteSub -> void $ lift $ withStoreBatch' c $ \db -> map (deleteNtfSubscription' db) connIds'
|
||||
where
|
||||
kickSMPWorkers :: [RcvQueue] -> AM ()
|
||||
kickSMPWorkers rqs = do
|
||||
let smpServers = S.fromList $ map qServer rqs
|
||||
lift $ mapM_ (getNtfSMPWorker True c) smpServers
|
||||
withStore' c (`getPrimaryRcvQueue` connId) >>= \case
|
||||
Right rq@RcvQueue {server = smpServer} -> do
|
||||
logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
|
||||
withStore' c $ \db -> supervisorUpdateNtfAction db connId (NSASMP NSASmpDelete)
|
||||
lift . void $ getNtfSMPWorker True c smpServer
|
||||
_ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
|
||||
NSCNtfWorker ntfServer -> lift . void $ getNtfNTFWorker True c ntfServer
|
||||
NSCNtfSMPWorker smpServer -> lift . void $ getNtfSMPWorker True c smpServer
|
||||
|
||||
getNtfNTFWorker :: Bool -> AgentClient -> NtfServer -> AM' Worker
|
||||
getNtfNTFWorker hasWork c server = do
|
||||
@@ -198,11 +143,6 @@ getNtfSMPWorker hasWork c server = do
|
||||
ws <- asks $ ntfSMPWorkers . ntfSupervisor
|
||||
getAgentWorker "ntf_smp" hasWork c server ws $ runNtfSMPWorker c server
|
||||
|
||||
getNtfTknDelWorker :: Bool -> AgentClient -> NtfServer -> AM' Worker
|
||||
getNtfTknDelWorker hasWork c server = do
|
||||
ws <- asks $ ntfTknDelWorkers . ntfSupervisor
|
||||
getAgentWorker "ntf_tkn_del" hasWork c server ws $ runNtfTknDelWorker c server
|
||||
|
||||
withTokenServer :: (NtfServer -> AM ()) -> AM ()
|
||||
withTokenServer action = lift getNtfToken >>= mapM_ (\NtfToken {ntfServer} -> action ntfServer)
|
||||
|
||||
@@ -213,288 +153,153 @@ runNtfWorker c srv Worker {doWork} =
|
||||
ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfOperation
|
||||
where
|
||||
runNtfOperation :: AM ()
|
||||
runNtfOperation = do
|
||||
ntfBatchSize <- asks $ ntfBatchSize . config
|
||||
withWorkItems c doWork (\db -> getNextNtfSubNTFActions db srv ntfBatchSize) $ \nextSubs -> do
|
||||
logInfo $ "runNtfWorker - length nextSubs = " <> tshow (length nextSubs)
|
||||
currTs <- liftIO getCurrentTime
|
||||
let (creates, checks, deletes, rotates) = splitActions currTs nextSubs
|
||||
if null creates && null checks && null deletes && null rotates
|
||||
then
|
||||
let (_, _, firstActionTs) = L.head nextSubs
|
||||
in lift $ rescheduleWork doWork currTs firstActionTs
|
||||
else do
|
||||
retrySubActions c creates createSubs
|
||||
retrySubActions c checks checkSubs
|
||||
retrySubActions c deletes deleteSubs
|
||||
retrySubActions c rotates rotateSubs
|
||||
splitActions :: UTCTime -> NonEmpty (NtfSubNTFAction, NtfSubscription, NtfActionTs) -> ([NtfSubscription], [NtfSubscription], [NtfSubscription], [NtfSubscription])
|
||||
splitActions currTs = foldr addAction ([], [], [], [])
|
||||
runNtfOperation =
|
||||
withWork c doWork (`getNextNtfSubNTFAction` srv) $
|
||||
\nextSub@(NtfSubscription {connId}, _, _) -> do
|
||||
logInfo $ "runNtfWorker, nextSub " <> tshow nextSub
|
||||
ri <- asks $ reconnectInterval . config
|
||||
withRetryInterval ri $ \_ loop -> do
|
||||
liftIO $ waitWhileSuspended c
|
||||
liftIO $ waitForUserNetwork c
|
||||
processSub nextSub
|
||||
`catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
|
||||
processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> AM ()
|
||||
processSub (sub@NtfSubscription {userId, connId, smpServer, ntfSubId}, action, actionTs) = do
|
||||
ts <- liftIO getCurrentTime
|
||||
unlessM (lift $ rescheduleAction doWork ts actionTs) $
|
||||
case action of
|
||||
NSACreate ->
|
||||
lift getNtfToken >>= \case
|
||||
Just tkn@NtfToken {ntfServer, ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
|
||||
RcvQueue {clientNtfCreds} <- withStore c (`getPrimaryRcvQueue` connId)
|
||||
case clientNtfCreds of
|
||||
Just ClientNtfCreds {ntfPrivateKey, notifierId} -> do
|
||||
atomically $ incNtfServerStat c userId ntfServer ntfCreateAttempts
|
||||
nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer notifierId) ntfPrivateKey
|
||||
atomically $ incNtfServerStat c userId ntfServer ntfCreated
|
||||
-- possible improvement: smaller retry until Active, less frequently (daily?) once Active
|
||||
let actionTs' = addUTCTime 30 ts
|
||||
withStore' c $ \db ->
|
||||
updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NSANtf NSACheck) actionTs'
|
||||
_ -> workerInternalError c connId "NSACreate - no notifier queue credentials"
|
||||
_ -> workerInternalError c connId "NSACreate - no active token"
|
||||
NSACheck ->
|
||||
lift getNtfToken >>= \case
|
||||
Just tkn@NtfToken {ntfServer} ->
|
||||
case ntfSubId of
|
||||
Just nSubId -> do
|
||||
atomically $ incNtfServerStat c userId ntfServer ntfCheckAttempts
|
||||
agentNtfCheckSubscription c nSubId tkn >>= \case
|
||||
NSAuth -> do
|
||||
withStore' c $ \db ->
|
||||
updateNtfSubscription db sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew} (NSASMP NSASmpKey) ts
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
|
||||
status -> updateSubNextCheck ts status
|
||||
atomically $ incNtfServerStat c userId ntfServer ntfChecked
|
||||
Nothing -> workerInternalError c connId "NSACheck - no subscription ID"
|
||||
_ -> workerInternalError c connId "NSACheck - no active token"
|
||||
NSADelete ->
|
||||
deleteNtfSub $ do
|
||||
let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
|
||||
withStore' c $ \db -> updateNtfSubscription db sub' (NSASMP NSASmpDelete) ts
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCNtfSMPWorker smpServer)
|
||||
NSARotate ->
|
||||
deleteNtfSub $ do
|
||||
withStore' c $ \db -> deleteNtfSubscription db connId
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ writeTBQueue (ntfSubQ ns) (connId, NSCCreate)
|
||||
where
|
||||
addAction (cmd, sub, ts) acc@(creates, checks, deletes, rotates) = case cmd of
|
||||
NSACreate -> (sub : creates, checks, deletes, rotates)
|
||||
NSACheck
|
||||
| ts <= currTs -> (creates, sub : checks, deletes, rotates)
|
||||
| otherwise -> acc
|
||||
NSADelete -> (creates, checks, sub : deletes, rotates)
|
||||
NSARotate -> (creates, checks, deletes, sub : rotates)
|
||||
createSubs :: [NtfSubscription] -> AM' [NtfSubscription]
|
||||
createSubs ntfSubs =
|
||||
getNtfToken >>= \case
|
||||
Just tkn@NtfToken {ntfServer, ntfTokenId = Just tknId, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
|
||||
subsRqs_ <- zip ntfSubs <$> withStoreBatch c (\db -> map (getQueue db) ntfSubs)
|
||||
let (errs1, subs_, newSubs_) = splitSubs tknId subsRqs_
|
||||
incStatByUserId ntfServer ntfCreateAttempts subs_
|
||||
case (L.nonEmpty subs_, L.nonEmpty newSubs_) of
|
||||
(Just subs, Just newSubs) -> do
|
||||
rs <- L.zip subs <$> agentNtfCreateSubscriptions c tkn newSubs
|
||||
let (ntfSubs', errs2, nSubIds) = splitResults $ L.toList rs
|
||||
subs' = map fst nSubIds
|
||||
errs2' = map (first ntfSubConnId) errs2
|
||||
incStatByUserId ntfServer ntfCreated subs'
|
||||
ts <- liftIO getCurrentTime
|
||||
int <- asks $ ntfSubFirstCheckInterval . config
|
||||
let checkTs = addUTCTime int ts
|
||||
(errs3, _) <- partitionErrs ntfSubConnId subs' <$> withStoreBatch' c (\db -> map (updateSubNSACheck db checkTs) nSubIds)
|
||||
workerErrors c $ errs1 <> errs2' <> errs3
|
||||
pure ntfSubs'
|
||||
_ -> workerErrors c errs1 $> []
|
||||
_ -> do
|
||||
let errs = map (\sub -> (ntfSubConnId sub, INTERNAL "NSACreate - no active token")) ntfSubs
|
||||
workerErrors c errs
|
||||
pure []
|
||||
where
|
||||
getQueue :: DB.Connection -> NtfSubscription -> IO (Either AgentErrorType RcvQueue)
|
||||
getQueue db NtfSubscription {connId} = first storeError <$> getPrimaryRcvQueue db connId
|
||||
splitSubs :: NtfTokenId -> [(NtfSubscription, Either AgentErrorType RcvQueue)] -> ([(ConnId, AgentErrorType)], [NtfSubscription], [NewNtfEntity 'Subscription])
|
||||
splitSubs tknId = foldr splitSub ([], [], [])
|
||||
where
|
||||
splitSub (sub, rq) (errs, subs, newSubs) = case rq of
|
||||
Right RcvQueue {clientNtfCreds = Just creds} -> (errs, sub : subs, toNewSub sub creds : newSubs)
|
||||
Right _ -> ((ntfSubConnId sub, INTERNAL "NSACreate - no notifier queue credentials") : errs, subs, newSubs)
|
||||
Left e -> ((ntfSubConnId sub, e) : errs, subs, newSubs)
|
||||
toNewSub NtfSubscription {smpServer} ClientNtfCreds {ntfPrivateKey, notifierId} =
|
||||
NewNtfSub tknId (SMPQueueNtf smpServer notifierId) ntfPrivateKey
|
||||
updateSubNSACheck :: DB.Connection -> UTCTime -> (NtfSubscription, NtfSubscriptionId) -> IO ()
|
||||
updateSubNSACheck db checkTs (sub, nSubId) = updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NSANtf NSACheck) checkTs
|
||||
checkSubs :: [NtfSubscription] -> AM' [NtfSubscription]
|
||||
checkSubs ntfSubs =
|
||||
getNtfToken >>= \case
|
||||
Just tkn@NtfToken {ntfServer, ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
|
||||
let (errs1, subs_, subIds_) = splitSubs ntfSubs
|
||||
incStatByUserId ntfServer ntfCheckAttempts subs_
|
||||
case (L.nonEmpty subs_, L.nonEmpty subIds_) of
|
||||
(Just subs, Just subIds) -> do
|
||||
rs <- L.zip subs <$> agentNtfCheckSubscriptions c tkn subIds
|
||||
let (ntfSubs', errs2, nSubStatuses) = splitResults $ L.toList rs
|
||||
subs' = map fst nSubStatuses
|
||||
(errs2', authSubs) = partitionEithers $ map (\case (sub, NTF _ SMP.AUTH) -> Right sub; e -> Left $ first ntfSubConnId e) errs2
|
||||
incStatByUserId ntfServer ntfChecked subs'
|
||||
ts <- liftIO getCurrentTime
|
||||
int <- asks $ ntfSubCheckInterval . config
|
||||
let nextCheckTs = addUTCTime int ts
|
||||
(errs3, srvs) <- partitionErrs ntfSubConnId subs' <$> withStoreBatch' c (\db -> map (updateSub db ntfServer ts nextCheckTs) nSubStatuses)
|
||||
(errs4, srvs') <- partitionErrs ntfSubConnId authSubs <$> withStoreBatch' c (\db -> map (recreateNtfSub db ntfServer ts) authSubs)
|
||||
mapM_ (getNtfSMPWorker True c) $ S.fromList (catMaybes srvs <> srvs')
|
||||
workerErrors c $ errs1 <> errs2' <> errs3 <> errs4
|
||||
pure ntfSubs'
|
||||
_ -> workerErrors c errs1 $> []
|
||||
_ -> do
|
||||
let errs = map (\sub -> (ntfSubConnId sub, INTERNAL "NSACheck - no active token")) ntfSubs
|
||||
workerErrors c errs
|
||||
pure []
|
||||
where
|
||||
splitSubs :: [NtfSubscription] -> ([(ConnId, AgentErrorType)], [NtfSubscription], [NtfSubscriptionId])
|
||||
splitSubs = foldr splitSub ([], [], [])
|
||||
where
|
||||
splitSub sub (errs, subs, subIds) = case sub of
|
||||
NtfSubscription {ntfSubId = Just subId} -> (errs, sub : subs, subId : subIds)
|
||||
_ -> ((ntfSubConnId sub, INTERNAL "NSACheck - no subscription ID") : errs, subs, subIds)
|
||||
updateSub :: DB.Connection -> NtfServer -> UTCTime -> UTCTime -> (NtfSubscription, NtfSubStatus) -> IO (Maybe SMPServer)
|
||||
updateSub db ntfServer ts nextCheckTs (sub, status)
|
||||
| ntfShouldSubscribe status =
|
||||
let sub' = sub {ntfSubStatus = NASCreated status}
|
||||
in Nothing <$ updateNtfSubscription db sub' (NSANtf NSACheck) nextCheckTs
|
||||
-- ntf server stopped subscribing to this queue
|
||||
| otherwise = Just <$> recreateNtfSub db ntfServer ts sub
|
||||
recreateNtfSub :: DB.Connection -> NtfServer -> UTCTime -> NtfSubscription -> IO SMPServer
|
||||
recreateNtfSub db ntfServer ts sub@NtfSubscription {smpServer} =
|
||||
let sub' = sub {ntfServer, ntfQueueId = Nothing, ntfSubId = Nothing, ntfSubStatus = NASNew}
|
||||
in smpServer <$ updateNtfSubscription db sub' (NSASMP NSASmpKey) ts
|
||||
incStatByUserId :: NtfServer -> (AgentNtfServerStats -> TVar Int) -> [NtfSubscription] -> AM' ()
|
||||
incStatByUserId ntfServer sel ss =
|
||||
forM_ (M.assocs userIdsCounts) $ \(userId, count) ->
|
||||
atomically $ incNtfServerStat' c userId ntfServer sel count
|
||||
where
|
||||
userIdsCounts = foldl' (\acc NtfSubscription {userId} -> M.insertWith (+) userId 1 acc) M.empty ss
|
||||
-- NSADelete and NSARotate are deprecated, but their processing is kept for legacy db records;
|
||||
-- These actions are not batched
|
||||
deleteSubs :: [NtfSubscription] -> AM' [NtfSubscription]
|
||||
deleteSubs ntfSubs = do
|
||||
retrySubs_ <- mapM (runCatching deleteSub) ntfSubs
|
||||
pure $ catMaybes retrySubs_
|
||||
where
|
||||
deleteSub :: NtfSubscription -> AM (Maybe NtfSubscription)
|
||||
deleteSub sub@NtfSubscription {smpServer} =
|
||||
deleteNtfSub sub $ do
|
||||
let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
|
||||
ts <- liftIO getCurrentTime
|
||||
withStore' c $ \db -> updateNtfSubscription db sub' (NSASMP NSASmpDelete) ts
|
||||
lift . void $ getNtfSMPWorker True c smpServer
|
||||
rotateSubs :: [NtfSubscription] -> AM' [NtfSubscription]
|
||||
rotateSubs ntfSubs = do
|
||||
retrySubs_ <- mapM (runCatching rotateSub) ntfSubs
|
||||
pure $ catMaybes retrySubs_
|
||||
where
|
||||
rotateSub :: NtfSubscription -> AM (Maybe NtfSubscription)
|
||||
rotateSub sub@NtfSubscription {connId} =
|
||||
deleteNtfSub sub $ do
|
||||
withStore' c $ \db -> deleteNtfSubscription db connId
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ writeTBQueue (ntfSubQ ns) (NSCCreate, [connId])
|
||||
runCatching :: (NtfSubscription -> AM (Maybe NtfSubscription)) -> NtfSubscription -> AM' (Maybe NtfSubscription)
|
||||
runCatching action sub@NtfSubscription {connId} =
|
||||
fromRight Nothing
|
||||
<$> runExceptT (action sub `catchAgentError` \e -> workerInternalError c connId (show e) $> Nothing)
|
||||
-- deleteNtfSub is only used in NSADelete and NSARotate, so also deprecated
|
||||
deleteNtfSub :: NtfSubscription -> AM () -> AM (Maybe NtfSubscription)
|
||||
deleteNtfSub sub@NtfSubscription {userId, ntfSubId} continue = case ntfSubId of
|
||||
Just nSubId ->
|
||||
lift getNtfToken >>= \case
|
||||
Just tkn@NtfToken {ntfServer} -> do
|
||||
atomically $ incNtfServerStat c userId ntfServer ntfDelAttempts
|
||||
tryAgentError (agentNtfDeleteSubscription c nSubId tkn) >>= \case
|
||||
Right _ -> do
|
||||
deleteNtfSub continue = case ntfSubId of
|
||||
Just nSubId ->
|
||||
lift getNtfToken >>= \case
|
||||
Just tkn@NtfToken {ntfServer} -> do
|
||||
atomically $ incNtfServerStat c userId ntfServer ntfDelAttempts
|
||||
tryAgentError (agentNtfDeleteSubscription c nSubId tkn) >>= \case
|
||||
Left e | temporaryOrHostError e -> throwE e
|
||||
_ -> continue
|
||||
atomically $ incNtfServerStat c userId ntfServer ntfDeleted
|
||||
continue'
|
||||
Left e
|
||||
| temporaryOrHostError e -> pure $ Just sub -- don't continue, retry
|
||||
| otherwise -> continue'
|
||||
Nothing -> continue'
|
||||
_ -> continue'
|
||||
where
|
||||
continue' = continue $> Nothing -- continue without retry
|
||||
Nothing -> continue
|
||||
_ -> continue
|
||||
updateSubNextCheck ts toStatus = do
|
||||
checkInterval <- asks $ ntfSubCheckInterval . config
|
||||
let nextCheckTs = addUTCTime checkInterval ts
|
||||
updateSub (NASCreated toStatus) (NSANtf NSACheck) nextCheckTs
|
||||
updateSub toStatus toAction actionTs' =
|
||||
withStore' c $ \db ->
|
||||
updateNtfSubscription db sub {ntfSubStatus = toStatus} toAction actionTs'
|
||||
|
||||
runNtfSMPWorker :: AgentClient -> SMPServer -> Worker -> AM ()
|
||||
runNtfSMPWorker c srv Worker {doWork} = forever $ do
|
||||
waitForWork doWork
|
||||
ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfSMPOperation
|
||||
runNtfSMPWorker c srv Worker {doWork} = do
|
||||
env <- ask
|
||||
forever $ do
|
||||
waitForWork doWork
|
||||
ExceptT . liftIO . agentOperationBracket c AONtfNetwork throwWhenInactive $
|
||||
runReaderT (runExceptT runNtfSMPOperation) env
|
||||
where
|
||||
runNtfSMPOperation :: AM ()
|
||||
runNtfSMPOperation = do
|
||||
ntfBatchSize <- asks $ ntfBatchSize . config
|
||||
withWorkItems c doWork (\db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
|
||||
logInfo $ "runNtfSMPWorker - length nextSubs = " <> tshow (length nextSubs)
|
||||
let (creates, deletes) = splitActions nextSubs
|
||||
retrySubActions c creates createNotifierKeys
|
||||
retrySubActions c deletes deleteNotifierKeys
|
||||
splitActions :: NonEmpty (NtfSubSMPAction, NtfSubscription) -> ([NtfSubscription], [NtfSubscription])
|
||||
splitActions = foldr addAction ([], [])
|
||||
where
|
||||
addAction (cmd, sub) (creates, deletes) = case cmd of
|
||||
NSASmpKey -> (sub : creates, deletes)
|
||||
NSASmpDelete -> (creates, sub : deletes)
|
||||
createNotifierKeys :: [NtfSubscription] -> AM' [NtfSubscription]
|
||||
createNotifierKeys ntfSubs =
|
||||
getNtfToken >>= \case
|
||||
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
|
||||
(errs1, subRqKeys) <- prepareQueueSmpKey ntfSubs
|
||||
rs <- enableQueuesNtfs c subRqKeys
|
||||
let (subRqKeys', errs2, successes) = splitResults rs
|
||||
ntfSubs' = map eqnrNtfSub subRqKeys'
|
||||
errs2' = map (first (qConnId . eqnrRq)) errs2
|
||||
ts <- liftIO getCurrentTime
|
||||
(errs3, srvs) <- partitionErrs (qConnId . eqnrRq . fst) successes <$> withStoreBatch' c (\db -> map (storeNtfSubCreds db ts) successes)
|
||||
mapM_ (getNtfNTFWorker True c) $ S.fromList srvs
|
||||
workerErrors c $ errs1 <> errs2' <> errs3
|
||||
pure ntfSubs'
|
||||
_ -> do
|
||||
let errs = map (\sub -> (ntfSubConnId sub, INTERNAL "NSASmpKey - no active token")) ntfSubs
|
||||
workerErrors c errs
|
||||
pure []
|
||||
where
|
||||
prepareQueueSmpKey :: [NtfSubscription] -> AM' ([(ConnId, AgentErrorType)], [EnableQueueNtfReq])
|
||||
prepareQueueSmpKey subs = do
|
||||
alg <- asks (rcvAuthAlg . config)
|
||||
g <- asks random
|
||||
partitionErrs ntfSubConnId subs <$> withStoreBatch c (\db -> map (getQueue db alg g) subs)
|
||||
where
|
||||
getQueue :: DB.Connection -> C.AuthAlg -> TVar ChaChaDRG -> NtfSubscription -> IO (Either AgentErrorType EnableQueueNtfReq)
|
||||
getQueue db (C.AuthAlg a) g sub = fmap (first storeError) $ runExceptT $ do
|
||||
rq <- ExceptT $ getPrimaryRcvQueue db (ntfSubConnId sub)
|
||||
authKeyPair <- atomically $ C.generateAuthKeyPair a g
|
||||
rcvNtfKeyPair <- atomically $ C.generateKeyPair g
|
||||
pure (EnableQueueNtfReq sub rq authKeyPair rcvNtfKeyPair)
|
||||
storeNtfSubCreds :: DB.Connection -> UTCTime -> (EnableQueueNtfReq, (SMP.NotifierId, SMP.RcvNtfPublicDhKey)) -> IO NtfServer
|
||||
storeNtfSubCreds db ts (EnableQueueNtfReq {eqnrNtfSub, eqnrAuthKeyPair = (ntfPublicKey, ntfPrivateKey), eqnrRcvKeyPair = (_, pk)}, (notifierId, srvPubDhKey)) = do
|
||||
let NtfSubscription {ntfServer} = eqnrNtfSub
|
||||
rcvNtfDhSecret = C.dh' srvPubDhKey pk
|
||||
setRcvQueueNtfCreds db (ntfSubConnId eqnrNtfSub) $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
|
||||
updateNtfSubscription db eqnrNtfSub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NSANtf NSACreate) ts
|
||||
pure ntfServer
|
||||
deleteNotifierKeys :: [NtfSubscription] -> AM' [NtfSubscription]
|
||||
deleteNotifierKeys ntfSubs = do
|
||||
(errs1, subRqs) <- partitionErrs ntfSubConnId ntfSubs <$> withStoreBatch c (\db -> map (resetCredsGetQueue db) ntfSubs)
|
||||
rs <- disableQueuesNtfs c subRqs
|
||||
let (subRqs', errs2, successes) = splitResults rs
|
||||
ntfSubs' = map fst subRqs'
|
||||
errs2' = map (first (qConnId . snd)) errs2
|
||||
disabledRqs = map (snd . fst) successes
|
||||
(errs3, _) <- partitionErrs qConnId disabledRqs <$> withStoreBatch' c (\db -> map (deleteSub db) disabledRqs)
|
||||
workerErrors c $ errs1 <> errs2' <> errs3
|
||||
pure ntfSubs'
|
||||
where
|
||||
resetCredsGetQueue :: DB.Connection -> NtfSubscription -> IO (Either AgentErrorType DisableQueueNtfReq)
|
||||
resetCredsGetQueue db sub@NtfSubscription {connId} = fmap (first storeError) $ runExceptT $ do
|
||||
liftIO $ setRcvQueueNtfCreds db connId Nothing
|
||||
rq <- ExceptT $ getPrimaryRcvQueue db connId
|
||||
pure (sub, rq)
|
||||
deleteSub :: DB.Connection -> RcvQueue -> IO ()
|
||||
deleteSub db rq = deleteNtfSubscription db (qConnId rq)
|
||||
runNtfSMPOperation =
|
||||
withWork c doWork (`getNextNtfSubSMPAction` srv) $
|
||||
\nextSub@(NtfSubscription {connId}, _, _) -> do
|
||||
logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
|
||||
ri <- asks $ reconnectInterval . config
|
||||
withRetryInterval ri $ \_ loop -> do
|
||||
liftIO $ waitWhileSuspended c
|
||||
liftIO $ waitForUserNetwork c
|
||||
processSub nextSub
|
||||
`catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
|
||||
processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> AM ()
|
||||
processSub (sub@NtfSubscription {connId, ntfServer}, smpAction, actionTs) = do
|
||||
ts <- liftIO getCurrentTime
|
||||
unlessM (lift $ rescheduleAction doWork ts actionTs) $
|
||||
case smpAction of
|
||||
NSASmpKey ->
|
||||
lift getNtfToken >>= \case
|
||||
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do
|
||||
rq <- withStore c (`getPrimaryRcvQueue` connId)
|
||||
C.AuthAlg a <- asks (rcvAuthAlg . config)
|
||||
g <- asks random
|
||||
(ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateAuthKeyPair a g
|
||||
(rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
|
||||
(notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey
|
||||
let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
|
||||
withStore' c $ \db -> do
|
||||
setRcvQueueNtfCreds db connId $ Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
|
||||
updateNtfSubscription db sub {ntfQueueId = Just notifierId, ntfSubStatus = NASKey} (NSANtf NSACreate) ts
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (connId, NSCNtfWorker ntfServer)
|
||||
_ -> workerInternalError c connId "NSASmpKey - no active token"
|
||||
NSASmpDelete -> do
|
||||
-- TODO should we remove it after successful removal from the server?
|
||||
rq_ <- withStore' c $ \db -> do
|
||||
setRcvQueueNtfCreds db connId Nothing
|
||||
getPrimaryRcvQueue db connId
|
||||
mapM_ (disableQueueNotifications c) rq_
|
||||
withStore' c $ \db -> deleteNtfSubscription db connId
|
||||
|
||||
retrySubActions :: AgentClient -> [NtfSubscription] -> ([NtfSubscription] -> AM' [NtfSubscription]) -> AM ()
|
||||
retrySubActions _ [] _ = pure ()
|
||||
retrySubActions c subs action = do
|
||||
v <- newTVarIO subs
|
||||
ri <- asks $ reconnectInterval . config
|
||||
withRetryInterval ri $ \_ loop -> do
|
||||
liftIO $ waitWhileSuspended c
|
||||
liftIO $ waitForUserNetwork c
|
||||
subs' <- readTVarIO v
|
||||
retrySubs <- lift $ action subs'
|
||||
unless (null retrySubs) $ do
|
||||
atomically $ writeTVar v retrySubs
|
||||
retryNetworkLoop c loop
|
||||
rescheduleAction :: TMVar () -> UTCTime -> UTCTime -> AM' Bool
|
||||
rescheduleAction doWork ts actionTs
|
||||
| actionTs <= ts = pure False
|
||||
| otherwise = do
|
||||
void . atomically $ tryTakeTMVar doWork
|
||||
void . forkIO $ do
|
||||
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime actionTs ts
|
||||
atomically $ hasWorkToDo' doWork
|
||||
pure True
|
||||
|
||||
-- (temporary errs, other errs, successes)
|
||||
splitResults :: [(a, Either AgentErrorType r)] -> ([a], [(a, AgentErrorType)], [(a, r)])
|
||||
splitResults = foldr addRes ([], [], [])
|
||||
retryOnError :: AgentClient -> Text -> AM () -> (AgentErrorType -> AM ()) -> AgentErrorType -> AM ()
|
||||
retryOnError c name loop done e = do
|
||||
logError $ name <> " error: " <> tshow e
|
||||
case e of
|
||||
BROKER _ NETWORK -> retryLoop
|
||||
BROKER _ TIMEOUT -> retryLoop
|
||||
_ -> done e
|
||||
where
|
||||
addRes (a, r_) (as, errs, rs) = case r_ of
|
||||
Right r -> (as, errs, (a, r) : rs)
|
||||
Left e
|
||||
| temporaryOrHostError e -> (a : as, errs, rs)
|
||||
| otherwise -> (as, (a, e) : errs, rs)
|
||||
|
||||
rescheduleWork :: TMVar () -> UTCTime -> UTCTime -> AM' ()
|
||||
rescheduleWork doWork ts actionTs = do
|
||||
void . atomically $ tryTakeTMVar doWork
|
||||
void . forkIO $ do
|
||||
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime actionTs ts
|
||||
atomically $ hasWorkToDo' doWork
|
||||
|
||||
retryNetworkLoop :: AgentClient -> AM () -> AM ()
|
||||
retryNetworkLoop c loop = do
|
||||
atomically $ endAgentOperation c AONtfNetwork
|
||||
liftIO $ throwWhenInactive c
|
||||
atomically $ beginAgentOperation c AONtfNetwork
|
||||
loop
|
||||
|
||||
workerErrors :: AgentClient -> [(ConnId, AgentErrorType)] -> AM' ()
|
||||
workerErrors c connErrs =
|
||||
unless (null connErrs) $ do
|
||||
void $ withStoreBatch' c (\db -> map (setNullNtfSubscriptionAction db . fst) connErrs)
|
||||
notifyErrs c connErrs
|
||||
retryLoop = do
|
||||
atomically $ endAgentOperation c AONtfNetwork
|
||||
liftIO $ throwWhenInactive c
|
||||
atomically $ beginAgentOperation c AONtfNetwork
|
||||
loop
|
||||
|
||||
workerInternalError :: AgentClient -> ConnId -> String -> AM ()
|
||||
workerInternalError c connId internalErrStr = do
|
||||
@@ -506,14 +311,6 @@ notifyInternalError :: MonadIO m => AgentClient -> ConnId -> String -> m ()
|
||||
notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AEvt SAEConn $ ERR $ INTERNAL internalErrStr)
|
||||
{-# INLINE notifyInternalError #-}
|
||||
|
||||
notifyInternalError' :: MonadIO m => AgentClient -> String -> m ()
|
||||
notifyInternalError' AgentClient {subQ} internalErrStr = atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ INTERNAL internalErrStr)
|
||||
{-# INLINE notifyInternalError' #-}
|
||||
|
||||
notifyErrs :: MonadIO m => AgentClient -> [(ConnId, AgentErrorType)] -> m ()
|
||||
notifyErrs AgentClient {subQ} connErrs = unless (null connErrs) $ atomically $ writeTBQueue subQ ("", "", AEvt SAENone $ ERRS connErrs)
|
||||
{-# INLINE notifyErrs #-}
|
||||
|
||||
getNtfToken :: AM' (Maybe NtfToken)
|
||||
getNtfToken = do
|
||||
tkn <- asks $ ntfTkn . ntfSupervisor
|
||||
@@ -525,7 +322,7 @@ nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
|
||||
nsRemoveNtfToken :: NtfSupervisor -> STM ()
|
||||
nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
|
||||
|
||||
sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
|
||||
sendNtfSubCommand :: NtfSupervisor -> (ConnId, NtfSupervisorCommand) -> STM ()
|
||||
sendNtfSubCommand ns cmd = do
|
||||
tkn <- readTVar (ntfTkn ns)
|
||||
when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
|
||||
@@ -535,51 +332,10 @@ instantNotifications = \case
|
||||
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
|
||||
_ -> False
|
||||
|
||||
deleteToken :: AgentClient -> NtfToken -> AM ()
|
||||
deleteToken c tkn@NtfToken {ntfServer, ntfTokenId, ntfPrivKey} = do
|
||||
setToDelete <- withStore' c $ \db -> do
|
||||
removeNtfToken db tkn
|
||||
case ntfTokenId of
|
||||
Just tknId -> addNtfTokenToDelete db ntfServer ntfPrivKey tknId $> True
|
||||
Nothing -> pure False
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ nsRemoveNtfToken ns
|
||||
when setToDelete $ void $ lift $ getNtfTknDelWorker True c ntfServer
|
||||
|
||||
runNtfTknDelWorker :: AgentClient -> NtfServer -> Worker -> AM ()
|
||||
runNtfTknDelWorker c srv Worker {doWork} =
|
||||
forever $ do
|
||||
waitForWork doWork
|
||||
ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfOperation
|
||||
where
|
||||
runNtfOperation :: AM ()
|
||||
runNtfOperation =
|
||||
withWork c doWork (`getNextNtfTokenToDelete` srv) $
|
||||
\nextTknToDelete -> do
|
||||
logInfo $ "runNtfTknDelWorker, nextTknToDelete " <> tshow nextTknToDelete
|
||||
ri <- asks $ reconnectInterval . config
|
||||
withRetryInterval ri $ \_ loop -> do
|
||||
liftIO $ waitWhileSuspended c
|
||||
liftIO $ waitForUserNetwork c
|
||||
processTknToDelete nextTknToDelete `catchAgentError` retryTmpError loop nextTknToDelete
|
||||
retryTmpError :: AM () -> NtfTokenToDelete -> AgentErrorType -> AM ()
|
||||
retryTmpError loop (tknDbId, _, _) e = do
|
||||
logError $ "ntf tkn del error: " <> tshow e
|
||||
if temporaryOrHostError e
|
||||
then retryNetworkLoop c loop
|
||||
else do
|
||||
withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
|
||||
notifyInternalError' c (show e)
|
||||
processTknToDelete :: NtfTokenToDelete -> AM ()
|
||||
processTknToDelete (tknDbId, ntfPrivKey, tknId) = do
|
||||
agentNtfDeleteToken c srv ntfPrivKey tknId
|
||||
withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
|
||||
|
||||
closeNtfSupervisor :: NtfSupervisor -> IO ()
|
||||
closeNtfSupervisor ns = do
|
||||
stopWorkers $ ntfWorkers ns
|
||||
stopWorkers $ ntfSMPWorkers ns
|
||||
stopWorkers $ ntfTknDelWorkers ns
|
||||
where
|
||||
stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
|
||||
|
||||
|
||||
@@ -51,7 +51,6 @@ module Simplex.Messaging.Agent.Protocol
|
||||
-- * SMP agent protocol types
|
||||
ConnInfo,
|
||||
SndQueueSecured,
|
||||
AEntityId,
|
||||
ACommand (..),
|
||||
AEvent (..),
|
||||
AEvt (..),
|
||||
@@ -108,7 +107,6 @@ module Simplex.Messaging.Agent.Protocol
|
||||
ConnReqUriData (..),
|
||||
CRClientData,
|
||||
ServiceScheme,
|
||||
sameConnReqContact,
|
||||
simplexChat,
|
||||
connReqUriP',
|
||||
AgentErrorType (..),
|
||||
@@ -192,6 +190,7 @@ import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol
|
||||
( AProtocolType,
|
||||
BrokerErrorType (..),
|
||||
EntityId,
|
||||
ErrorType,
|
||||
MsgBody,
|
||||
MsgFlags,
|
||||
@@ -199,6 +198,7 @@ import Simplex.Messaging.Protocol
|
||||
NMsgMeta,
|
||||
ProtocolServer (..),
|
||||
SMPClientVersion,
|
||||
SMPMsgMeta,
|
||||
SMPServer,
|
||||
SMPServerWithAuth,
|
||||
SndPublicAuthKey,
|
||||
@@ -277,22 +277,20 @@ supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPA
|
||||
e2eEncConnInfoLength :: VersionSMPA -> PQSupport -> Int
|
||||
e2eEncConnInfoLength v = \case
|
||||
-- reduced by 3726 (roughly the increase of message ratchet header size + key and ciphertext in reply link)
|
||||
PQSupportOn | v >= pqdrSMPAgentVersion -> 11106
|
||||
_ -> 14832
|
||||
PQSupportOn | v >= pqdrSMPAgentVersion -> 11122
|
||||
_ -> 14848
|
||||
|
||||
e2eEncAgentMsgLength :: VersionSMPA -> PQSupport -> Int
|
||||
e2eEncAgentMsgLength v = \case
|
||||
-- reduced by 2222 (the increase of message ratchet header size)
|
||||
PQSupportOn | v >= pqdrSMPAgentVersion -> 13618
|
||||
_ -> 15840
|
||||
PQSupportOn | v >= pqdrSMPAgentVersion -> 13634
|
||||
_ -> 15856
|
||||
|
||||
-- | SMP agent event
|
||||
type ATransmission = (ACorrId, AEntityId, AEvt)
|
||||
type ATransmission = (ACorrId, EntityId, AEvt)
|
||||
|
||||
type UserId = Int64
|
||||
|
||||
type AEntityId = ByteString
|
||||
|
||||
type ACorrId = ByteString
|
||||
|
||||
data AEntity = AEConn | AERcvFile | AESndFile | AENone
|
||||
@@ -344,7 +342,6 @@ data AEvent (e :: AEntity) where
|
||||
INFO :: PQSupport -> ConnInfo -> AEvent AEConn
|
||||
CON :: PQEncryption -> AEvent AEConn -- notification that connection is established
|
||||
END :: AEvent AEConn
|
||||
DELD :: AEvent AEConn
|
||||
CONNECT :: AProtocolType -> TransportHost -> AEvent AENone
|
||||
DISCONNECT :: AProtocolType -> TransportHost -> AEvent AENone
|
||||
DOWN :: SMPServer -> [ConnId] -> AEvent AENone
|
||||
@@ -356,7 +353,7 @@ data AEvent (e :: AEntity) where
|
||||
MERR :: AgentMsgId -> AgentErrorType -> AEvent AEConn
|
||||
MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> AEvent AEConn
|
||||
MSG :: MsgMeta -> MsgFlags -> MsgBody -> AEvent AEConn
|
||||
MSGNTF :: MsgId -> Maybe UTCTime -> AEvent AEConn
|
||||
MSGNTF :: SMPMsgMeta -> AEvent AEConn
|
||||
RCVD :: MsgMeta -> NonEmpty MsgReceipt -> AEvent AEConn
|
||||
QCONT :: AEvent AEConn
|
||||
DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> AEvent AEConn
|
||||
@@ -366,7 +363,6 @@ data AEvent (e :: AEntity) where
|
||||
OK :: AEvent AEConn
|
||||
JOINED :: SndQueueSecured -> AEvent AEConn
|
||||
ERR :: AgentErrorType -> AEvent AEConn
|
||||
ERRS :: [(ConnId, AgentErrorType)] -> AEvent AENone
|
||||
SUSPENDED :: AEvent AENone
|
||||
RFPROG :: Int64 -> Int64 -> AEvent AERcvFile
|
||||
RFDONE :: FilePath -> AEvent AERcvFile
|
||||
@@ -415,7 +411,6 @@ data AEventTag (e :: AEntity) where
|
||||
INFO_ :: AEventTag AEConn
|
||||
CON_ :: AEventTag AEConn
|
||||
END_ :: AEventTag AEConn
|
||||
DELD_ :: AEventTag AEConn
|
||||
CONNECT_ :: AEventTag AENone
|
||||
DISCONNECT_ :: AEventTag AENone
|
||||
DOWN_ :: AEventTag AENone
|
||||
@@ -437,7 +432,6 @@ data AEventTag (e :: AEntity) where
|
||||
OK_ :: AEventTag AEConn
|
||||
JOINED_ :: AEventTag AEConn
|
||||
ERR_ :: AEventTag AEConn
|
||||
ERRS_ :: AEventTag AENone
|
||||
SUSPENDED_ :: AEventTag AENone
|
||||
-- XFTP commands and responses
|
||||
RFDONE_ :: AEventTag AERcvFile
|
||||
@@ -470,7 +464,6 @@ aEventTag = \case
|
||||
INFO {} -> INFO_
|
||||
CON _ -> CON_
|
||||
END -> END_
|
||||
DELD -> DELD_
|
||||
CONNECT {} -> CONNECT_
|
||||
DISCONNECT {} -> DISCONNECT_
|
||||
DOWN {} -> DOWN_
|
||||
@@ -492,7 +485,6 @@ aEventTag = \case
|
||||
OK -> OK_
|
||||
JOINED _ -> JOINED_
|
||||
ERR _ -> ERR_
|
||||
ERRS _ -> ERRS_
|
||||
SUSPENDED -> SUSPENDED_
|
||||
RFPROG {} -> RFPROG_
|
||||
RFDONE {} -> RFDONE_
|
||||
@@ -1264,12 +1256,6 @@ instance Eq AConnectionRequestUri where
|
||||
|
||||
deriving instance Show AConnectionRequestUri
|
||||
|
||||
sameConnReqContact :: ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact -> Bool
|
||||
sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUri ConnReqUriData {crSmpQueues = qs'}) =
|
||||
L.length qs == L.length qs' && all same (L.zip qs qs')
|
||||
where
|
||||
same (q, q') = sameQAddress (qAddress q) (qAddress q')
|
||||
|
||||
data ConnReqUriData = ConnReqUriData
|
||||
{ crScheme :: ServiceScheme,
|
||||
crAgentVRange :: VersionRangeSMPA,
|
||||
@@ -1350,8 +1336,6 @@ data AgentErrorType
|
||||
CMD {cmdErr :: CommandErrorType, errContext :: String}
|
||||
| -- | connection errors
|
||||
CONN {connErr :: ConnectionErrorType}
|
||||
| -- | user not found in database
|
||||
NO_USER
|
||||
| -- | SMP protocol errors forwarded to agent clients
|
||||
SMP {serverAddress :: String, smpErr :: ErrorType}
|
||||
| -- | NTF protocol errors forwarded to agent clients
|
||||
|
||||
@@ -1,12 +1,10 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
@@ -17,7 +15,6 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
@@ -60,7 +57,6 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
getDeletedConns,
|
||||
getConnData,
|
||||
setConnDeleted,
|
||||
setConnUserId,
|
||||
setConnAgentVersion,
|
||||
setConnPQSupport,
|
||||
getDeletedConnIds,
|
||||
@@ -114,7 +110,6 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
getSndMsgViaRcpt,
|
||||
updateSndMsgRcpt,
|
||||
getPendingQueueMsg,
|
||||
getConnectionsForDelivery,
|
||||
updatePendingMsgRIState,
|
||||
deletePendingMsgs,
|
||||
getExpiredSndMessages,
|
||||
@@ -122,7 +117,6 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
getRcvMsg,
|
||||
getLastMsg,
|
||||
checkRcvMsgHashExists,
|
||||
getRcvMsgBrokerTs,
|
||||
deleteMsg,
|
||||
deleteDeliveredSndMsg,
|
||||
deleteSndMsgDelivery,
|
||||
@@ -141,7 +135,6 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
createCommand,
|
||||
getPendingCommandServers,
|
||||
getPendingServerCommand,
|
||||
updateCommandServer,
|
||||
deleteCommand,
|
||||
-- Notification device token persistence
|
||||
createNtfToken,
|
||||
@@ -151,15 +144,7 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
updateNtfMode,
|
||||
updateNtfToken,
|
||||
removeNtfToken,
|
||||
addNtfTokenToDelete,
|
||||
deleteExpiredNtfTokensToDelete,
|
||||
NtfTokenToDelete,
|
||||
getNextNtfTokenToDelete,
|
||||
markNtfTokenToDeleteFailed_, -- exported for tests
|
||||
getPendingDelTknServers,
|
||||
deleteNtfTokenToDelete,
|
||||
-- Notification subscription persistence
|
||||
NtfSupervisorSub,
|
||||
getNtfSubscription,
|
||||
createNtfSubscription,
|
||||
supervisorUpdateNtfSub,
|
||||
@@ -167,10 +152,9 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
updateNtfSubscription,
|
||||
setNullNtfSubscriptionAction,
|
||||
deleteNtfSubscription,
|
||||
deleteNtfSubscription',
|
||||
getNextNtfSubNTFActions,
|
||||
getNextNtfSubNTFAction,
|
||||
markNtfSubActionNtfFailed_, -- exported for tests
|
||||
getNextNtfSubSMPActions,
|
||||
getNextNtfSubSMPAction,
|
||||
markNtfSubActionSMPFailed_, -- exported for tests
|
||||
getActiveNtfToken,
|
||||
getNtfRcvQueue,
|
||||
@@ -976,18 +960,17 @@ updateRcvIds db connId = do
|
||||
pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash)
|
||||
|
||||
createRcvMsg :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO ()
|
||||
createRcvMsg db connId rq@RcvQueue {dbQueueId} rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId, broker = (_, brokerTs)}, internalRcvId, internalHash} = do
|
||||
createRcvMsg db connId rq rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalRcvId, internalHash} = do
|
||||
insertRcvMsgBase_ db connId rcvMsgData
|
||||
insertRcvMsgDetails_ db connId rq rcvMsgData
|
||||
updateRcvMsgHash db connId sndMsgId internalRcvId internalHash
|
||||
DB.execute db "UPDATE rcv_queues SET last_broker_ts = ? WHERE conn_id = ? AND rcv_queue_id = ?" (brokerTs, connId, dbQueueId)
|
||||
|
||||
updateSndIds :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash))
|
||||
updateSndIds db connId = runExceptT $ do
|
||||
(lastInternalId, lastInternalSndId, prevSndHash) <- ExceptT $ retrieveLastIdsAndHashSnd_ db connId
|
||||
updateSndIds :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
|
||||
updateSndIds db connId = do
|
||||
(lastInternalId, lastInternalSndId, prevSndHash) <- retrieveLastIdsAndHashSnd_ db connId
|
||||
let internalId = InternalId $ unId lastInternalId + 1
|
||||
internalSndId = InternalSndId $ unSndId lastInternalSndId + 1
|
||||
liftIO $ updateLastIdsSnd_ db connId internalId internalSndId
|
||||
updateLastIdsSnd_ db connId internalId internalSndId
|
||||
pure (internalId, internalSndId, prevSndHash)
|
||||
|
||||
createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO ()
|
||||
@@ -1025,10 +1008,6 @@ updateSndMsgRcpt db connId sndMsgId MsgReceipt {agentMsgId, msgRcptStatus} =
|
||||
"UPDATE snd_messages SET rcpt_internal_id = ?, rcpt_status = ? WHERE conn_id = ? AND internal_snd_id = ?"
|
||||
(agentMsgId, msgRcptStatus, connId, sndMsgId)
|
||||
|
||||
getConnectionsForDelivery :: DB.Connection -> IO [ConnId]
|
||||
getConnectionsForDelivery db =
|
||||
map fromOnly <$> DB.query_ db "SELECT DISTINCT conn_id FROM snd_message_deliveries WHERE failed = 0"
|
||||
|
||||
getPendingQueueMsg :: DB.Connection -> ConnId -> SndQueue -> IO (Either StoreError (Maybe (Maybe RcvQueue, PendingMsgData)))
|
||||
getPendingQueueMsg db connId SndQueue {dbQueueId} =
|
||||
getWorkItem "message" getMsgId getMsgData markMsgFailed
|
||||
@@ -1072,26 +1051,17 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} =
|
||||
|
||||
getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a))
|
||||
getWorkItem itemName getId getItem markFailed =
|
||||
runExceptT $ handleWrkErr itemName "getId" getId >>= mapM (tryGetItem itemName getItem markFailed)
|
||||
|
||||
getWorkItems :: Show i => ByteString -> IO [i] -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError [Either StoreError a])
|
||||
getWorkItems itemName getIds getItem markFailed =
|
||||
runExceptT $ handleWrkErr itemName "getIds" getIds >>= mapM (tryE . tryGetItem itemName getItem markFailed)
|
||||
|
||||
tryGetItem :: Show i => ByteString -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> i -> ExceptT StoreError IO a
|
||||
tryGetItem itemName getItem markFailed itemId = ExceptT (getItem itemId) `catchStoreError` \e -> mark >> throwE e
|
||||
runExceptT $ handleErr "getId" getId >>= mapM tryGetItem
|
||||
where
|
||||
mark = handleWrkErr itemName ("markFailed ID " <> bshow itemId) $ markFailed itemId
|
||||
|
||||
catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a
|
||||
catchStoreError = catchAllErrors (SEInternal . bshow)
|
||||
|
||||
-- Errors caught by this function will suspend worker as if there is no more work,
|
||||
handleWrkErr :: ByteString -> ByteString -> IO a -> ExceptT StoreError IO a
|
||||
handleWrkErr itemName opName action = ExceptT $ first mkError <$> E.try action
|
||||
where
|
||||
mkError :: E.SomeException -> StoreError
|
||||
mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e
|
||||
tryGetItem itemId = ExceptT (getItem itemId) `catchStoreErrors` \e -> mark itemId >> throwE e
|
||||
mark itemId = handleErr ("markFailed ID " <> bshow itemId) $ markFailed itemId
|
||||
catchStoreErrors = catchAllErrors (SEInternal . bshow)
|
||||
-- Errors caught by this function will suspend worker as if there is no more work,
|
||||
handleErr :: ByteString -> IO a -> ExceptT StoreError IO a
|
||||
handleErr opName action = ExceptT $ first mkError <$> E.try action
|
||||
where
|
||||
mkError :: E.SomeException -> StoreError
|
||||
mkError e = SEWorkItemError $ itemName <> " " <> opName <> " error: " <> bshow e
|
||||
|
||||
updatePendingMsgRIState :: DB.Connection -> ConnId -> InternalId -> RI2State -> IO ()
|
||||
updatePendingMsgRIState db connId msgId RI2State {slowInterval, fastInterval} =
|
||||
@@ -1187,11 +1157,6 @@ checkRcvMsgHashExists db connId hash = do
|
||||
(connId, hash)
|
||||
)
|
||||
|
||||
getRcvMsgBrokerTs :: DB.Connection -> ConnId -> SMP.MsgId -> IO (Either StoreError BrokerTs)
|
||||
getRcvMsgBrokerTs db connId msgId =
|
||||
firstRow fromOnly SEMsgNotFound $
|
||||
DB.query db "SELECT broker_ts FROM rcv_messages WHERE conn_id = ? AND broker_id = ?" (connId, msgId)
|
||||
|
||||
deleteMsg :: DB.Connection -> ConnId -> InternalId -> IO ()
|
||||
deleteMsg db connId msgId =
|
||||
DB.execute db "DELETE FROM messages WHERE conn_id = ? AND internal_id = ?;" (connId, msgId)
|
||||
@@ -1352,39 +1317,38 @@ getPendingCommandServers db connId = do
|
||||
where
|
||||
smpServer (host, port, keyHash) = SMPServer <$> host <*> port <*> keyHash
|
||||
|
||||
getPendingServerCommand :: DB.Connection -> ConnId -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
|
||||
getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
|
||||
getPendingServerCommand :: DB.Connection -> Maybe SMPServer -> IO (Either StoreError (Maybe PendingCommand))
|
||||
getPendingServerCommand db srv_ = getWorkItem "command" getCmdId getCommand markCommandFailed
|
||||
where
|
||||
getCmdId :: IO (Maybe Int64)
|
||||
getCmdId =
|
||||
maybeFirstRow fromOnly $ case srv_ of
|
||||
Nothing ->
|
||||
DB.query
|
||||
DB.query_
|
||||
db
|
||||
[sql|
|
||||
SELECT command_id FROM commands
|
||||
WHERE conn_id = ? AND host IS NULL AND port IS NULL AND failed = 0
|
||||
WHERE host IS NULL AND port IS NULL AND failed = 0
|
||||
ORDER BY created_at ASC, command_id ASC
|
||||
LIMIT 1
|
||||
|]
|
||||
(Only connId)
|
||||
Just (SMPServer host port _) ->
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT command_id FROM commands
|
||||
WHERE conn_id = ? AND host = ? AND port = ? AND failed = 0
|
||||
WHERE host = ? AND port = ? AND failed = 0
|
||||
ORDER BY created_at ASC, command_id ASC
|
||||
LIMIT 1
|
||||
|]
|
||||
(connId, host, port)
|
||||
(host, port)
|
||||
getCommand :: Int64 -> IO (Either StoreError PendingCommand)
|
||||
getCommand cmdId =
|
||||
firstRow pendingCommand err $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.corr_id, cs.user_id, c.command
|
||||
SELECT c.corr_id, cs.user_id, c.conn_id, c.command
|
||||
FROM commands c
|
||||
JOIN connections cs USING (conn_id)
|
||||
WHERE c.command_id = ?
|
||||
@@ -1392,22 +1356,9 @@ getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getComma
|
||||
(Only cmdId)
|
||||
where
|
||||
err = SEInternal $ "command " <> bshow cmdId <> " returned []"
|
||||
pendingCommand (corrId, userId, command) = PendingCommand {cmdId, corrId, userId, connId, command}
|
||||
pendingCommand (corrId, userId, connId, command) = PendingCommand {cmdId, corrId, userId, connId, command}
|
||||
markCommandFailed cmdId = DB.execute db "UPDATE commands SET failed = 1 WHERE command_id = ?" (Only cmdId)
|
||||
|
||||
updateCommandServer :: DB.Connection -> AsyncCmdId -> SMPServer -> IO (Either StoreError ())
|
||||
updateCommandServer db cmdId srv@(SMPServer host port _) = runExceptT $ do
|
||||
serverKeyHash_ <- ExceptT $ getServerKeyHash_ db srv
|
||||
liftIO $
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE commands
|
||||
SET host = ?, port = ?, server_key_hash = ?
|
||||
WHERE command_id = ?
|
||||
|]
|
||||
(host, port, serverKeyHash_, cmdId)
|
||||
|
||||
deleteCommand :: DB.Connection -> AsyncCmdId -> IO ()
|
||||
deleteCommand db cmdId =
|
||||
DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId)
|
||||
@@ -1500,73 +1451,7 @@ removeNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer
|
||||
|]
|
||||
(provider, token, host, port)
|
||||
|
||||
addNtfTokenToDelete :: DB.Connection -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> IO ()
|
||||
addNtfTokenToDelete db ProtocolServer {host, port, keyHash} ntfPrivKey tknId =
|
||||
DB.execute db "INSERT INTO ntf_tokens_to_delete (ntf_host, ntf_port, ntf_key_hash, tkn_id, tkn_priv_key) VALUES (?,?,?,?,?)" (host, port, keyHash, tknId, ntfPrivKey)
|
||||
|
||||
deleteExpiredNtfTokensToDelete :: DB.Connection -> NominalDiffTime -> IO ()
|
||||
deleteExpiredNtfTokensToDelete db ttl = do
|
||||
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
|
||||
DB.execute db "DELETE FROM ntf_tokens_to_delete WHERE created_at < ?" (Only cutoffTs)
|
||||
|
||||
type NtfTokenToDelete = (Int64, C.APrivateAuthKey, NtfTokenId)
|
||||
|
||||
getNextNtfTokenToDelete :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe NtfTokenToDelete))
|
||||
getNextNtfTokenToDelete db (NtfServer ntfHost ntfPort _) =
|
||||
getWorkItem "ntf tkn del" getNtfTknDbId getNtfTknToDelete (markNtfTokenToDeleteFailed_ db)
|
||||
where
|
||||
getNtfTknDbId :: IO (Maybe Int64)
|
||||
getNtfTknDbId =
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT ntf_token_to_delete_id
|
||||
FROM ntf_tokens_to_delete
|
||||
WHERE ntf_host = ? AND ntf_port = ?
|
||||
AND del_failed = 0
|
||||
ORDER BY created_at ASC
|
||||
LIMIT 1
|
||||
|]
|
||||
(ntfHost, ntfPort)
|
||||
getNtfTknToDelete :: Int64 -> IO (Either StoreError NtfTokenToDelete)
|
||||
getNtfTknToDelete tknDbId =
|
||||
firstRow ntfTokenToDelete err $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT tkn_priv_key, tkn_id
|
||||
FROM ntf_tokens_to_delete
|
||||
WHERE ntf_token_to_delete_id = ?
|
||||
|]
|
||||
(Only tknDbId)
|
||||
where
|
||||
err = SEInternal $ "ntf token to delete " <> bshow tknDbId <> " returned []"
|
||||
ntfTokenToDelete (tknPrivKey, tknId) = (tknDbId, tknPrivKey, tknId)
|
||||
|
||||
markNtfTokenToDeleteFailed_ :: DB.Connection -> Int64 -> IO ()
|
||||
markNtfTokenToDeleteFailed_ db tknDbId =
|
||||
DB.execute db "UPDATE ntf_tokens_to_delete SET del_failed = 1 where ntf_token_to_delete_id = ?" (Only tknDbId)
|
||||
|
||||
getPendingDelTknServers :: DB.Connection -> IO [NtfServer]
|
||||
getPendingDelTknServers db =
|
||||
map toNtfServer
|
||||
<$> DB.query_
|
||||
db
|
||||
[sql|
|
||||
SELECT DISTINCT ntf_host, ntf_port, ntf_key_hash
|
||||
FROM ntf_tokens_to_delete
|
||||
|]
|
||||
where
|
||||
toNtfServer (host, port, keyHash) = NtfServer host port keyHash
|
||||
|
||||
deleteNtfTokenToDelete :: DB.Connection -> Int64 -> IO ()
|
||||
deleteNtfTokenToDelete db tknDbId =
|
||||
DB.execute db "DELETE FROM ntf_tokens_to_delete WHERE ntf_token_to_delete_id = ?" (Only tknDbId)
|
||||
|
||||
type NtfSupervisorSub = (NtfSubscription, Maybe (NtfSubAction, NtfActionTs))
|
||||
|
||||
getNtfSubscription :: DB.Connection -> ConnId -> IO (Maybe NtfSupervisorSub)
|
||||
getNtfSubscription :: DB.Connection -> ConnId -> IO (Maybe (NtfSubscription, Maybe (NtfSubAction, NtfActionTs)))
|
||||
getNtfSubscription db connId =
|
||||
maybeFirstRow ntfSubscription $
|
||||
DB.query
|
||||
@@ -1582,7 +1467,7 @@ getNtfSubscription db connId =
|
||||
|]
|
||||
(Only connId)
|
||||
where
|
||||
ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) =
|
||||
ntfSubscription ((userId, smpHost, smpPort, smpKeyHash, ntfHost, ntfPort, ntfKeyHash ) :. (ntfQueueId, ntfSubId, ntfSubStatus, ntfAction_, smpAction_, actionTs_)) =
|
||||
let smpServer = SMPServer smpHost smpPort smpKeyHash
|
||||
ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
|
||||
action = case (ntfAction_, smpAction_, actionTs_) of
|
||||
@@ -1612,19 +1497,16 @@ createNtfSubscription db ntfSubscription action = runExceptT $ do
|
||||
(ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
|
||||
|
||||
supervisorUpdateNtfSub :: DB.Connection -> NtfSubscription -> NtfSubAction -> IO ()
|
||||
supervisorUpdateNtfSub db NtfSubscription {connId, smpServer = (SMPServer smpHost smpPort _), ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do
|
||||
supervisorUpdateNtfSub db NtfSubscription {connId, ntfQueueId, ntfServer = (NtfServer ntfHost ntfPort _), ntfSubId, ntfSubStatus} action = do
|
||||
ts <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE ntf_subscriptions
|
||||
SET smp_host = ?, smp_port = ?, smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?,
|
||||
ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
|
||||
SET smp_ntf_id = ?, ntf_host = ?, ntf_port = ?, ntf_sub_id = ?, ntf_sub_status = ?, ntf_sub_action = ?, ntf_sub_smp_action = ?, ntf_sub_action_ts = ?, updated_by_supervisor = ?, updated_at = ?
|
||||
WHERE conn_id = ?
|
||||
|]
|
||||
( (smpHost, smpPort, ntfQueueId, ntfHost, ntfPort, ntfSubId)
|
||||
:. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId)
|
||||
)
|
||||
((ntfQueueId, ntfHost, ntfPort, ntfSubId) :. (ntfSubStatus, ntfSubAction, ntfSubSMPAction, ts, True, ts, connId))
|
||||
where
|
||||
(ntfSubAction, ntfSubSMPAction) = ntfSubAndSMPAction action
|
||||
|
||||
@@ -1699,20 +1581,16 @@ deleteNtfSubscription db connId = do
|
||||
WHERE conn_id = ?
|
||||
|]
|
||||
(Nothing :: Maybe SMP.NotifierId, Nothing :: Maybe NtfSubscriptionId, NASDeleted, False, updatedAt, connId)
|
||||
else deleteNtfSubscription' db connId
|
||||
else DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
|
||||
|
||||
deleteNtfSubscription' :: DB.Connection -> ConnId -> IO ()
|
||||
deleteNtfSubscription' db connId = do
|
||||
DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
|
||||
|
||||
getNextNtfSubNTFActions :: DB.Connection -> NtfServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubNTFAction, NtfSubscription, NtfActionTs)])
|
||||
getNextNtfSubNTFActions db ntfServer@(NtfServer ntfHost ntfPort _) ntfBatchSize =
|
||||
getWorkItems "ntf NTF" getNtfConnIds getNtfSubAction (markNtfSubActionNtfFailed_ db)
|
||||
getNextNtfSubNTFAction :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubNTFAction, NtfActionTs)))
|
||||
getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
|
||||
getWorkItem "ntf NTF" getNtfConnId getNtfSubAction (markNtfSubActionNtfFailed_ db)
|
||||
where
|
||||
getNtfConnIds :: IO [ConnId]
|
||||
getNtfConnIds =
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
getNtfConnId :: IO (Maybe ConnId)
|
||||
getNtfConnId =
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_id
|
||||
@@ -1720,10 +1598,10 @@ getNextNtfSubNTFActions db ntfServer@(NtfServer ntfHost ntfPort _) ntfBatchSize
|
||||
WHERE ntf_host = ? AND ntf_port = ? AND ntf_sub_action IS NOT NULL
|
||||
AND (ntf_failed = 0 OR updated_by_supervisor = 1)
|
||||
ORDER BY ntf_sub_action_ts ASC
|
||||
LIMIT ?
|
||||
LIMIT 1
|
||||
|]
|
||||
(ntfHost, ntfPort, ntfBatchSize)
|
||||
getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubNTFAction, NtfSubscription, NtfActionTs))
|
||||
(ntfHost, ntfPort)
|
||||
getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubscription, NtfSubNTFAction, NtfActionTs))
|
||||
getNtfSubAction connId = do
|
||||
markUpdatedByWorker db connId
|
||||
firstRow ntfSubAction err $
|
||||
@@ -1743,20 +1621,20 @@ getNextNtfSubNTFActions db ntfServer@(NtfServer ntfHost ntfPort _) ntfBatchSize
|
||||
ntfSubAction (userId, smpHost, smpPort, smpKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
|
||||
let smpServer = SMPServer smpHost smpPort smpKeyHash
|
||||
ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
|
||||
in (action, ntfSubscription, actionTs)
|
||||
in (ntfSubscription, action, actionTs)
|
||||
|
||||
markNtfSubActionNtfFailed_ :: DB.Connection -> ConnId -> IO ()
|
||||
markNtfSubActionNtfFailed_ db connId =
|
||||
DB.execute db "UPDATE ntf_subscriptions SET ntf_failed = 1 where conn_id = ?" (Only connId)
|
||||
|
||||
getNextNtfSubSMPActions :: DB.Connection -> SMPServer -> Int -> IO (Either StoreError [Either StoreError (NtfSubSMPAction, NtfSubscription)])
|
||||
getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize =
|
||||
getWorkItems "ntf SMP" getNtfConnIds getNtfSubAction (markNtfSubActionSMPFailed_ db)
|
||||
getNextNtfSubSMPAction :: DB.Connection -> SMPServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubSMPAction, NtfActionTs)))
|
||||
getNextNtfSubSMPAction db smpServer@(SMPServer smpHost smpPort _) =
|
||||
getWorkItem "ntf SMP" getNtfConnId getNtfSubAction (markNtfSubActionSMPFailed_ db)
|
||||
where
|
||||
getNtfConnIds :: IO [ConnId]
|
||||
getNtfConnIds =
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
getNtfConnId :: IO (Maybe ConnId)
|
||||
getNtfConnId =
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_id
|
||||
@@ -1764,10 +1642,10 @@ getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize
|
||||
WHERE smp_host = ? AND smp_port = ? AND ntf_sub_smp_action IS NOT NULL AND ntf_sub_action_ts IS NOT NULL
|
||||
AND (smp_failed = 0 OR updated_by_supervisor = 1)
|
||||
ORDER BY ntf_sub_action_ts ASC
|
||||
LIMIT ?
|
||||
LIMIT 1
|
||||
|]
|
||||
(smpHost, smpPort, ntfBatchSize)
|
||||
getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubSMPAction, NtfSubscription))
|
||||
(smpHost, smpPort)
|
||||
getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubscription, NtfSubSMPAction, NtfActionTs))
|
||||
getNtfSubAction connId = do
|
||||
markUpdatedByWorker db connId
|
||||
firstRow ntfSubAction err $
|
||||
@@ -1775,7 +1653,7 @@ getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize
|
||||
db
|
||||
[sql|
|
||||
SELECT c.user_id, s.ntf_host, s.ntf_port, s.ntf_key_hash,
|
||||
ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_smp_action
|
||||
ns.smp_ntf_id, ns.ntf_sub_id, ns.ntf_sub_status, ns.ntf_sub_action_ts, ns.ntf_sub_smp_action
|
||||
FROM ntf_subscriptions ns
|
||||
JOIN connections c USING (conn_id)
|
||||
JOIN ntf_servers s USING (ntf_host, ntf_port)
|
||||
@@ -1784,10 +1662,10 @@ getNextNtfSubSMPActions db smpServer@(SMPServer smpHost smpPort _) ntfBatchSize
|
||||
(Only connId)
|
||||
where
|
||||
err = SEInternal $ "ntf subscription " <> bshow connId <> " returned []"
|
||||
ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, action) =
|
||||
ntfSubAction (userId, ntfHost, ntfPort, ntfKeyHash, ntfQueueId, ntfSubId, ntfSubStatus, actionTs, action) =
|
||||
let ntfServer = NtfServer ntfHost ntfPort ntfKeyHash
|
||||
ntfSubscription = NtfSubscription {userId, connId, smpServer, ntfQueueId, ntfServer, ntfSubId, ntfSubStatus}
|
||||
in (action, ntfSubscription)
|
||||
in (ntfSubscription, action, actionTs)
|
||||
|
||||
markNtfSubActionSMPFailed_ :: DB.Connection -> ConnId -> IO ()
|
||||
markNtfSubActionSMPFailed_ db connId =
|
||||
@@ -1818,19 +1696,19 @@ getActiveNtfToken db =
|
||||
ntfMode = fromMaybe NMPeriodic ntfMode_
|
||||
in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode}
|
||||
|
||||
getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, RcvNtfDhSecret, Maybe UTCTime))
|
||||
getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, RcvNtfDhSecret))
|
||||
getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} =
|
||||
firstRow' res SEConnNotFound $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_id, rcv_ntf_dh_secret, last_broker_ts
|
||||
SELECT conn_id, rcv_ntf_dh_secret
|
||||
FROM rcv_queues
|
||||
WHERE host = ? AND port = ? AND ntf_id = ? AND deleted = 0
|
||||
|]
|
||||
(host, port, notifierId)
|
||||
where
|
||||
res (connId, Just rcvNtfDhSecret, lastBrokerTs_) = Right (connId, rcvNtfDhSecret, lastBrokerTs_)
|
||||
res (connId, Just rcvNtfDhSecret) = Right (connId, rcvNtfDhSecret)
|
||||
res _ = Left SEConnNotFound
|
||||
|
||||
setConnectionNtfs :: DB.Connection -> ConnId -> Bool -> IO ()
|
||||
@@ -1915,14 +1793,6 @@ instance ToField (Version v) where toField (Version v) = toField v
|
||||
|
||||
instance FromField (Version v) where fromField f = Version <$> fromField f
|
||||
|
||||
deriving newtype instance ToField EntityId
|
||||
|
||||
deriving newtype instance FromField EntityId
|
||||
|
||||
deriving newtype instance ToField ChunkReplicaId
|
||||
|
||||
deriving newtype instance FromField ChunkReplicaId
|
||||
|
||||
listToEither :: e -> [a] -> Either e a
|
||||
listToEither _ (x : _) = Right x
|
||||
listToEither e _ = Left e
|
||||
@@ -2039,11 +1909,9 @@ newQueueId_ (Only maxId : _) = DBQueueId (maxId + 1)
|
||||
|
||||
getConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
|
||||
getConn = getAnyConn False
|
||||
{-# INLINE getConn #-}
|
||||
|
||||
getDeletedConn :: DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
|
||||
getDeletedConn = getAnyConn True
|
||||
{-# INLINE getDeletedConn #-}
|
||||
|
||||
getAnyConn :: Bool -> DB.Connection -> ConnId -> IO (Either StoreError SomeConn)
|
||||
getAnyConn deleted' dbConn connId =
|
||||
@@ -2064,11 +1932,9 @@ getAnyConn deleted' dbConn connId =
|
||||
|
||||
getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
|
||||
getConns = getAnyConns_ False
|
||||
{-# INLINE getConns #-}
|
||||
|
||||
getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
|
||||
getDeletedConns = getAnyConns_ True
|
||||
{-# INLINE getDeletedConns #-}
|
||||
|
||||
getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
|
||||
getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db
|
||||
@@ -2101,10 +1967,6 @@ setConnDeleted db waitDelivery connId
|
||||
| otherwise =
|
||||
DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
|
||||
|
||||
setConnUserId :: DB.Connection -> UserId -> ConnId -> UserId -> IO ()
|
||||
setConnUserId db oldUserId connId newUserId =
|
||||
DB.execute db "UPDATE connections SET user_id = ? WHERE conn_id = ? and user_id = ?" (newUserId, connId, oldUserId)
|
||||
|
||||
setConnAgentVersion :: DB.Connection -> ConnId -> VersionSMPA -> IO ()
|
||||
setConnAgentVersion db connId aVersion =
|
||||
DB.execute db "UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?" (aVersion, connId)
|
||||
@@ -2317,9 +2179,9 @@ updateRcvMsgHash db connId sndMsgId internalRcvId internalHash =
|
||||
|
||||
-- * updateSndIds helpers
|
||||
|
||||
retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash))
|
||||
retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash)
|
||||
retrieveLastIdsAndHashSnd_ dbConn connId = do
|
||||
firstRow id SEConnNotFound $
|
||||
[(lastInternalId, lastInternalSndId, lastSndHash)] <-
|
||||
DB.queryNamed
|
||||
dbConn
|
||||
[sql|
|
||||
@@ -2328,6 +2190,7 @@ retrieveLastIdsAndHashSnd_ dbConn connId = do
|
||||
WHERE conn_id = :conn_id;
|
||||
|]
|
||||
[":conn_id" := connId]
|
||||
return (lastInternalId, lastInternalSndId, lastSndHash)
|
||||
|
||||
updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO ()
|
||||
updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId =
|
||||
@@ -2623,7 +2486,7 @@ deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO ()
|
||||
deleteRcvFile' db rcvFileId =
|
||||
DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId)
|
||||
|
||||
getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool, Maybe RcvFileId)))
|
||||
getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool)))
|
||||
getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do
|
||||
getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd)
|
||||
where
|
||||
@@ -2647,7 +2510,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
|
||||
LIMIT 1
|
||||
|]
|
||||
(host, port, keyHash, RFSReceiving, cutoffTs)
|
||||
getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool, Maybe RcvFileId))
|
||||
getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool))
|
||||
getChunkData (rcvFileChunkReplicaId, _fileId) =
|
||||
firstRow toChunk SEFileNotFound $
|
||||
DB.query
|
||||
@@ -2656,7 +2519,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
|
||||
SELECT
|
||||
f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path,
|
||||
r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries,
|
||||
f.approved_relays, f.redirect_entity_id
|
||||
f.approved_relays
|
||||
FROM rcv_file_chunk_replicas r
|
||||
JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
|
||||
JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
|
||||
@@ -2665,8 +2528,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
|
||||
|]
|
||||
(Only rcvFileChunkReplicaId)
|
||||
where
|
||||
toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. (Bool, Maybe RcvFileId)) -> (RcvFileChunk, Bool, Maybe RcvFileId)
|
||||
toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (approvedRelays, redirectEntityId_)) =
|
||||
toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. Only Bool) -> (RcvFileChunk, Bool)
|
||||
toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (Only approvedRelays)) =
|
||||
( RcvFileChunk
|
||||
{ rcvFileId,
|
||||
rcvFileEntityId,
|
||||
@@ -2679,8 +2542,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
|
||||
chunkTmpPath,
|
||||
replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}]
|
||||
},
|
||||
approvedRelays,
|
||||
redirectEntityId_
|
||||
approvedRelays
|
||||
)
|
||||
|
||||
getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile))
|
||||
|
||||
@@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
@@ -21,19 +20,15 @@ where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (when)
|
||||
import Control.Exception
|
||||
import qualified Data.Aeson.TH as J
|
||||
import Data.Int (Int64)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text (Text)
|
||||
import Data.Time (diffUTCTime, getCurrentTime)
|
||||
import Database.SQLite.Simple (FromRow, NamedParam, Query, ToRow)
|
||||
import qualified Database.SQLite.Simple as SQL
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (diffToMilliseconds, tshow)
|
||||
import Simplex.Messaging.Util (diffToMilliseconds)
|
||||
|
||||
data Connection = Connection
|
||||
{ conn :: SQL.Connection,
|
||||
@@ -43,35 +38,27 @@ data Connection = Connection
|
||||
data SlowQueryStats = SlowQueryStats
|
||||
{ count :: Int64,
|
||||
timeMax :: Int64,
|
||||
timeAvg :: Int64,
|
||||
errs :: Map Text Int
|
||||
timeAvg :: Int64
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
timeIt :: TMap Query SlowQueryStats -> Query -> IO a -> IO a
|
||||
timeIt slow sql a = do
|
||||
t <- getCurrentTime
|
||||
r <- a `catch` \e -> do
|
||||
atomically $ TM.alter (Just . updateQueryErrors e) sql slow
|
||||
throwIO e
|
||||
r <- a
|
||||
t' <- getCurrentTime
|
||||
let diff = diffToMilliseconds $ diffUTCTime t' t
|
||||
when (diff > 1) $ atomically $ TM.alter (updateQueryStats diff) sql slow
|
||||
atomically $ when (diff > 5) $ TM.alter (updateQueryStats diff) sql slow
|
||||
pure r
|
||||
where
|
||||
updateQueryErrors :: SomeException -> Maybe SlowQueryStats -> SlowQueryStats
|
||||
updateQueryErrors e Nothing = SlowQueryStats 0 0 0 $ M.singleton (tshow e) 1
|
||||
updateQueryErrors e (Just stats@SlowQueryStats {errs}) =
|
||||
stats {errs = M.alter (Just . maybe 1 (+ 1)) (tshow e) errs}
|
||||
updateQueryStats :: Int64 -> Maybe SlowQueryStats -> Maybe SlowQueryStats
|
||||
updateQueryStats diff Nothing = Just $ SlowQueryStats 1 diff diff M.empty
|
||||
updateQueryStats diff (Just SlowQueryStats {count, timeMax, timeAvg, errs}) =
|
||||
updateQueryStats diff Nothing = Just $ SlowQueryStats 1 diff diff
|
||||
updateQueryStats diff (Just SlowQueryStats {count, timeMax, timeAvg}) =
|
||||
Just $
|
||||
SlowQueryStats
|
||||
{ count = count + 1,
|
||||
timeMax = max timeMax diff,
|
||||
timeAvg = (timeAvg * count + diff) `div` (count + 1),
|
||||
errs
|
||||
timeAvg = (timeAvg * count + diff) `div` (count + 1)
|
||||
}
|
||||
|
||||
open :: String -> IO Connection
|
||||
|
||||
@@ -29,7 +29,7 @@ import Control.Monad (forM_, when)
|
||||
import qualified Data.Aeson.TH as J
|
||||
import Data.List (intercalate, sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (isNothing, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
@@ -74,8 +74,6 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
@@ -118,9 +116,7 @@ schemaMigrations =
|
||||
("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem),
|
||||
("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays),
|
||||
("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure),
|
||||
("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats),
|
||||
("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete),
|
||||
("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts)
|
||||
("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -1,27 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_delete where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20240930_ntf_tokens_to_delete :: Query
|
||||
m20240930_ntf_tokens_to_delete =
|
||||
[sql|
|
||||
CREATE TABLE ntf_tokens_to_delete (
|
||||
ntf_token_to_delete_id INTEGER PRIMARY KEY,
|
||||
ntf_host TEXT NOT NULL,
|
||||
ntf_port TEXT NOT NULL,
|
||||
ntf_key_hash BLOB NOT NULL,
|
||||
tkn_id BLOB NOT NULL, -- token ID assigned by notifications server
|
||||
tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands,
|
||||
del_failed INTEGER DEFAULT 0,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|]
|
||||
|
||||
down_m20240930_ntf_tokens_to_delete :: Query
|
||||
down_m20240930_ntf_tokens_to_delete =
|
||||
[sql|
|
||||
DROP TABLE ntf_tokens_to_delete;
|
||||
|]
|
||||
-18
@@ -1,18 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20241007_rcv_queues_last_broker_ts :: Query
|
||||
m20241007_rcv_queues_last_broker_ts =
|
||||
[sql|
|
||||
ALTER TABLE rcv_queues ADD COLUMN last_broker_ts TEXT;
|
||||
|]
|
||||
|
||||
down_m20241007_rcv_queues_last_broker_ts :: Query
|
||||
down_m20241007_rcv_queues_last_broker_ts =
|
||||
[sql|
|
||||
ALTER TABLE rcv_queues DROP COLUMN last_broker_ts;
|
||||
|]
|
||||
@@ -1 +0,0 @@
|
||||
CREATE INDEX 'ratchets_conn_id' ON 'ratchets'('conn_id'); --> connections(conn_id)
|
||||
@@ -56,7 +56,6 @@ CREATE TABLE rcv_queues(
|
||||
switch_status TEXT,
|
||||
deleted INTEGER NOT NULL DEFAULT 0,
|
||||
snd_secure INTEGER NOT NULL DEFAULT 0,
|
||||
last_broker_ts TEXT,
|
||||
PRIMARY KEY(host, port, rcv_id),
|
||||
FOREIGN KEY(host, port) REFERENCES servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE,
|
||||
@@ -404,16 +403,6 @@ CREATE TABLE servers_stats(
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE ntf_tokens_to_delete(
|
||||
ntf_token_to_delete_id INTEGER PRIMARY KEY,
|
||||
ntf_host TEXT NOT NULL,
|
||||
ntf_port TEXT NOT NULL,
|
||||
ntf_key_hash BLOB NOT NULL,
|
||||
tkn_id BLOB NOT NULL, -- token ID assigned by notifications server
|
||||
tkn_priv_key BLOB NOT NULL, -- client's private key to sign token commands,
|
||||
del_failed INTEGER DEFAULT 0,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
|
||||
CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
|
||||
CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
|
||||
|
||||
@@ -31,7 +31,7 @@ import Simplex.Messaging.Transport
|
||||
|
||||
class Queue q where
|
||||
connId' :: q -> ConnId
|
||||
qKey :: q -> (UserId, SMPServer, RecipientId)
|
||||
qKey :: q -> (UserId, SMPServer, ConnId)
|
||||
|
||||
-- the fields in this record have the same data with swapped keys for lookup efficiency,
|
||||
-- and all methods must maintain this invariant.
|
||||
@@ -63,7 +63,7 @@ addQueue rq (TRcvQueues qs cs) = do
|
||||
addQ = Just . maybe (k :| []) (k <|)
|
||||
k = qKey rq
|
||||
|
||||
-- Save time by aggregating modifyTVar'
|
||||
-- Save time by aggregating modifyTVar
|
||||
batchAddQueues :: (Foldable t, Queue q) => TRcvQueues q -> t q -> STM ()
|
||||
batchAddQueues (TRcvQueues qs cs) rqs = do
|
||||
modifyTVar' qs $ \now -> foldl' (\rqs' rq -> M.insert (qKey rq) rq rqs') now rqs
|
||||
@@ -97,7 +97,7 @@ getDelSessQueues tSess sessId' (TRcvQueues qs cs) = do
|
||||
delQ acc@(removed, qs') (sessId, rq)
|
||||
| rq `isSession` tSess && sessId == sessId' = (rq : removed, M.delete (qKey rq) qs')
|
||||
| otherwise = acc
|
||||
delConn :: ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, RecipientId))) -> RcvQueue -> ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, RecipientId)))
|
||||
delConn :: ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, ConnId))) -> RcvQueue -> ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, ConnId)))
|
||||
delConn (removed, cs') rq = M.alterF f cId cs'
|
||||
where
|
||||
cId = connId rq
|
||||
@@ -113,7 +113,7 @@ isSession rq (uId, srv, connId_) =
|
||||
|
||||
instance Queue RcvQueue where
|
||||
connId' = connId
|
||||
qKey rq = (userId rq, server rq, rcvId rq)
|
||||
qKey rq = (userId rq, server rq, connId rq)
|
||||
|
||||
instance Queue (SessionId, RcvQueue) where
|
||||
connId' = connId . snd
|
||||
|
||||
@@ -63,13 +63,11 @@ module Simplex.Messaging.Client
|
||||
forwardSMPTransmission,
|
||||
getSMPQueueInfo,
|
||||
sendProtocolCommand,
|
||||
sendProtocolCommands,
|
||||
|
||||
-- * Supporting types and client configuration
|
||||
ProtocolClientError (..),
|
||||
SMPClientError,
|
||||
ProxyClientError (..),
|
||||
Response (..),
|
||||
unexpectedResponse,
|
||||
ProtocolClientConfig (..),
|
||||
NetworkConfig (..),
|
||||
@@ -82,11 +80,10 @@ module Simplex.Messaging.Client
|
||||
defaultSMPClientConfig,
|
||||
defaultNetworkConfig,
|
||||
transportClientConfig,
|
||||
clientSocksCredentials,
|
||||
chooseTransportHost,
|
||||
proxyUsername,
|
||||
temporaryClientError,
|
||||
smpProxyError,
|
||||
textToHostMode,
|
||||
ServerTransmissionBatch,
|
||||
ServerTransmission (..),
|
||||
ClientCommand,
|
||||
@@ -119,20 +116,16 @@ import qualified Data.Aeson.TH as J
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime)
|
||||
import qualified Data.X509 as X
|
||||
import qualified Data.X509.Validation as XV
|
||||
import Network.Socket (ServiceName)
|
||||
import Network.Socks5 (SocksCredentials (..))
|
||||
import Numeric.Natural
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
@@ -143,7 +136,7 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient)
|
||||
import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient)
|
||||
import Simplex.Messaging.Transport.KeepAlive
|
||||
import Simplex.Messaging.Transport.WebSockets (WS)
|
||||
import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM)
|
||||
@@ -199,7 +192,6 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
thAuth,
|
||||
blockSize = smpBlockSize,
|
||||
implySessId = thVersion >= authCmdsSMPVersion,
|
||||
encryptBlock = Nothing,
|
||||
batch = True
|
||||
},
|
||||
sessionTs = ts,
|
||||
@@ -244,12 +236,6 @@ data HostMode
|
||||
HMPublic
|
||||
deriving (Eq, Show)
|
||||
|
||||
textToHostMode :: Text -> Either String HostMode
|
||||
textToHostMode = \case
|
||||
"public" -> Right HMPublic
|
||||
"onion" -> Right HMOnionViaSocks
|
||||
s -> Left $ T.unpack $ "Invalid host_mode: " <> s
|
||||
|
||||
data SocksMode
|
||||
= -- | always use SOCKS proxy when enabled
|
||||
SMAlways
|
||||
@@ -271,7 +257,7 @@ instance StrEncoding SocksMode where
|
||||
-- | network configuration for the client
|
||||
data NetworkConfig = NetworkConfig
|
||||
{ -- | use SOCKS5 proxy
|
||||
socksProxy :: Maybe SocksProxyWithAuth,
|
||||
socksProxy :: Maybe SocksProxy,
|
||||
-- | when to use SOCKS proxy
|
||||
socksMode :: SocksMode,
|
||||
-- | determines critera which host is chosen from the list
|
||||
@@ -284,8 +270,6 @@ data NetworkConfig = NetworkConfig
|
||||
smpProxyMode :: SMPProxyMode,
|
||||
-- | Fallback to direct connection when destination SMP relay does not support SMP proxy protocol extensions
|
||||
smpProxyFallback :: SMPProxyFallback,
|
||||
-- | use web port 443 for SMP protocol
|
||||
smpWebPort :: Bool,
|
||||
-- | timeout for the initial client TCP/TLS connection (microseconds)
|
||||
tcpConnectTimeout :: Int,
|
||||
-- | timeout of protocol commands (microseconds)
|
||||
@@ -304,7 +288,7 @@ data NetworkConfig = NetworkConfig
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data TransportSessionMode = TSMUser | TSMSession | TSMServer | TSMEntity
|
||||
data TransportSessionMode = TSMUser | TSMEntity
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- SMP proxy mode for sending messages
|
||||
@@ -354,10 +338,9 @@ defaultNetworkConfig =
|
||||
socksMode = SMAlways,
|
||||
hostMode = HMOnionViaSocks,
|
||||
requiredHostMode = False,
|
||||
sessionMode = TSMSession,
|
||||
sessionMode = TSMUser,
|
||||
smpProxyMode = SPMNever,
|
||||
smpProxyFallback = SPFAllow,
|
||||
smpWebPort = False,
|
||||
tcpConnectTimeout = defaultTcpConnectTimeout,
|
||||
tcpTimeout = 15_000_000,
|
||||
tcpTimeoutPerKb = 5_000,
|
||||
@@ -368,31 +351,15 @@ defaultNetworkConfig =
|
||||
logTLSErrors = False
|
||||
}
|
||||
|
||||
transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> TransportClientConfig
|
||||
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI =
|
||||
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing, useSNI}
|
||||
transportClientConfig :: NetworkConfig -> TransportHost -> TransportClientConfig
|
||||
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host =
|
||||
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
|
||||
where
|
||||
socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
|
||||
useSocksProxy SMAlways = socksProxy'
|
||||
useSocksProxy SMAlways = socksProxy
|
||||
useSocksProxy SMOnion = case host of
|
||||
THOnionHost _ -> socksProxy'
|
||||
THOnionHost _ -> socksProxy
|
||||
_ -> Nothing
|
||||
|
||||
clientSocksCredentials :: ProtocolTypeI (ProtoType msg) => NetworkConfig -> UTCTime -> TransportSession msg -> Maybe SocksCredentials
|
||||
clientSocksCredentials NetworkConfig {socksProxy, sessionMode} proxySessTs (userId, srv, entityId_) = case socksProxy of
|
||||
Just (SocksProxyWithAuth auth _) -> case auth of
|
||||
SocksAuthUsername {username, password} -> Just $ SocksCredentials username password
|
||||
SocksAuthNull -> Nothing
|
||||
SocksIsolateByAuth -> Just $ SocksCredentials sessionUsername ""
|
||||
Nothing -> Nothing
|
||||
where
|
||||
sessionUsername =
|
||||
B64.encode $ C.sha256Hash $
|
||||
bshow userId <> case sessionMode of
|
||||
TSMUser -> ""
|
||||
TSMSession -> ":" <> bshow proxySessTs
|
||||
TSMServer -> ":" <> bshow proxySessTs <> "@" <> strEncode srv
|
||||
TSMEntity -> ":" <> bshow proxySessTs <> "@" <> strEncode srv <> maybe "" ("/" <>) entityId_
|
||||
{-# INLINE transportClientConfig #-}
|
||||
|
||||
-- | protocol client configuration.
|
||||
data ProtocolClientConfig v = ProtocolClientConfig
|
||||
@@ -406,31 +373,24 @@ data ProtocolClientConfig v = ProtocolClientConfig
|
||||
-- | client-server protocol version range
|
||||
serverVRange :: VersionRange v,
|
||||
-- | agree shared session secret (used in SMP proxy for additional encryption layer)
|
||||
agreeSecret :: Bool,
|
||||
-- | send SNI to server, False for SMP
|
||||
useSNI :: Bool
|
||||
agreeSecret :: Bool
|
||||
}
|
||||
|
||||
-- | Default protocol client configuration.
|
||||
defaultClientConfig :: Maybe [ALPN] -> Bool -> VersionRange v -> ProtocolClientConfig v
|
||||
defaultClientConfig clientALPN useSNI serverVRange =
|
||||
defaultClientConfig :: Maybe [ALPN] -> VersionRange v -> ProtocolClientConfig v
|
||||
defaultClientConfig clientALPN serverVRange =
|
||||
ProtocolClientConfig
|
||||
{ qSize = 64,
|
||||
defaultTransport = ("443", transport @TLS),
|
||||
networkConfig = defaultNetworkConfig,
|
||||
clientALPN,
|
||||
serverVRange,
|
||||
agreeSecret = False,
|
||||
useSNI
|
||||
agreeSecret = False
|
||||
}
|
||||
{-# INLINE defaultClientConfig #-}
|
||||
|
||||
defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
|
||||
defaultSMPClientConfig =
|
||||
(defaultClientConfig (Just supportedSMPHandshakes) False supportedClientSMPRelayVRange)
|
||||
{ defaultTransport = (show defaultSMPPort, transport @TLS),
|
||||
agreeSecret = True
|
||||
}
|
||||
defaultSMPClientConfig = defaultClientConfig (Just supportedSMPHandshakes) supportedClientSMPRelayVRange
|
||||
{-# INLINE defaultSMPClientConfig #-}
|
||||
|
||||
data Request err msg = Request
|
||||
@@ -481,23 +441,22 @@ transportSession' = transportSession . client_
|
||||
type UserId = Int64
|
||||
|
||||
-- | Transport session key - includes entity ID if `sessionMode = TSMEntity`.
|
||||
-- Please note that for SMP connection ID is used as entity ID, not queue ID.
|
||||
type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
|
||||
type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
|
||||
|
||||
-- | Connects to 'ProtocolServer' using passed client configuration
|
||||
-- and queue for messages and notifications.
|
||||
--
|
||||
-- A single queue can be used for multiple 'SMPClient' instances,
|
||||
-- as 'SMPServerTransmission' includes server information.
|
||||
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, useSNI} msgQ proxySessTs disconnected = do
|
||||
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do
|
||||
case chooseTransportHost networkConfig (host srv) of
|
||||
Right useHost ->
|
||||
(getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
|
||||
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
|
||||
Left e -> pure $ Left e
|
||||
where
|
||||
NetworkConfig {smpWebPort, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
|
||||
NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
|
||||
mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
|
||||
mkProtocolClient transportHost ts = do
|
||||
connected <- newTVarIO False
|
||||
@@ -528,10 +487,10 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
runClient :: (ServiceName, ATransport) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
runClient (port', ATransport t) useHost c = do
|
||||
cVar <- newEmptyTMVarIO
|
||||
let tcConfig = (transportClientConfig networkConfig useHost useSNI) {alpn = clientALPN}
|
||||
socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
|
||||
let tcConfig = (transportClientConfig networkConfig useHost) {alpn = clientALPN}
|
||||
username = proxyUsername transportSession
|
||||
tId <-
|
||||
runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
|
||||
runTransportClient tcConfig (Just username) useHost port' (Just $ keyHash srv) (client t c cVar)
|
||||
`forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError)
|
||||
c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
|
||||
case c_ of
|
||||
@@ -541,9 +500,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
|
||||
useTransport :: (ServiceName, ATransport)
|
||||
useTransport = case port srv of
|
||||
"" -> case protocolTypeI @(ProtoType msg) of
|
||||
SPSMP | smpWebPort -> ("443", transport @TLS)
|
||||
_ -> defaultTransport cfg
|
||||
"" -> defaultTransport cfg
|
||||
"80" -> ("80", transport @WS)
|
||||
p -> (p, transport @TLS)
|
||||
|
||||
@@ -587,7 +544,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
if remaining > 1_000_000 -- delay pings only for significant time
|
||||
then loop remaining
|
||||
else do
|
||||
whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing NoEntity (protocolPing @v @err @msg)
|
||||
whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing "" (protocolPing @v @err @msg)
|
||||
-- sendProtocolCommand/getResponse updates counter for each command
|
||||
cnt <- readTVarIO timeoutErrorCount
|
||||
-- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response
|
||||
@@ -639,6 +596,10 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
unexpectedResponse :: Show r => r -> ProtocolClientError err
|
||||
unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show
|
||||
|
||||
proxyUsername :: TransportSession msg -> ByteString
|
||||
proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
|
||||
{-# INLINE proxyUsername #-}
|
||||
|
||||
-- | Disconnects client from the server and terminates client threads.
|
||||
closeProtocolClient :: ProtocolClient v err msg -> IO ()
|
||||
closeProtocolClient = mapM_ (deRefWeak >=> mapM_ killThread) . action
|
||||
@@ -709,7 +670,7 @@ createSMPQueue ::
|
||||
Bool ->
|
||||
ExceptT SMPClientError IO QueueIdsKeys
|
||||
createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure =
|
||||
sendSMPCommand c (Just rpKey) NoEntity (NEW rKey dhKey auth subMode sndSecure) >>= \case
|
||||
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode sndSecure) >>= \case
|
||||
IDS qik -> pure qik
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
@@ -717,8 +678,8 @@ createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure =
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
|
||||
subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
subscribeSMPQueue c rpKey rId = do
|
||||
liftIO $ enablePings c
|
||||
subscribeSMPQueue c@ProtocolClient {client_ = PClient {sendPings}} rpKey rId = do
|
||||
liftIO . atomically $ writeTVar sendPings True
|
||||
sendSMPCommand c (Just rpKey) rId SUB >>= \case
|
||||
OK -> pure ()
|
||||
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
|
||||
@@ -726,8 +687,8 @@ subscribeSMPQueue c rpKey rId = do
|
||||
|
||||
-- | Subscribe to multiple SMP queues batching commands if supported.
|
||||
subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
subscribeSMPQueues c qs = do
|
||||
liftIO $ enablePings c
|
||||
subscribeSMPQueues c@ProtocolClient {client_ = PClient {sendPings}} qs = do
|
||||
atomically $ writeTVar sendPings True
|
||||
sendProtocolCommands c cs >>= mapM (processSUBResponse c)
|
||||
where
|
||||
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
|
||||
@@ -766,22 +727,14 @@ getSMPMessage c rpKey rId =
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
|
||||
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO ()
|
||||
subscribeSMPQueueNotifications c npKey nId = do
|
||||
liftIO $ enablePings c
|
||||
okSMPCommand NSUB c npKey nId
|
||||
subscribeSMPQueueNotifications = okSMPCommand NSUB
|
||||
{-# INLINE subscribeSMPQueueNotifications #-}
|
||||
|
||||
-- | Subscribe to multiple SMP queues notifications batching commands if supported.
|
||||
subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateAuthKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
subscribeSMPQueuesNtfs c qs = do
|
||||
liftIO $ enablePings c
|
||||
okSMPCommands NSUB c qs
|
||||
subscribeSMPQueuesNtfs = okSMPCommands NSUB
|
||||
{-# INLINE subscribeSMPQueuesNtfs #-}
|
||||
|
||||
enablePings :: SMPClient -> IO ()
|
||||
enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeTVar sendPings True
|
||||
{-# INLINE enablePings #-}
|
||||
|
||||
-- | Secure the SMP queue by adding a sender public key.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
|
||||
@@ -876,7 +829,7 @@ deleteSMPQueues = okSMPCommands DEL
|
||||
connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
|
||||
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
|
||||
| thVersion (thParams c) >= sendingProxySMPVersion =
|
||||
sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
|
||||
sendProtocolCommand_ c Nothing tOut Nothing "" (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
|
||||
PKEY sId vr (chain, key) ->
|
||||
case supportedClientSMPRelayVRange `compatibleVersion` vr of
|
||||
Nothing -> throwE $ transportErr TEVersion
|
||||
@@ -978,7 +931,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
|
||||
et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength
|
||||
-- proxy interaction errors are wrapped
|
||||
let tOut = Just $ 2 * tcpTimeout
|
||||
tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
|
||||
tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing sessionId (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
|
||||
Right r -> case r of
|
||||
PRES (EncResponse er) -> do
|
||||
-- server interaction errors are thrown directly
|
||||
@@ -1014,7 +967,7 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
|
||||
let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission}
|
||||
eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT)
|
||||
-- send
|
||||
sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SSender (RFWD eft)) >>= \case
|
||||
sendProtocolCommand_ c (Just nonce) Nothing Nothing "" (Cmd SSender (RFWD eft)) >>= \case
|
||||
RRES (EncFwdResponse efr) -> do
|
||||
-- unwrap
|
||||
r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
|
||||
@@ -1062,7 +1015,7 @@ sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSiz
|
||||
| diff == 0 = pure $ L.fromList rs
|
||||
| diff > 0 = do
|
||||
putStrLn "send error: fewer responses than expected"
|
||||
pure $ L.fromList $ rs <> replicate diff (Response NoEntity $ Left $ PCETransportError TEBadBlock)
|
||||
pure $ L.fromList $ rs <> replicate diff (Response "" $ Left $ PCETransportError TEBadBlock)
|
||||
| otherwise = do
|
||||
putStrLn "send error: more responses than expected"
|
||||
pure $ L.fromList $ take (L.length cs) rs
|
||||
|
||||
@@ -76,7 +76,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
|
||||
defaultSMPClientAgentConfig :: SMPClientAgentConfig
|
||||
defaultSMPClientAgentConfig =
|
||||
SMPClientAgentConfig
|
||||
{ smpCfg = defaultSMPClientConfig,
|
||||
{ smpCfg = defaultSMPClientConfig {defaultTransport = ("5223", transport @TLS)},
|
||||
reconnectInterval =
|
||||
RetryInterval
|
||||
{ initialInterval = second,
|
||||
@@ -84,8 +84,8 @@ defaultSMPClientAgentConfig =
|
||||
maxInterval = 10 * second
|
||||
},
|
||||
persistErrorInterval = 30, -- seconds
|
||||
msgQSize = 2048,
|
||||
agentQSize = 2048,
|
||||
msgQSize = 1024,
|
||||
agentQSize = 1024,
|
||||
agentSubsBatchSize = 1360,
|
||||
ownServerDomains = []
|
||||
}
|
||||
@@ -95,7 +95,6 @@ defaultSMPClientAgentConfig =
|
||||
data SMPClientAgent = SMPClientAgent
|
||||
{ agentCfg :: SMPClientAgentConfig,
|
||||
active :: TVar Bool,
|
||||
startedAt :: UTCTime,
|
||||
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
|
||||
agentQ :: TBQueue SMPClientAgentEvent,
|
||||
randomDrg :: TVar ChaChaDRG,
|
||||
@@ -112,7 +111,6 @@ type OwnServer = Bool
|
||||
newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO SMPClientAgent
|
||||
newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
|
||||
active <- newTVarIO True
|
||||
startedAt <- getCurrentTime
|
||||
msgQ <- newTBQueueIO msgQSize
|
||||
agentQ <- newTBQueueIO agentQSize
|
||||
smpClients <- TM.emptyIO
|
||||
@@ -125,7 +123,6 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg
|
||||
SMPClientAgent
|
||||
{ agentCfg,
|
||||
active,
|
||||
startedAt,
|
||||
msgQ,
|
||||
agentQ,
|
||||
randomDrg,
|
||||
@@ -197,8 +194,8 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
|
||||
|
||||
-- | Run an SMP client for SMPClientVar
|
||||
connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
|
||||
connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
|
||||
getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) startedAt clientDisconnected
|
||||
connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg} srv v =
|
||||
getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
|
||||
where
|
||||
clientDisconnected :: SMPClient -> IO ()
|
||||
clientDisconnected smp = do
|
||||
@@ -375,15 +372,13 @@ smpSubscribeQueues party ca smp srv subs = do
|
||||
notify_ :: (SMPServer -> SMPSubParty -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO ()
|
||||
notify_ evt qs = mapM_ (notify ca . evt srv party) $ L.nonEmpty qs
|
||||
|
||||
activeClientSession' :: SMPClientAgent -> SessionId -> SMPServer -> STM Bool
|
||||
activeClientSession' ca sessId srv = sameSess <$> tryReadSessVar srv (smpClients ca)
|
||||
where
|
||||
sameSess = \case
|
||||
Just (Right (_, smp')) -> sessId == sessionId (thParams smp')
|
||||
_ -> False
|
||||
|
||||
activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool
|
||||
activeClientSession ca = activeClientSession' ca . sessionId . thParams
|
||||
activeClientSession ca smp srv = sameSess <$> tryReadSessVar srv (smpClients ca)
|
||||
where
|
||||
sessId = sessionId . thParams
|
||||
sameSess = \case
|
||||
Just (Right (_, smp')) -> sessId smp == sessId smp'
|
||||
_ -> False
|
||||
|
||||
showServer :: SMPServer -> ByteString
|
||||
showServer ProtocolServer {host, port} =
|
||||
|
||||
@@ -152,12 +152,6 @@ module Simplex.Messaging.Crypto
|
||||
unsafeSbKey,
|
||||
randomSbKey,
|
||||
|
||||
-- * secret_box chains
|
||||
SbChainKey,
|
||||
SbKeyNonce,
|
||||
sbcInit,
|
||||
sbcHkdf,
|
||||
|
||||
-- * pseudo-random bytes
|
||||
randomBytes,
|
||||
|
||||
@@ -204,7 +198,6 @@ import qualified Crypto.Cipher.Types as AES
|
||||
import qualified Crypto.Cipher.XSalsa as XSalsa
|
||||
import qualified Crypto.Error as CE
|
||||
import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize)
|
||||
import qualified Crypto.KDF.HKDF as H
|
||||
import qualified Crypto.MAC.Poly1305 as Poly1305
|
||||
import qualified Crypto.PubKey.Curve25519 as X25519
|
||||
import qualified Crypto.PubKey.Curve448 as X448
|
||||
@@ -1341,26 +1334,6 @@ unsafeSbKey s = either error id $ sbKey s
|
||||
randomSbKey :: TVar ChaChaDRG -> STM SbKey
|
||||
randomSbKey gVar = SecretBoxKey <$> randomBytes 32 gVar
|
||||
|
||||
newtype SbChainKey = SecretBoxChainKey {unSbChainKey :: ByteString}
|
||||
deriving (Eq, Show)
|
||||
|
||||
sbcInit :: ByteArrayAccess secret => ByteString -> secret -> (SbChainKey, SbChainKey)
|
||||
sbcInit salt secret = (SecretBoxChainKey ck1, SecretBoxChainKey ck2)
|
||||
where
|
||||
prk = H.extract salt secret :: H.PRK SHA512
|
||||
out = H.expand prk ("SimpleXSbChainInit" :: ByteString) 64
|
||||
(ck1, ck2) = B.splitAt 32 out
|
||||
|
||||
type SbKeyNonce = (SbKey, CbNonce)
|
||||
|
||||
sbcHkdf :: SbChainKey -> (SbKeyNonce, SbChainKey)
|
||||
sbcHkdf (SecretBoxChainKey ck) = ((SecretBoxKey sk, CryptoBoxNonce nonce), SecretBoxChainKey ck')
|
||||
where
|
||||
prk = H.extract B.empty ck :: H.PRK SHA512
|
||||
out = H.expand prk ("SimpleXSbChain" :: ByteString) 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce)
|
||||
(ck', rest) = B.splitAt 32 out
|
||||
(sk, nonce) = B.splitAt 32 rest
|
||||
|
||||
xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString)
|
||||
xSalsa20 secret nonce msg = (rs, msg')
|
||||
where
|
||||
|
||||
@@ -17,8 +17,6 @@ module Simplex.Messaging.Crypto.Lazy
|
||||
kcbEncryptTailTag,
|
||||
sbDecryptTailTag,
|
||||
kcbDecryptTailTag,
|
||||
sbEncryptTailTagNoPad,
|
||||
sbDecryptTailTagNoPad,
|
||||
fastReplicate,
|
||||
secretBox,
|
||||
secretBoxTailTag,
|
||||
@@ -51,7 +49,7 @@ import Data.Composition ((.:.))
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Foreign (sizeOf)
|
||||
import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, SbKeyNonce, pattern CbNonce, pattern SbKey)
|
||||
import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey)
|
||||
import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret (..))
|
||||
import Simplex.Messaging.Encoding
|
||||
|
||||
@@ -144,10 +142,6 @@ sbEncryptTailTag_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString ->
|
||||
sbEncryptTailTag_ key (CbNonce nonce) msg len paddedLen =
|
||||
LB.fromChunks <$> (secretBoxTailTag sbEncryptChunk key nonce =<< pad msg len paddedLen)
|
||||
|
||||
sbEncryptTailTagNoPad :: SbKeyNonce -> LazyByteString -> Either CryptoError LazyByteString
|
||||
sbEncryptTailTagNoPad (SbKey key, CbNonce nonce) msg =
|
||||
LB.fromChunks <$> secretBoxTailTag sbEncryptChunk key nonce msg
|
||||
|
||||
-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files).
|
||||
-- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag.
|
||||
sbDecryptTailTag :: SbKey -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString)
|
||||
@@ -171,15 +165,6 @@ sbDecryptTailTag_ key (CbNonce nonce) paddedLen packet =
|
||||
where
|
||||
(c, tag') = LB.splitAt paddedLen packet
|
||||
|
||||
sbDecryptTailTagNoPad :: SbKeyNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString)
|
||||
sbDecryptTailTagNoPad (SbKey key, CbNonce nonce) paddedLen packet =
|
||||
result <$> secretBox sbDecryptChunk key nonce c
|
||||
where
|
||||
result (tag :| cs) =
|
||||
let valid = LB.length tag' == 16 && BA.constEq (LB.toStrict tag') tag
|
||||
in (valid, LB.fromChunks cs)
|
||||
(c, tag') = LB.splitAt paddedLen packet
|
||||
|
||||
secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString]
|
||||
secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
|
||||
where
|
||||
|
||||
@@ -4,7 +4,7 @@
|
||||
|
||||
module Simplex.Messaging.Crypto.SNTRUP761 where
|
||||
|
||||
import Crypto.Hash (Digest, SHA3_256, hash)
|
||||
import Crypto.Hash (Digest, SHA256, hash)
|
||||
import Data.ByteArray (ScrubbedBytes)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
@@ -28,4 +28,4 @@ kcbEncrypt (KEMHybridSecret k) = sbEncrypt_ k
|
||||
kemHybridSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> KEMSharedKey -> KEMHybridSecret
|
||||
kemHybridSecret k pk (KEMSharedKey kem) =
|
||||
let DhSecretX25519 dh = C.dh' k pk
|
||||
in KEMHybridSecret $ BA.convert (hash $ BA.convert dh <> kem :: Digest SHA3_256)
|
||||
in KEMHybridSecret $ BA.convert (hash $ BA.convert dh <> kem :: Digest SHA256)
|
||||
|
||||
@@ -42,12 +42,10 @@ class Encoding a where
|
||||
-- | decoding of type (default implementation uses parser)
|
||||
smpDecode :: ByteString -> Either String a
|
||||
smpDecode = parseAll smpP
|
||||
{-# INLINE smpDecode #-}
|
||||
|
||||
-- | protocol parser of type (default implementation parses protocol ByteString encoding)
|
||||
smpP :: Parser a
|
||||
smpP = smpDecode <$?> smpP
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
instance Encoding Char where
|
||||
smpEncode = B.singleton
|
||||
|
||||
@@ -28,8 +28,6 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isAlphaNum)
|
||||
import Data.Int (Int64)
|
||||
import Data.IntSet (IntSet)
|
||||
import qualified Data.IntSet as IS
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
@@ -41,7 +39,7 @@ import Data.Time.Format.ISO8601
|
||||
import Data.Word (Word16, Word32)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (bshow, (<$?>))
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
class TextEncoding a where
|
||||
textEncode :: a -> Text
|
||||
@@ -55,20 +53,14 @@ class StrEncoding a where
|
||||
-- Please note - if you only specify strDecode, it will use base64urlP as default parser before decoding the string
|
||||
strDecode :: ByteString -> Either String a
|
||||
strDecode = parseAll strP
|
||||
{-# INLINE strDecode #-}
|
||||
|
||||
strP :: Parser a
|
||||
strP = strDecode <$?> base64urlP
|
||||
{-# INLINE strP #-}
|
||||
|
||||
-- base64url encoding/decoding of ByteStrings - the parser only allows non-empty strings
|
||||
instance StrEncoding ByteString where
|
||||
strEncode = U.encode
|
||||
{-# INLINE strEncode #-}
|
||||
strDecode = U.decode
|
||||
{-# INLINE strDecode #-}
|
||||
strP = base64urlP
|
||||
{-# INLINE strP #-}
|
||||
|
||||
base64urlP :: Parser ByteString
|
||||
base64urlP = do
|
||||
@@ -127,15 +119,15 @@ instance StrEncoding Bool where
|
||||
{-# INLINE strP #-}
|
||||
|
||||
instance StrEncoding Int where
|
||||
strEncode = bshow
|
||||
strEncode = B.pack . show
|
||||
{-# INLINE strEncode #-}
|
||||
strP = A.signed A.decimal
|
||||
strP = A.decimal
|
||||
{-# INLINE strP #-}
|
||||
|
||||
instance StrEncoding Int64 where
|
||||
strEncode = bshow
|
||||
strEncode = B.pack . show
|
||||
{-# INLINE strEncode #-}
|
||||
strP = A.signed A.decimal
|
||||
strP = A.decimal
|
||||
{-# INLINE strP #-}
|
||||
|
||||
instance StrEncoding SystemTime where
|
||||
@@ -162,10 +154,6 @@ instance (StrEncoding a, Ord a) => StrEncoding (Set a) where
|
||||
strEncode = strEncodeList . S.toList
|
||||
strP = S.fromList <$> listItem `A.sepBy'` A.char ','
|
||||
|
||||
instance StrEncoding IntSet where
|
||||
strEncode = strEncodeList . IS.toList
|
||||
strP = IS.fromList <$> listItem `A.sepBy'` A.char ','
|
||||
|
||||
listItem :: StrEncoding a => Parser a
|
||||
listItem = parseAll strP <$?> A.takeTill (\c -> c == ',' || c == ' ' || c == '\n')
|
||||
|
||||
|
||||
@@ -1,36 +1,28 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Client where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Word (Word16)
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes)
|
||||
import Simplex.Messaging.Protocol (ErrorType, pattern NoEntity)
|
||||
import Simplex.Messaging.Transport (TLS, Transport (..))
|
||||
import Simplex.Messaging.Protocol (ErrorType)
|
||||
|
||||
type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse
|
||||
|
||||
type NtfClientError = ProtocolClientError ErrorType
|
||||
|
||||
defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
|
||||
defaultNTFClientConfig =
|
||||
(defaultClientConfig (Just supportedNTFHandshakes) False supportedClientNTFVRange)
|
||||
{defaultTransport = ("443", transport @TLS)}
|
||||
{-# INLINE defaultNTFClientConfig #-}
|
||||
defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) supportedClientNTFVRange
|
||||
|
||||
ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
|
||||
ntfRegisterToken c pKey newTkn =
|
||||
sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case
|
||||
sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
|
||||
NRTknId tknId dhKey -> pure (tknId, dhKey)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
@@ -54,34 +46,16 @@ ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
|
||||
|
||||
ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
|
||||
ntfCreateSubscription c pKey newSub =
|
||||
sendNtfCommand c (Just pKey) NoEntity (SNEW newSub) >>= \case
|
||||
sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
|
||||
NRSubId subId -> pure subId
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfCreateSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty (NewNtfEntity 'Subscription) -> IO (NonEmpty (Either NtfClientError NtfSubscriptionId))
|
||||
ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c cs
|
||||
where
|
||||
cs = L.map (\newSub -> (Just pKey, NoEntity, NtfCmd SSubscription $ SNEW newSub)) newSubs
|
||||
process (Response _ r) = case r of
|
||||
Right (NRSubId subId) -> Right subId
|
||||
Right r' -> Left $ unexpectedResponse r'
|
||||
Left e -> Left e
|
||||
|
||||
ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
|
||||
ntfCheckSubscription c pKey subId =
|
||||
sendNtfCommand c (Just pKey) subId SCHK >>= \case
|
||||
NRSub stat -> pure stat
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfCheckSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty NtfSubscriptionId -> IO (NonEmpty (Either NtfClientError NtfSubStatus))
|
||||
ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c cs
|
||||
where
|
||||
cs = L.map (\subId -> (Just pKey, subId, NtfCmd SSubscription SCHK)) subIds
|
||||
process (Response _ r) = case r of
|
||||
Right (NRSub stat) -> Right stat
|
||||
Right r' -> Left $ unexpectedResponse r'
|
||||
Left e -> Left e
|
||||
|
||||
ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
|
||||
ntfDeleteSubscription = okNtfCommand SDEL
|
||||
|
||||
|
||||
@@ -20,11 +20,8 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.Kind
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock.System
|
||||
import Data.Type.Equality
|
||||
import Data.Word (Word16)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
@@ -211,7 +208,7 @@ instance NtfEntityI e => ProtocolEncoding NTFVersion ErrorType (NtfCommand e) wh
|
||||
fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials (auth, _, EntityId entityId, _) cmd = case cmd of
|
||||
checkCredentials (auth, _, entityId, _) cmd = case cmd of
|
||||
-- TNEW and SNEW must have signature but NOT token/subscription IDs
|
||||
TNEW {} -> sigNoEntity
|
||||
SNEW {} -> sigNoEntity
|
||||
@@ -325,7 +322,7 @@ instance ProtocolEncoding NTFVersion ErrorType NtfResponse where
|
||||
PEBlock -> BLOCK
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
|
||||
checkCredentials (_, _, entId, _) cmd = case cmd of
|
||||
-- IDTKN response must not have queue ID
|
||||
NRTknId {} -> noEntity
|
||||
-- IDSUB response must not have queue ID
|
||||
@@ -429,31 +426,7 @@ instance FromJSON DeviceToken where
|
||||
t <- encodeUtf8 <$> o .: "token"
|
||||
pure $ DeviceToken pp t
|
||||
|
||||
-- List of PNMessageData uses semicolon-separated encoding instead of strEncode,
|
||||
-- because strEncode of NonEmpty list uses comma for separator,
|
||||
-- and encoding of PNMessageData's smpQueue has comma in list of hosts
|
||||
encodePNMessages :: NonEmpty PNMessageData -> ByteString
|
||||
encodePNMessages = B.intercalate ";" . map strEncode . L.toList
|
||||
|
||||
pnMessagesP :: A.Parser (NonEmpty PNMessageData)
|
||||
pnMessagesP = L.fromList <$> strP `A.sepBy1` A.char ';'
|
||||
|
||||
data PNMessageData = PNMessageData
|
||||
{ smpQueue :: SMPQueueNtf,
|
||||
ntfTs :: SystemTime,
|
||||
nmsgNonce :: C.CbNonce,
|
||||
encNMsgMeta :: EncNMsgMeta
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance StrEncoding PNMessageData where
|
||||
strEncode PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} =
|
||||
strEncode (smpQueue, ntfTs, nmsgNonce, encNMsgMeta)
|
||||
strP = do
|
||||
(smpQueue, ntfTs, nmsgNonce, encNMsgMeta) <- strP
|
||||
pure PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
|
||||
|
||||
type NtfEntityId = EntityId
|
||||
type NtfEntityId = ByteString
|
||||
|
||||
type NtfSubscriptionId = NtfEntityId
|
||||
|
||||
@@ -470,8 +443,6 @@ data NtfSubStatus
|
||||
NSInactive
|
||||
| -- | END received
|
||||
NSEnd
|
||||
| -- | DELD received (connection was deleted)
|
||||
NSDeleted
|
||||
| -- | SMP AUTH error
|
||||
NSAuth
|
||||
| -- | SMP error other than AUTH
|
||||
@@ -485,7 +456,6 @@ ntfShouldSubscribe = \case
|
||||
NSActive -> True
|
||||
NSInactive -> True
|
||||
NSEnd -> False
|
||||
NSDeleted -> False
|
||||
NSAuth -> False
|
||||
NSErr _ -> False
|
||||
|
||||
@@ -496,7 +466,6 @@ instance Encoding NtfSubStatus where
|
||||
NSActive -> "ACTIVE"
|
||||
NSInactive -> "INACTIVE"
|
||||
NSEnd -> "END"
|
||||
NSDeleted -> "DELETED"
|
||||
NSAuth -> "AUTH"
|
||||
NSErr err -> "ERR " <> err
|
||||
smpP =
|
||||
@@ -506,7 +475,6 @@ instance Encoding NtfSubStatus where
|
||||
"ACTIVE" -> pure NSActive
|
||||
"INACTIVE" -> pure NSInactive
|
||||
"END" -> pure NSEnd
|
||||
"DELETED" -> pure NSDeleted
|
||||
"AUTH" -> pure NSAuth
|
||||
"ERR" -> NSErr <$> (A.space *> A.takeByteString)
|
||||
_ -> fail "bad NtfSubStatus"
|
||||
|
||||
@@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@@ -9,7 +7,6 @@
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
@@ -19,17 +16,11 @@ import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.Bifunctor (first)
|
||||
import qualified Data.ByteString.Builder as BLD
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.Functor (($>))
|
||||
import Data.IORef
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.List (intercalate, partition, sort)
|
||||
import Data.List (intercalate, sort)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
@@ -39,43 +30,34 @@ import Data.Text.Encoding (decodeLatin1)
|
||||
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
|
||||
import Data.Time.Clock.System (getSystemTime)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import GHC.IORef (atomicSwapIORef)
|
||||
import GHC.Stats (getRTSStats)
|
||||
import Network.Socket (ServiceName, Socket, socketToHandle)
|
||||
import Network.Socket (ServiceName)
|
||||
import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..))
|
||||
import Simplex.Messaging.Client.Agent
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Control
|
||||
import Simplex.Messaging.Notifications.Server.Env
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS (PushNotification (..), PushProviderError (..))
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), PushNotification (..), PushProviderError (..))
|
||||
import Simplex.Messaging.Notifications.Server.Stats
|
||||
import Simplex.Messaging.Notifications.Server.Store
|
||||
import Simplex.Messaging.Notifications.Server.StoreLog
|
||||
import Simplex.Messaging.Notifications.Transport
|
||||
import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, pattern SMPServer, encodeTransmission, tGet, tPut)
|
||||
import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server
|
||||
import Simplex.Messaging.Server.Control (CPClientRole (..))
|
||||
import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, updatePeriodStats)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport.Buffer (trimCR)
|
||||
import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer)
|
||||
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.Server (runTransportServer, tlsServerCredentials)
|
||||
import Simplex.Messaging.Util
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO (BufferMode (..), hClose, hPrint, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode)
|
||||
import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
|
||||
import System.Mem.Weak (deRefWeak)
|
||||
import UnliftIO (IOMode (..), UnliftIO, askUnliftIO, async, uninterruptibleCancel, unliftIO, withFile)
|
||||
import UnliftIO (IOMode (..), async, uninterruptibleCancel, withFile)
|
||||
import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId)
|
||||
import UnliftIO.Directory (doesFileExist, renameFile)
|
||||
import UnliftIO.Exception
|
||||
import UnliftIO.STM
|
||||
#if MIN_VERSION_base(4,18,0)
|
||||
import GHC.Conc (listThreads)
|
||||
#endif
|
||||
|
||||
runNtfServer :: NtfServerConfig -> IO ()
|
||||
runNtfServer cfg = do
|
||||
@@ -89,19 +71,18 @@ type M a = ReaderT NtfEnv IO a
|
||||
|
||||
ntfServer :: NtfServerConfig -> TMVar Bool -> M ()
|
||||
ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
|
||||
restoreServerLastNtfs
|
||||
restoreServerStats
|
||||
s <- asks subscriber
|
||||
ps <- asks pushServer
|
||||
resubscribe s
|
||||
raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
|
||||
raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
|
||||
where
|
||||
runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
|
||||
runServer (tcpPort, ATransport t, _addHTTP) = do
|
||||
srvCreds <- asks tlsServerCreds
|
||||
serverSignKey <- either fail pure $ fromTLSCredentials srvCreds
|
||||
runServer :: (ServiceName, ATransport) -> M ()
|
||||
runServer (tcpPort, ATransport t) = do
|
||||
serverParams <- asks tlsServerParams
|
||||
serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams
|
||||
env <- ask
|
||||
liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds (Just supportedNTFHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
|
||||
liftIO $ runTransportServer started tcpPort serverParams tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
|
||||
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
|
||||
|
||||
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
|
||||
@@ -115,15 +96,11 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
|
||||
|
||||
stopServer :: M ()
|
||||
stopServer = do
|
||||
logInfo "Saving server state..."
|
||||
saveServer
|
||||
withNtfLog closeStoreLog
|
||||
saveServerStats
|
||||
NtfSubscriber {smpSubscribers, smpAgent} <- asks subscriber
|
||||
liftIO $ readTVarIO smpSubscribers >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (deRefWeak >=> mapM_ killThread))
|
||||
liftIO $ closeSMPClientAgent smpAgent
|
||||
logInfo "Server stopped"
|
||||
|
||||
saveServer :: M ()
|
||||
saveServer = withNtfLog closeStoreLog >> saveServerLastNtfs >> saveServerStats
|
||||
|
||||
serverStatsThread_ :: NtfServerConfig -> [M ()]
|
||||
serverStatsThread_ NtfServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
|
||||
@@ -141,16 +118,16 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
|
||||
withFile statsFilePath AppendMode $ \h -> liftIO $ do
|
||||
hSetBuffering h LineBuffering
|
||||
ts <- getCurrentTime
|
||||
fromTime' <- atomicSwapIORef fromTime ts
|
||||
tknCreated' <- atomicSwapIORef tknCreated 0
|
||||
tknVerified' <- atomicSwapIORef tknVerified 0
|
||||
tknDeleted' <- atomicSwapIORef tknDeleted 0
|
||||
subCreated' <- atomicSwapIORef subCreated 0
|
||||
subDeleted' <- atomicSwapIORef subDeleted 0
|
||||
ntfReceived' <- atomicSwapIORef ntfReceived 0
|
||||
ntfDelivered' <- atomicSwapIORef ntfDelivered 0
|
||||
tkn <- liftIO $ periodStatCounts activeTokens ts
|
||||
sub <- liftIO $ periodStatCounts activeSubs ts
|
||||
fromTime' <- atomically $ swapTVar fromTime ts
|
||||
tknCreated' <- atomically $ swapTVar tknCreated 0
|
||||
tknVerified' <- atomically $ swapTVar tknVerified 0
|
||||
tknDeleted' <- atomically $ swapTVar tknDeleted 0
|
||||
subCreated' <- atomically $ swapTVar subCreated 0
|
||||
subDeleted' <- atomically $ swapTVar subDeleted 0
|
||||
ntfReceived' <- atomically $ swapTVar ntfReceived 0
|
||||
ntfDelivered' <- atomically $ swapTVar ntfDelivered 0
|
||||
tkn <- atomically $ periodStatCounts activeTokens ts
|
||||
sub <- atomically $ periodStatCounts activeSubs ts
|
||||
hPutStrLn h $
|
||||
intercalate
|
||||
","
|
||||
@@ -171,131 +148,6 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
|
||||
]
|
||||
liftIO $ threadDelay' interval
|
||||
|
||||
controlPortThread_ :: NtfServerConfig -> [M ()]
|
||||
controlPortThread_ NtfServerConfig {controlPort = Just port} = [runCPServer port]
|
||||
controlPortThread_ _ = []
|
||||
|
||||
runCPServer :: ServiceName -> M ()
|
||||
runCPServer port = do
|
||||
cpStarted <- newEmptyTMVarIO
|
||||
u <- askUnliftIO
|
||||
liftIO $ do
|
||||
labelMyThread "control port server"
|
||||
runLocalTCPServer cpStarted port $ runCPClient u
|
||||
where
|
||||
runCPClient :: UnliftIO (ReaderT NtfEnv IO) -> Socket -> IO ()
|
||||
runCPClient u sock = do
|
||||
labelMyThread "control port client"
|
||||
h <- socketToHandle sock ReadWriteMode
|
||||
hSetBuffering h LineBuffering
|
||||
hSetNewlineMode h universalNewlineMode
|
||||
hPutStrLn h "Ntf server control port\n'help' for supported commands"
|
||||
role <- newTVarIO CPRNone
|
||||
cpLoop h role
|
||||
where
|
||||
cpLoop h role = do
|
||||
s <- trimCR <$> B.hGetLine h
|
||||
case strDecode s of
|
||||
Right CPQuit -> hClose h
|
||||
Right cmd -> logCmd s cmd >> processCP h role cmd >> cpLoop h role
|
||||
Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h role
|
||||
logCmd s cmd = when shouldLog $ logWarn $ "ControlPort: " <> tshow s
|
||||
where
|
||||
shouldLog = case cmd of
|
||||
CPAuth _ -> False
|
||||
CPHelp -> False
|
||||
CPQuit -> False
|
||||
CPSkip -> False
|
||||
_ -> True
|
||||
processCP h role = \case
|
||||
CPAuth auth -> atomically $ writeTVar role $! newRole cfg
|
||||
where
|
||||
newRole NtfServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin}
|
||||
| Just auth == admin = CPRAdmin
|
||||
| Just auth == user = CPRUser
|
||||
| otherwise = CPRNone
|
||||
CPStats -> withUserRole $ do
|
||||
ss <- unliftIO u $ asks serverStats
|
||||
let getStat :: (NtfServerStats -> IORef a) -> IO a
|
||||
getStat var = readIORef (var ss)
|
||||
putStat :: Show a => String -> (NtfServerStats -> IORef a) -> IO ()
|
||||
putStat label var = getStat var >>= \v -> hPutStrLn h $ label <> ": " <> show v
|
||||
putStat "fromTime" fromTime
|
||||
putStat "tknCreated" tknCreated
|
||||
putStat "tknVerified" tknVerified
|
||||
putStat "tknDeleted" tknDeleted
|
||||
putStat "subCreated" subCreated
|
||||
putStat "subDeleted" subDeleted
|
||||
putStat "ntfReceived" ntfReceived
|
||||
getStat (day . activeTokens) >>= \v -> hPutStrLn h $ "daily active tokens: " <> show (IS.size v)
|
||||
getStat (day . activeSubs) >>= \v -> hPutStrLn h $ "daily active subscriptions: " <> show (IS.size v)
|
||||
CPStatsRTS -> tryAny getRTSStats >>= either (hPrint h) (hPrint h)
|
||||
CPServerInfo -> readTVarIO role >>= \case
|
||||
CPRNone -> do
|
||||
logError "Unauthorized control port command"
|
||||
hPutStrLn h "AUTH"
|
||||
r -> do
|
||||
#if MIN_VERSION_base(4,18,0)
|
||||
threads <- liftIO listThreads
|
||||
hPutStrLn h $ "Threads: " <> show (length threads)
|
||||
#else
|
||||
hPutStrLn h "Threads: not available on GHC 8.10"
|
||||
#endif
|
||||
NtfSubscriber {smpSubscribers, smpAgent = a} <- unliftIO u $ asks subscriber
|
||||
putSMPWorkers a "SMP subcscribers" smpSubscribers
|
||||
let SMPClientAgent {smpClients, smpSessions, srvSubs, pendingSrvSubs, smpSubWorkers} = a
|
||||
putSMPWorkers a "SMP clients" smpClients
|
||||
putSMPWorkers a "SMP subscription workers" smpSubWorkers
|
||||
sessions <- readTVarIO smpSessions
|
||||
hPutStrLn h $ "SMP sessions count: " <> show (M.size sessions)
|
||||
putSMPSubs a "SMP subscriptions" srvSubs
|
||||
putSMPSubs a "Pending SMP subscriptions" pendingSrvSubs
|
||||
where
|
||||
putSMPSubs :: SMPClientAgent -> String -> TMap SMPServer (TMap SMPSub a) -> IO ()
|
||||
putSMPSubs a name v = do
|
||||
subs <- readTVarIO v
|
||||
(totalCnt, ownCount, otherCnt, servers, ownByServer) <- foldM countSubs (0, 0, 0, [], M.empty) $ M.assocs subs
|
||||
showServers a name servers
|
||||
hPutStrLn h $ name <> " total: " <> show totalCnt
|
||||
hPutStrLn h $ name <> " on own servers: " <> show ownCount
|
||||
when (r == CPRAdmin && not (null ownByServer)) $
|
||||
forM_ (M.assocs ownByServer) $ \(SMPServer (host :| _) _ _, cnt) ->
|
||||
hPutStrLn h $ name <> " on " <> B.unpack (strEncode host) <> ": " <> show cnt
|
||||
hPutStrLn h $ name <> " on other servers: " <> show otherCnt
|
||||
where
|
||||
countSubs :: (Int, Int, Int, [SMPServer], M.Map SMPServer Int) -> (SMPServer, TMap SMPSub a) -> IO (Int, Int, Int, [SMPServer], M.Map SMPServer Int)
|
||||
countSubs (!totalCnt, !ownCount, !otherCnt, !servers, !ownByServer) (srv, srvSubs) = do
|
||||
cnt <- M.size <$> readTVarIO srvSubs
|
||||
let totalCnt' = totalCnt + cnt
|
||||
ownServer = isOwnServer a srv
|
||||
(ownCount', otherCnt')
|
||||
| ownServer = (ownCount + cnt, otherCnt)
|
||||
| otherwise = (ownCount, otherCnt + cnt)
|
||||
servers' = if cnt > 0 then srv : servers else servers
|
||||
ownByServer'
|
||||
| r == CPRAdmin && ownServer && cnt > 0 = M.alter (Just . maybe cnt (+ cnt)) srv ownByServer
|
||||
| otherwise = ownByServer
|
||||
pure (totalCnt', ownCount', otherCnt', servers', ownByServer')
|
||||
putSMPWorkers :: SMPClientAgent -> String -> TMap SMPServer a -> IO ()
|
||||
putSMPWorkers a name v = readTVarIO v >>= showServers a name . M.keys
|
||||
showServers :: SMPClientAgent -> String -> [SMPServer] -> IO ()
|
||||
showServers a name srvs = do
|
||||
let (ownSrvs, otherSrvs) = partition (isOwnServer a) srvs
|
||||
hPutStrLn h $ name <> " own servers count: " <> show (length ownSrvs)
|
||||
when (r == CPRAdmin) $ hPutStrLn h $ name <> " own servers: " <> intercalate "," (sort $ map (\(SMPServer (host :| _) _ _) -> B.unpack $ strEncode host) ownSrvs)
|
||||
hPutStrLn h $ name <> " other servers count: " <> show (length otherSrvs)
|
||||
CPHelp -> hPutStrLn h "commands: stats, stats-rts, server-info, help, quit"
|
||||
CPQuit -> pure ()
|
||||
CPSkip -> pure ()
|
||||
where
|
||||
withUserRole action =
|
||||
readTVarIO role >>= \case
|
||||
CPRAdmin -> action
|
||||
CPRUser -> action
|
||||
_ -> do
|
||||
logError "Unauthorized control port command"
|
||||
hPutStrLn h "AUTH"
|
||||
|
||||
resubscribe :: NtfSubscriber -> M ()
|
||||
resubscribe NtfSubscriber {newSubQ} = do
|
||||
logInfo "Preparing SMP resubscriptions..."
|
||||
@@ -351,7 +203,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
|
||||
|
||||
receiveSMP :: M ()
|
||||
receiveSMP = forever $ do
|
||||
((_, srv, _), _thVersion, sessionId, ts) <- atomically $ readTBQueue msgQ
|
||||
((_, srv, _), _, _, ts) <- atomically $ readTBQueue msgQ
|
||||
forM ts $ \(ntfId, t) -> case t of
|
||||
STUnexpectedError e -> logError $ "SMP client unexpected error: " <> tshow e -- uncorrelated response, should not happen
|
||||
STResponse {} -> pure () -- it was already reported as timeout error
|
||||
@@ -363,17 +215,12 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
|
||||
st <- asks store
|
||||
NtfPushServer {pushQ} <- asks pushServer
|
||||
stats <- asks serverStats
|
||||
liftIO $ updatePeriodStats (activeSubs stats) ntfId
|
||||
tkn_ <- atomically (findNtfSubscriptionToken st smpQueue)
|
||||
forM_ tkn_ $ \tkn -> do
|
||||
let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
|
||||
lastNtfs <- liftIO $ addTokenLastNtf st (ntfTknId tkn) newNtf
|
||||
atomically (writeTBQueue pushQ (tkn, PNMessage lastNtfs))
|
||||
atomically $ updatePeriodStats (activeSubs stats) ntfId
|
||||
atomically $
|
||||
findNtfSubscriptionToken st smpQueue
|
||||
>>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
|
||||
incNtfStat ntfReceived
|
||||
Right SMP.END ->
|
||||
whenM (atomically $ activeClientSession' ca sessionId srv) $
|
||||
updateSubStatus smpQueue NSEnd
|
||||
Right SMP.DELD -> updateSubStatus smpQueue NSDeleted
|
||||
Right SMP.END -> updateSubStatus smpQueue NSEnd
|
||||
Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e
|
||||
Right _ -> logError "SMP server unexpected response"
|
||||
Left e -> logError $ "SMP client error: " <> tshow e
|
||||
@@ -450,7 +297,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
|
||||
void $ deliverNotification pp tkn ntf
|
||||
PNMessage {} -> checkActiveTkn status $ do
|
||||
stats <- asks serverStats
|
||||
liftIO $ updatePeriodStats (activeTokens stats) ntfTknId
|
||||
atomically $ updatePeriodStats (activeTokens stats) ntfTknId
|
||||
void $ deliverNotification pp tkn ntf
|
||||
incNtfStat ntfDelivered
|
||||
where
|
||||
@@ -501,29 +348,28 @@ clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connecte
|
||||
|
||||
receive :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> M ()
|
||||
receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
|
||||
ts <- L.toList <$> liftIO (tGet th)
|
||||
atomically . (writeTVar rcvActiveAt $!) =<< liftIO getSystemTime
|
||||
(errs, cmds) <- partitionEithers <$> mapM cmdAction ts
|
||||
write sndQ errs
|
||||
write rcvQ cmds
|
||||
ts <- liftIO $ tGet th
|
||||
forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
|
||||
atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime
|
||||
logDebug "received transmission"
|
||||
case cmdOrError of
|
||||
Left e -> write sndQ (corrId, entId, NRErr e)
|
||||
Right cmd ->
|
||||
verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd >>= \case
|
||||
VRVerified req -> write rcvQ req
|
||||
VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
|
||||
where
|
||||
cmdAction t@(_, _, (corrId, entId, cmdOrError)) =
|
||||
case cmdOrError of
|
||||
Left e -> pure $ Left (corrId, entId, NRErr e)
|
||||
Right cmd ->
|
||||
verified <$> verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd
|
||||
where
|
||||
verified = \case
|
||||
VRVerified req -> Right req
|
||||
VRFailed -> Left (corrId, entId, NRErr AUTH)
|
||||
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
|
||||
write q t = atomically $ writeTBQueue q t
|
||||
|
||||
send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO ()
|
||||
send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
|
||||
ts <- atomically $ readTBQueue sndQ
|
||||
void . liftIO $ tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts
|
||||
t <- atomically $ readTBQueue sndQ
|
||||
void . liftIO $ tPut h [Right (Nothing, encodeTransmission params t)]
|
||||
atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime
|
||||
|
||||
-- instance Show a => Show (TVar a) where
|
||||
-- show x = unsafePerformIO $ show <$> readTVarIO x
|
||||
|
||||
data VerificationResult = VRVerified NtfRequest | VRFailed
|
||||
|
||||
verifyNtfTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
|
||||
@@ -581,7 +427,7 @@ client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M ()
|
||||
client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} =
|
||||
forever $
|
||||
atomically (readTBQueue rcvQ)
|
||||
>>= mapM processCommand
|
||||
>>= processCommand
|
||||
>>= atomically . writeTBQueue sndQ
|
||||
where
|
||||
processCommand :: NtfRequest -> M (Transmission NtfResponse)
|
||||
@@ -598,7 +444,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
|
||||
atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
|
||||
withNtfLog (`logCreateToken` tkn)
|
||||
incNtfStatT token tknCreated
|
||||
pure (corrId, NoEntity, NRTknId tknId srvDhPubKey)
|
||||
pure (corrId, "", NRTknId tknId srvDhPubKey)
|
||||
NtfReqCmd SToken (NtfTkn tkn@NtfTknData {token, ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
|
||||
status <- readTVarIO tknStatus
|
||||
(corrId,tknId,) <$> case cmd of
|
||||
@@ -689,7 +535,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
|
||||
_ -> pure $ NRErr AUTH
|
||||
withNtfLog (`logCreateSubscription` sub)
|
||||
incNtfStat subCreated
|
||||
pure (corrId, NoEntity, resp)
|
||||
pure (corrId, "", resp)
|
||||
NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do
|
||||
status <- readTVarIO subStatus
|
||||
(corrId,subId,) <$> case cmd of
|
||||
@@ -714,7 +560,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
|
||||
PING -> pure NRPong
|
||||
NtfReqPing corrId entId -> pure (corrId, entId, NRPong)
|
||||
getId :: M NtfEntityId
|
||||
getId = fmap EntityId . randomBytes =<< asks (subIdBytes . config)
|
||||
getId = randomBytes =<< asks (subIdBytes . config)
|
||||
getRegCode :: M NtfRegCode
|
||||
getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config))
|
||||
randomBytes :: Int -> M ByteString
|
||||
@@ -727,52 +573,14 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
|
||||
withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M ()
|
||||
withNtfLog action = liftIO . mapM_ action =<< asks storeLog
|
||||
|
||||
incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M ()
|
||||
incNtfStatT :: DeviceToken -> (NtfServerStats -> TVar Int) -> M ()
|
||||
incNtfStatT (DeviceToken PPApnsNull _) _ = pure ()
|
||||
incNtfStatT _ statSel = incNtfStat statSel
|
||||
|
||||
incNtfStat :: (NtfServerStats -> IORef Int) -> M ()
|
||||
incNtfStat :: (NtfServerStats -> TVar Int) -> M ()
|
||||
incNtfStat statSel = do
|
||||
stats <- asks serverStats
|
||||
liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1)
|
||||
|
||||
saveServerLastNtfs :: M ()
|
||||
saveServerLastNtfs = asks (storeLastNtfsFile . config) >>= mapM_ saveLastNtfs
|
||||
where
|
||||
saveLastNtfs f = do
|
||||
logInfo $ "saving last notifications to file " <> T.pack f
|
||||
NtfStore {tokenLastNtfs} <- asks store
|
||||
liftIO . withFile f WriteMode $ \h ->
|
||||
readTVarIO tokenLastNtfs >>= mapM_ (saveTokenLastNtfs h) . M.assocs
|
||||
logInfo "notifications saved"
|
||||
where
|
||||
-- reverse on save, to save notifications in order, will become reversed again when restoring.
|
||||
saveTokenLastNtfs h (tknId, v) = BLD.hPutBuilder h . encodeLastNtfs tknId . L.reverse =<< readTVarIO v
|
||||
encodeLastNtfs tknId = mconcat . L.toList . L.map (\ntf -> BLD.byteString (strEncode $ TNMRv1 tknId ntf) <> BLD.char8 '\n')
|
||||
|
||||
restoreServerLastNtfs :: M ()
|
||||
restoreServerLastNtfs =
|
||||
asks (storeLastNtfsFile . config) >>= mapM_ restoreLastNtfs
|
||||
where
|
||||
restoreLastNtfs f =
|
||||
whenM (doesFileExist f) $ do
|
||||
logInfo $ "restoring last notifications from file " <> T.pack f
|
||||
st <- asks store
|
||||
runExceptT (liftIO (LB.readFile f) >>= mapM (restoreNtf st) . LB.lines) >>= \case
|
||||
Left e -> do
|
||||
logError . T.pack $ "error restoring last notifications: " <> e
|
||||
liftIO exitFailure
|
||||
Right _ -> do
|
||||
renameFile f $ f <> ".bak"
|
||||
logInfo "last notifications restored"
|
||||
where
|
||||
restoreNtf st s' = do
|
||||
TNMRv1 tknId ntf <- liftEither . first (ntfErr "parsing") $ strDecode s
|
||||
liftIO $ storeTokenLastNtf st tknId ntf
|
||||
where
|
||||
s = LB.toStrict s'
|
||||
ntfErr :: Show e => String -> e -> String
|
||||
ntfErr op e = op <> " error (" <> show e <> "): " <> B.unpack (B.take 100 s)
|
||||
atomically $ modifyTVar' (statSel stats) (+ 1)
|
||||
|
||||
saveServerStats :: M ()
|
||||
saveServerStats =
|
||||
@@ -792,7 +600,7 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat
|
||||
liftIO (strDecode <$> B.readFile f) >>= \case
|
||||
Right d -> do
|
||||
s <- asks serverStats
|
||||
liftIO $ setNtfServerStats s d
|
||||
atomically $ setNtfServerStats s d
|
||||
renameFile f $ f <> ".bak"
|
||||
logInfo "server stats restored"
|
||||
Left e -> do
|
||||
|
||||
@@ -1,37 +0,0 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Control where
|
||||
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BasicAuth)
|
||||
|
||||
data ControlProtocol
|
||||
= CPAuth BasicAuth
|
||||
| CPStats
|
||||
| CPStatsRTS
|
||||
| CPServerInfo
|
||||
| CPHelp
|
||||
| CPQuit
|
||||
| CPSkip
|
||||
|
||||
instance StrEncoding ControlProtocol where
|
||||
strEncode = \case
|
||||
CPAuth tok -> "auth " <> strEncode tok
|
||||
CPStats -> "stats"
|
||||
CPStatsRTS -> "stats-rts"
|
||||
CPServerInfo -> "server-info"
|
||||
CPHelp -> "help"
|
||||
CPQuit -> "quit"
|
||||
CPSkip -> ""
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"auth" -> CPAuth <$> _strP
|
||||
"stats" -> pure CPStats
|
||||
"stats-rts" -> pure CPStatsRTS
|
||||
"server-info" -> pure CPServerInfo
|
||||
"help" -> pure CPHelp
|
||||
"quit" -> pure CPQuit
|
||||
"" -> pure CPSkip
|
||||
_ -> fail "bad ControlProtocol command"
|
||||
@@ -28,21 +28,18 @@ import Simplex.Messaging.Notifications.Server.Stats
|
||||
import Simplex.Messaging.Notifications.Server.Store
|
||||
import Simplex.Messaging.Notifications.Server.StoreLog
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, CorrId, SMPServer, Transmission)
|
||||
import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams)
|
||||
import System.IO (IOMode (..))
|
||||
import System.Mem.Weak (Weak)
|
||||
import UnliftIO.STM
|
||||
|
||||
data NtfServerConfig = NtfServerConfig
|
||||
{ transports :: [(ServiceName, ATransport, AddHTTP)],
|
||||
controlPort :: Maybe ServiceName,
|
||||
controlPortUserAuth :: Maybe BasicAuth,
|
||||
controlPortAdminAuth :: Maybe BasicAuth,
|
||||
{ transports :: [(ServiceName, ATransport)],
|
||||
subIdBytes :: Int,
|
||||
regCodeBytes :: Int,
|
||||
clientQSize :: Natural,
|
||||
@@ -53,8 +50,10 @@ data NtfServerConfig = NtfServerConfig
|
||||
subsBatchSize :: Int,
|
||||
inactiveClientExpiration :: Maybe ExpirationConfig,
|
||||
storeLogFile :: Maybe FilePath,
|
||||
storeLastNtfsFile :: Maybe FilePath,
|
||||
ntfCredentials :: ServerCredentials,
|
||||
-- CA certificate private key is not needed for initialization
|
||||
caCertificateFile :: FilePath,
|
||||
privateKeyFile :: FilePath,
|
||||
certificateFile :: FilePath,
|
||||
-- stats config - see SMP server config
|
||||
logStatsInterval :: Maybe Int64,
|
||||
logStatsStartTime :: Int64,
|
||||
@@ -78,13 +77,13 @@ data NtfEnv = NtfEnv
|
||||
store :: NtfStore,
|
||||
storeLog :: Maybe (StoreLog 'WriteMode),
|
||||
random :: TVar ChaChaDRG,
|
||||
tlsServerCreds :: T.Credential,
|
||||
tlsServerParams :: T.ServerParams,
|
||||
serverIdentity :: C.KeyHash,
|
||||
serverStats :: NtfServerStats
|
||||
}
|
||||
|
||||
newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
|
||||
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, ntfCredentials} = do
|
||||
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
|
||||
random <- C.newRandom
|
||||
store <- newNtfStore
|
||||
logInfo "restoring subscriptions..."
|
||||
@@ -92,10 +91,10 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
|
||||
logInfo "restored subscriptions"
|
||||
subscriber <- newNtfSubscriber subQSize smpAgentCfg random
|
||||
pushServer <- newNtfPushServer pushQSize apnsConfig
|
||||
tlsServerCreds <- loadServerCredential ntfCredentials
|
||||
Fingerprint fp <- loadFingerprint ntfCredentials
|
||||
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
|
||||
Fingerprint fp <- loadFingerprint caCertificateFile
|
||||
serverStats <- newNtfServerStats =<< getCurrentTime
|
||||
pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
|
||||
pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
data NtfSubscriber = NtfSubscriber
|
||||
{ smpSubscribers :: TMap SMPServer SMPSubscriber,
|
||||
@@ -159,8 +158,8 @@ data NtfRequest
|
||||
| NtfReqPing CorrId NtfEntityId
|
||||
|
||||
data NtfServerClient = NtfServerClient
|
||||
{ rcvQ :: TBQueue (NonEmpty NtfRequest),
|
||||
sndQ :: TBQueue (NonEmpty (Transmission NtfResponse)),
|
||||
{ rcvQ :: TBQueue NtfRequest,
|
||||
sndQ :: TBQueue (Transmission NtfResponse),
|
||||
ntfThParams :: THandleParams NTFVersion 'TServer,
|
||||
connected :: TVar Bool,
|
||||
rcvActiveAt :: TVar SystemTime,
|
||||
|
||||
@@ -1,11 +1,9 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Main where
|
||||
|
||||
@@ -14,23 +12,22 @@ import Data.Functor (($>))
|
||||
import Data.Ini (lookupValue, readIniFile)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import qualified Data.Text.IO as T
|
||||
import Network.Socket (HostName)
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig)
|
||||
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Server (runNtfServer)
|
||||
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
|
||||
import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
|
||||
import Simplex.Messaging.Notifications.Transport (supportedNTFHandshakes, supportedServerNTFVRange)
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
|
||||
import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||
import System.FilePath (combine)
|
||||
@@ -53,9 +50,7 @@ ntfServerCLI cfgPath logPath =
|
||||
True -> readIniFile iniFile >>= either exitError runServer
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
Delete -> do
|
||||
confirmOrExit
|
||||
"WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
"Server NOT deleted"
|
||||
confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
deleteDirIfExists cfgPath
|
||||
deleteDirIfExists logPath
|
||||
putStrLn "Deleted configuration and log files"
|
||||
@@ -87,38 +82,21 @@ ntfServerCLI cfgPath logPath =
|
||||
\# and restoring it when the server is started.\n\
|
||||
\# Log is compacted on start (deleted objects are removed).\n"
|
||||
<> ("enable: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Last notifications are optionally saved and restored when the server restarts,\n\
|
||||
\# they are preserved in the .bak file until the next restart.\n"
|
||||
<> ("restore_last_notifications: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "log_stats: off\n\n\
|
||||
\[AUTH]\n\
|
||||
\# control_port_admin_password:\n\
|
||||
\# control_port_user_password:\n\
|
||||
\\n\
|
||||
\[TRANSPORT]\n\
|
||||
\# Host is only used to print server address on start.\n\
|
||||
\# You can specify multiple server ports.\n"
|
||||
\# host is only used to print server address on start\n"
|
||||
<> ("host: " <> T.pack host <> "\n")
|
||||
<> ("port: " <> T.pack defaultServerPort <> "\n")
|
||||
<> "log_tls_errors: off\n\n\
|
||||
\# Use `websockets: 443` to run websockets server in addition to plain TLS.\n\
|
||||
\websockets: off\n\n\
|
||||
\# control_port: 5227\n\
|
||||
\\n\
|
||||
<> "log_tls_errors: off\n"
|
||||
<> "websockets: off\n\n\
|
||||
\[SUBSCRIBER]\n\
|
||||
\# Network configuration for notification server client.\n\
|
||||
\# `host_mode` can be 'public' (default) or 'onion'.\n\
|
||||
\# It defines prefferred hostname for destination servers with multiple hostnames.\n\
|
||||
\# host_mode: public\n\
|
||||
\# required_host_mode: off\n\n\
|
||||
\# SOCKS proxy port for subscribing to SMP servers.\n\
|
||||
\# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\
|
||||
\# socks_proxy: localhost:9050\n\n\
|
||||
\# `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\
|
||||
\# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\
|
||||
\# own_server_domains: \n\n\
|
||||
\[INACTIVE_CLIENTS]\n\
|
||||
\# TTL and interval to check inactive clients\n\
|
||||
\disconnect: off\n"
|
||||
@@ -139,17 +117,9 @@ ntfServerCLI cfgPath logPath =
|
||||
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
logStats = settingIsOn "STORE_LOG" "log_stats" ini
|
||||
c = combine cfgPath . ($ defaultX509Config)
|
||||
restoreLastNtfsFile path = case iniOnOff "STORE_LOG" "restore_last_notifications" ini of
|
||||
Just True -> Just path
|
||||
Just False -> Nothing
|
||||
-- if the setting is not set, it is enabled when store log is enabled
|
||||
_ -> enableStoreLog $> path
|
||||
serverConfig =
|
||||
NtfServerConfig
|
||||
{ transports = iniTransports ini,
|
||||
controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
|
||||
controlPortAdminAuth = either error id <$!> strDecodeIni "AUTH" "control_port_admin_password" ini,
|
||||
controlPortUserAuth = either error id <$!> strDecodeIni "AUTH" "control_port_user_password" ini,
|
||||
subIdBytes = 24,
|
||||
regCodeBytes = 32,
|
||||
clientQSize = 64,
|
||||
@@ -162,13 +132,9 @@ ntfServerCLI cfgPath logPath =
|
||||
{ networkConfig =
|
||||
defaultNetworkConfig
|
||||
{ socksProxy = either error id <$!> strDecodeIni "SUBSCRIBER" "socks_proxy" ini,
|
||||
socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini,
|
||||
hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "SUBSCRIBER" "host_mode" ini,
|
||||
requiredHostMode = fromMaybe False $ iniOnOff "SUBSCRIBER" "required_host_mode" ini,
|
||||
smpPingInterval = 60_000_000 -- 1 minute
|
||||
socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini
|
||||
}
|
||||
},
|
||||
ownServerDomains = either (const []) (map encodeUtf8 . T.words) $ lookupValue "SUBSCRIBER" "own_server_domains" ini,
|
||||
persistErrorInterval = 0 -- seconds
|
||||
},
|
||||
apnsConfig = defaultAPNSPushClientConfig,
|
||||
@@ -180,13 +146,9 @@ ntfServerCLI cfgPath logPath =
|
||||
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
|
||||
},
|
||||
storeLogFile = enableStoreLog $> storeLogFilePath,
|
||||
storeLastNtfsFile = restoreLastNtfsFile $ combine logPath "ntf-server-last-notifications.log",
|
||||
ntfCredentials =
|
||||
ServerCredentials
|
||||
{ caCertificateFile = Just $ c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c serverCrtFile
|
||||
},
|
||||
caCertificateFile = c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c serverCrtFile,
|
||||
logStatsInterval = logStats $> 86400, -- seconds
|
||||
logStatsStartTime = 0, -- seconds from 00:00 UTC
|
||||
serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
|
||||
@@ -194,7 +156,8 @@ ntfServerCLI cfgPath logPath =
|
||||
ntfServerVRange = supportedServerNTFVRange,
|
||||
transportConfig =
|
||||
defaultTransportServerConfig
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
|
||||
alpn = Just supportedNTFHandshakes
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@@ -34,7 +34,6 @@ import Data.ByteString.Builder (lazyByteString)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Text (Text)
|
||||
@@ -48,10 +47,12 @@ import Network.HTTP2.Client (Request)
|
||||
import qualified Network.HTTP2.Client as H
|
||||
import Network.Socket (HostName, ServiceName)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
|
||||
import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.Protocol (EncNMsgMeta)
|
||||
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.Client
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
|
||||
@@ -102,11 +103,26 @@ readECPrivateKey f = do
|
||||
|
||||
data PushNotification
|
||||
= PNVerification NtfRegCode
|
||||
| PNMessage (NonEmpty PNMessageData)
|
||||
| PNMessage PNMessageData
|
||||
| -- | PNAlert Text
|
||||
PNCheckMessages
|
||||
deriving (Show)
|
||||
|
||||
data PNMessageData = PNMessageData
|
||||
{ smpQueue :: SMPQueueNtf,
|
||||
ntfTs :: SystemTime,
|
||||
nmsgNonce :: C.CbNonce,
|
||||
encNMsgMeta :: EncNMsgMeta
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance StrEncoding PNMessageData where
|
||||
strEncode PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} =
|
||||
strEncode (smpQueue, ntfTs, nmsgNonce, encNMsgMeta)
|
||||
strP = do
|
||||
(smpQueue, ntfTs, nmsgNonce, encNMsgMeta) <- strP
|
||||
pure PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
|
||||
|
||||
data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
|
||||
deriving (Show)
|
||||
|
||||
@@ -192,7 +208,7 @@ defaultAPNSPushClientConfig =
|
||||
authKeyFileEnv = "APNS_KEY_FILE", -- the environment variables APNS_KEY_FILE and APNS_KEY_ID must be set, or the server would fail to start
|
||||
authKeyAlg = "ES256",
|
||||
authKeyIdEnv = "APNS_KEY_ID",
|
||||
paddedNtfLength = 3072,
|
||||
paddedNtfLength = 512,
|
||||
appName = "chat.simplex.app",
|
||||
appTeamId = "5NN7GUYB6T",
|
||||
apnsPort = "443",
|
||||
@@ -269,7 +285,7 @@ apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
|
||||
encrypt code $ \code' ->
|
||||
apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code']
|
||||
PNMessage pnMessageData ->
|
||||
encrypt (encodePNMessages pnMessageData) $ \ntfData ->
|
||||
encrypt (strEncode pnMessageData) $ \ntfData ->
|
||||
apn apnMutableContent . Just $ J.object ["nonce" .= nonce, "message" .= ntfData]
|
||||
-- PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
|
||||
PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True]
|
||||
|
||||
@@ -7,22 +7,24 @@ module Simplex.Messaging.Notifications.Server.Stats where
|
||||
import Control.Applicative (optional)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.IORef
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (NtfTokenId)
|
||||
import Simplex.Messaging.Protocol (NotifierId)
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import UnliftIO.STM
|
||||
|
||||
data NtfServerStats = NtfServerStats
|
||||
{ fromTime :: IORef UTCTime,
|
||||
tknCreated :: IORef Int,
|
||||
tknVerified :: IORef Int,
|
||||
tknDeleted :: IORef Int,
|
||||
subCreated :: IORef Int,
|
||||
subDeleted :: IORef Int,
|
||||
ntfReceived :: IORef Int,
|
||||
ntfDelivered :: IORef Int,
|
||||
activeTokens :: PeriodStats,
|
||||
activeSubs :: PeriodStats
|
||||
{ fromTime :: TVar UTCTime,
|
||||
tknCreated :: TVar Int,
|
||||
tknVerified :: TVar Int,
|
||||
tknDeleted :: TVar Int,
|
||||
subCreated :: TVar Int,
|
||||
subDeleted :: TVar Int,
|
||||
ntfReceived :: TVar Int,
|
||||
ntfDelivered :: TVar Int,
|
||||
activeTokens :: PeriodStats NtfTokenId,
|
||||
activeSubs :: PeriodStats NotifierId
|
||||
}
|
||||
|
||||
data NtfServerStatsData = NtfServerStatsData
|
||||
@@ -34,49 +36,48 @@ data NtfServerStatsData = NtfServerStatsData
|
||||
_subDeleted :: Int,
|
||||
_ntfReceived :: Int,
|
||||
_ntfDelivered :: Int,
|
||||
_activeTokens :: PeriodStatsData,
|
||||
_activeSubs :: PeriodStatsData
|
||||
_activeTokens :: PeriodStatsData NtfTokenId,
|
||||
_activeSubs :: PeriodStatsData NotifierId
|
||||
}
|
||||
|
||||
newNtfServerStats :: UTCTime -> IO NtfServerStats
|
||||
newNtfServerStats ts = do
|
||||
fromTime <- newIORef ts
|
||||
tknCreated <- newIORef 0
|
||||
tknVerified <- newIORef 0
|
||||
tknDeleted <- newIORef 0
|
||||
subCreated <- newIORef 0
|
||||
subDeleted <- newIORef 0
|
||||
ntfReceived <- newIORef 0
|
||||
ntfDelivered <- newIORef 0
|
||||
fromTime <- newTVarIO ts
|
||||
tknCreated <- newTVarIO 0
|
||||
tknVerified <- newTVarIO 0
|
||||
tknDeleted <- newTVarIO 0
|
||||
subCreated <- newTVarIO 0
|
||||
subDeleted <- newTVarIO 0
|
||||
ntfReceived <- newTVarIO 0
|
||||
ntfDelivered <- newTVarIO 0
|
||||
activeTokens <- newPeriodStats
|
||||
activeSubs <- newPeriodStats
|
||||
pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs}
|
||||
|
||||
getNtfServerStatsData :: NtfServerStats -> IO NtfServerStatsData
|
||||
getNtfServerStatsData s@NtfServerStats {fromTime} = do
|
||||
_fromTime <- readIORef fromTime
|
||||
_tknCreated <- readIORef $ tknCreated s
|
||||
_tknVerified <- readIORef $ tknVerified s
|
||||
_tknDeleted <- readIORef $ tknDeleted s
|
||||
_subCreated <- readIORef $ subCreated s
|
||||
_subDeleted <- readIORef $ subDeleted s
|
||||
_ntfReceived <- readIORef $ ntfReceived s
|
||||
_ntfDelivered <- readIORef $ ntfDelivered s
|
||||
_fromTime <- readTVarIO fromTime
|
||||
_tknCreated <- readTVarIO $ tknCreated s
|
||||
_tknVerified <- readTVarIO $ tknVerified s
|
||||
_tknDeleted <- readTVarIO $ tknDeleted s
|
||||
_subCreated <- readTVarIO $ subCreated s
|
||||
_subDeleted <- readTVarIO $ subDeleted s
|
||||
_ntfReceived <- readTVarIO $ ntfReceived s
|
||||
_ntfDelivered <- readTVarIO $ ntfDelivered s
|
||||
_activeTokens <- getPeriodStatsData $ activeTokens s
|
||||
_activeSubs <- getPeriodStatsData $ activeSubs s
|
||||
pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs}
|
||||
|
||||
-- this function is not thread safe, it is used on server start only
|
||||
setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> IO ()
|
||||
setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> STM ()
|
||||
setNtfServerStats s@NtfServerStats {fromTime} d@NtfServerStatsData {_fromTime} = do
|
||||
writeIORef fromTime $! _fromTime
|
||||
writeIORef (tknCreated s) $! _tknCreated d
|
||||
writeIORef (tknVerified s) $! _tknVerified d
|
||||
writeIORef (tknDeleted s) $! _tknDeleted d
|
||||
writeIORef (subCreated s) $! _subCreated d
|
||||
writeIORef (subDeleted s) $! _subDeleted d
|
||||
writeIORef (ntfReceived s) $! _ntfReceived d
|
||||
writeIORef (ntfDelivered s) $! _ntfDelivered d
|
||||
writeTVar fromTime $! _fromTime
|
||||
writeTVar (tknCreated s) $! _tknCreated d
|
||||
writeTVar (tknVerified s) $! _tknVerified d
|
||||
writeTVar (tknDeleted s) $! _tknDeleted d
|
||||
writeTVar (subCreated s) $! _subCreated d
|
||||
writeTVar (subDeleted s) $! _subDeleted d
|
||||
writeTVar (ntfReceived s) $! _ntfReceived d
|
||||
writeTVar (ntfDelivered s) $! _ntfDelivered d
|
||||
setPeriodStats (activeTokens s) (_activeTokens d)
|
||||
setPeriodStats (activeSubs s) (_activeSubs d)
|
||||
|
||||
|
||||
@@ -1,12 +1,9 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Store where
|
||||
@@ -15,14 +12,12 @@ import Control.Concurrent.STM
|
||||
import Control.Monad
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Functor (($>))
|
||||
import Data.List.NonEmpty (NonEmpty (..), (<|))
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Word (Word16)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
@@ -35,8 +30,7 @@ data NtfStore = NtfStore
|
||||
tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId),
|
||||
subscriptions :: TMap NtfSubscriptionId NtfSubData,
|
||||
tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)),
|
||||
subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId,
|
||||
tokenLastNtfs :: TMap NtfTokenId (TVar (NonEmpty PNMessageData))
|
||||
subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId
|
||||
}
|
||||
|
||||
newNtfStore :: IO NtfStore
|
||||
@@ -46,8 +40,7 @@ newNtfStore = do
|
||||
subscriptions <- TM.emptyIO
|
||||
tokenSubscriptions <- TM.emptyIO
|
||||
subscriptionLookup <- TM.emptyIO
|
||||
tokenLastNtfs <- TM.emptyIO
|
||||
pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup, tokenLastNtfs}
|
||||
pure NtfStore {tokens, tokenRegistrations, subscriptions, tokenSubscriptions, subscriptionLookup}
|
||||
|
||||
data NtfTknData = NtfTknData
|
||||
{ ntfTknId :: NtfTokenId,
|
||||
@@ -118,7 +111,6 @@ removeInactiveTokenRegistrations st NtfTknData {ntfTknId = tId, token} =
|
||||
forM_ tIds $ \(regKey, tId') -> do
|
||||
TM.delete regKey tknRegs
|
||||
TM.delete tId' $ tokens st
|
||||
TM.delete tId' $ tokenLastNtfs st
|
||||
void $ deleteTokenSubs st tId'
|
||||
pure $ map snd tIds
|
||||
|
||||
@@ -138,7 +130,6 @@ deleteNtfToken st tknId = do
|
||||
TM.lookup token regs $>>= \tIds ->
|
||||
TM.delete (regKey tknVerifyKey) tIds
|
||||
>> whenM (TM.null tIds) (TM.delete token regs) $> Just ()
|
||||
TM.delete tknId $ tokenLastNtfs st
|
||||
deleteTokenSubs st tknId
|
||||
where
|
||||
regs = tokenRegistrations st
|
||||
@@ -205,42 +196,3 @@ deleteNtfSubscription st subId = do
|
||||
ts_ <- TM.lookup tokenId (tokenSubscriptions st)
|
||||
forM_ ts_ $ \ts -> modifyTVar' ts $ S.delete subId
|
||||
)
|
||||
|
||||
addTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO (NonEmpty PNMessageData)
|
||||
addTokenLastNtf st tknId newNtf =
|
||||
TM.lookupIO tknId (tokenLastNtfs st) >>= maybe (atomically maybeNewTokenLastNtfs) (atomically . addNtf)
|
||||
where
|
||||
maybeNewTokenLastNtfs =
|
||||
TM.lookup tknId (tokenLastNtfs st) >>= maybe newTokenLastNtfs addNtf
|
||||
newTokenLastNtfs = do
|
||||
v <- newTVar [newNtf]
|
||||
TM.insert tknId v $ tokenLastNtfs st
|
||||
pure [newNtf]
|
||||
addNtf v =
|
||||
stateTVar v $ \ntfs -> let !ntfs' = rebuildList ntfs in (ntfs', ntfs')
|
||||
where
|
||||
rebuildList :: NonEmpty PNMessageData -> NonEmpty PNMessageData
|
||||
rebuildList = foldr keepPrevNtf [newNtf]
|
||||
where
|
||||
PNMessageData {smpQueue = newNtfQ} = newNtf
|
||||
keepPrevNtf ntf@PNMessageData {smpQueue} ntfs
|
||||
| smpQueue /= newNtfQ && length ntfs < maxNtfs = ntf <| ntfs
|
||||
| otherwise = ntfs
|
||||
maxNtfs = 6
|
||||
|
||||
-- This function is expected to be called after store log is read,
|
||||
-- as it checks for token existence when adding last notification.
|
||||
storeTokenLastNtf :: NtfStore -> NtfTokenId -> PNMessageData -> IO ()
|
||||
storeTokenLastNtf (NtfStore {tokens, tokenLastNtfs}) tknId ntf = do
|
||||
TM.lookupIO tknId tokenLastNtfs >>= atomically . maybe newTokenLastNtfs (`modifyTVar'` (ntf <|))
|
||||
where
|
||||
newTokenLastNtfs = TM.lookup tknId tokenLastNtfs >>= maybe insertForExistingToken (`modifyTVar'` (ntf <|))
|
||||
insertForExistingToken =
|
||||
whenM (TM.member tknId tokens) $
|
||||
TM.insertM tknId (newTVar [ntf]) tokenLastNtfs
|
||||
|
||||
data TokenNtfMessageRecord = TNMRv1 NtfTokenId PNMessageData
|
||||
|
||||
instance StrEncoding TokenNtfMessageRecord where
|
||||
strEncode (TNMRv1 tknId ntf) = strEncode (Str "v1", tknId, ntf)
|
||||
strP = "v1 " *> (TNMRv1 <$> strP_ <*> strP)
|
||||
|
||||
@@ -37,7 +37,8 @@ import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Store
|
||||
import Simplex.Messaging.Protocol (NtfPrivateAuthKey)
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8, whenM)
|
||||
import System.Directory (doesFileExist, renameFile)
|
||||
import System.IO
|
||||
|
||||
data NtfStoreLogRecord
|
||||
@@ -49,7 +50,6 @@ data NtfStoreLogRecord
|
||||
| CreateSubscription NtfSubRec
|
||||
| SubscriptionStatus NtfSubscriptionId NtfSubStatus
|
||||
| DeleteSubscription NtfSubscriptionId
|
||||
deriving (Show)
|
||||
|
||||
data NtfTknRec = NtfTknRec
|
||||
{ ntfTknId :: NtfTokenId,
|
||||
@@ -61,7 +61,6 @@ data NtfTknRec = NtfTknRec
|
||||
tknRegCode :: NtfRegCode,
|
||||
tknCronInterval :: Word16
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
mkTknData :: NtfTknRec -> STM NtfTknData
|
||||
mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
|
||||
@@ -82,7 +81,6 @@ data NtfSubRec = NtfSubRec
|
||||
tokenId :: NtfTokenId,
|
||||
subStatus :: NtfSubStatus
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
mkSubData :: NtfSubRec -> STM NtfSubData
|
||||
mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
|
||||
@@ -185,7 +183,13 @@ logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
|
||||
logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
|
||||
|
||||
readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode)
|
||||
readWriteNtfStore = readWriteStoreLog readNtfStore writeNtfStore
|
||||
readWriteNtfStore f st = do
|
||||
whenM (doesFileExist f) $ do
|
||||
readNtfStore f st
|
||||
renameFile f $ f <> ".bak"
|
||||
s <- openWriteStoreLog f
|
||||
writeNtfStore s st
|
||||
pure s
|
||||
|
||||
readNtfStore :: FilePath -> NtfStore -> IO ()
|
||||
readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f
|
||||
|
||||
@@ -169,6 +169,5 @@ ntfTHandle c = THandle {connection = c, params}
|
||||
thServerVRange = versionToRange v,
|
||||
thAuth = Nothing,
|
||||
implySessId = False,
|
||||
encryptBlock = Nothing,
|
||||
batch = False
|
||||
}
|
||||
|
||||
@@ -99,8 +99,8 @@ type NtfActionTs = UTCTime
|
||||
data NtfSubNTFAction
|
||||
= NSACreate
|
||||
| NSACheck
|
||||
| NSADelete -- deprecated
|
||||
| NSARotate -- deprecated
|
||||
| NSADelete
|
||||
| NSARotate
|
||||
deriving (Show)
|
||||
|
||||
instance Encoding NtfSubNTFAction where
|
||||
|
||||
@@ -2,13 +2,11 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
@@ -101,8 +99,7 @@ module Simplex.Messaging.Protocol
|
||||
BasicAuth (..),
|
||||
SrvLoc (..),
|
||||
CorrId (..),
|
||||
EntityId (..),
|
||||
pattern NoEntity,
|
||||
EntityId,
|
||||
QueueId,
|
||||
RecipientId,
|
||||
SenderId,
|
||||
@@ -258,14 +255,13 @@ supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClie
|
||||
-- TODO v6.0 remove dependency on version
|
||||
maxMessageLength :: VersionSMP -> Int
|
||||
maxMessageLength v
|
||||
| v >= encryptedBlockSMPVersion = 16048 -- max 16051
|
||||
| v >= sendingProxySMPVersion = 16064 -- max 16067
|
||||
| otherwise = 16088 -- 16048 - always use this size to determine allowed ranges
|
||||
| otherwise = 16088 -- 16064 - always use this size to determine allowed ranges
|
||||
|
||||
paddedProxiedTLength :: Int
|
||||
paddedProxiedTLength = 16226 -- 16225 .. 16227
|
||||
paddedProxiedTLength = 16242 -- 16241 .. 16243
|
||||
|
||||
-- TODO v7.0 change to 16048
|
||||
-- TODO v6.0 change to 16064
|
||||
type MaxMessageLen = 16088
|
||||
|
||||
-- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used)
|
||||
@@ -273,10 +269,10 @@ type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
|
||||
|
||||
-- it is shorter to allow per-queue e2e encryption DH key in the "public" header
|
||||
e2eEncConfirmationLength :: Int
|
||||
e2eEncConfirmationLength = 15904 -- 15865 .. 15960
|
||||
e2eEncConfirmationLength = 15920 -- 15881 .. 15976
|
||||
|
||||
e2eEncMessageLength :: Int
|
||||
e2eEncMessageLength = 16000 -- 15988 .. 16005
|
||||
e2eEncMessageLength = 16016 -- 16004 .. 16021
|
||||
|
||||
-- | SMP protocol clients
|
||||
data Party = Recipient | Sender | Notifier | ProxiedClient
|
||||
@@ -333,8 +329,8 @@ data RawTransmission = RawTransmission
|
||||
{ authenticator :: ByteString, -- signature or encrypted transmission hash
|
||||
authorized :: ByteString, -- authorized transmission
|
||||
sessId :: SessionId,
|
||||
corrId :: CorrId,
|
||||
entityId :: EntityId,
|
||||
corrId :: ByteString,
|
||||
entityId :: ByteString,
|
||||
command :: ByteString
|
||||
}
|
||||
deriving (Show)
|
||||
@@ -361,7 +357,7 @@ instance IsString (Maybe TransmissionAuth) where
|
||||
fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . fmap TASignature
|
||||
|
||||
-- | unparsed sent SMP transmission with signature, without session ID.
|
||||
type SignedRawTransmission = (Maybe TransmissionAuth, CorrId, EntityId, ByteString)
|
||||
type SignedRawTransmission = (Maybe TransmissionAuth, SessionId, ByteString, ByteString)
|
||||
|
||||
-- | unparsed sent SMP transmission with signature.
|
||||
type SentRawTransmission = (Maybe TransmissionAuth, ByteString)
|
||||
@@ -378,13 +374,7 @@ type NotifierId = QueueId
|
||||
-- | SMP queue ID on the server.
|
||||
type QueueId = EntityId
|
||||
|
||||
-- this type is used for server entities only
|
||||
newtype EntityId = EntityId {unEntityId :: ByteString}
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving newtype (Encoding, StrEncoding)
|
||||
|
||||
pattern NoEntity :: EntityId
|
||||
pattern NoEntity = EntityId ""
|
||||
type EntityId = ByteString
|
||||
|
||||
-- | Parameterized type for SMP protocol commands from all clients.
|
||||
data Command (p :: Party) where
|
||||
@@ -399,6 +389,8 @@ data Command (p :: Party) where
|
||||
NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
|
||||
NDEL :: Command Recipient
|
||||
GET :: Command Recipient
|
||||
-- ACK v1 has to be supported for encoding/decoding
|
||||
-- ACK :: Command Recipient
|
||||
ACK :: MsgId -> Command Recipient
|
||||
OFF :: Command Recipient
|
||||
DEL :: Command Recipient
|
||||
@@ -483,7 +475,6 @@ data BrokerMsg where
|
||||
RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy
|
||||
PRES :: EncResponse -> BrokerMsg -- proxy to client
|
||||
END :: BrokerMsg
|
||||
DELD :: BrokerMsg
|
||||
INFO :: QueueInfo -> BrokerMsg
|
||||
OK :: BrokerMsg
|
||||
ERR :: ErrorType -> BrokerMsg
|
||||
@@ -538,13 +529,11 @@ messageId :: Message -> MsgId
|
||||
messageId = \case
|
||||
Message {msgId} -> msgId
|
||||
MessageQuota {msgId} -> msgId
|
||||
{-# INLINE messageId #-}
|
||||
|
||||
messageTs :: Message -> SystemTime
|
||||
messageTs = \case
|
||||
Message {msgTs} -> msgTs
|
||||
MessageQuota {msgTs} -> msgTs
|
||||
{-# INLINE messageTs #-}
|
||||
|
||||
newtype EncRcvMsgBody = EncRcvMsgBody ByteString
|
||||
deriving (Eq, Show)
|
||||
@@ -707,7 +696,6 @@ data BrokerMsgTag
|
||||
| RRES_
|
||||
| PRES_
|
||||
| END_
|
||||
| DELD_
|
||||
| INFO_
|
||||
| OK_
|
||||
| ERR_
|
||||
@@ -781,7 +769,6 @@ instance Encoding BrokerMsgTag where
|
||||
RRES_ -> "RRES"
|
||||
PRES_ -> "PRES"
|
||||
END_ -> "END"
|
||||
DELD_ -> "DELD"
|
||||
INFO_ -> "INFO"
|
||||
OK_ -> "OK"
|
||||
ERR_ -> "ERR"
|
||||
@@ -798,7 +785,6 @@ instance ProtocolMsgTag BrokerMsgTag where
|
||||
"RRES" -> Just RRES_
|
||||
"PRES" -> Just PRES_
|
||||
"END" -> Just END_
|
||||
"DELD" -> Just DELD_
|
||||
"INFO" -> Just INFO_
|
||||
"OK" -> Just OK_
|
||||
"ERR" -> Just ERR_
|
||||
@@ -1111,13 +1097,10 @@ serverStrP = do
|
||||
portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
|
||||
|
||||
-- | Transmission correlation ID.
|
||||
newtype CorrId = CorrId {bs :: ByteString}
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving newtype (Encoding)
|
||||
newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
|
||||
|
||||
instance IsString CorrId where
|
||||
fromString = CorrId . fromString
|
||||
{-# INLINE fromString #-}
|
||||
|
||||
instance StrEncoding CorrId where
|
||||
strEncode (CorrId cId) = strEncode cId
|
||||
@@ -1198,8 +1181,6 @@ data ErrorType
|
||||
CRYPTO
|
||||
| -- | SMP queue capacity is exceeded on the server
|
||||
QUOTA
|
||||
| -- | SMP server storage error
|
||||
STORE {storeErr :: String}
|
||||
| -- | ACK command is sent without message to be acknowledged
|
||||
NO_MSG
|
||||
| -- | sent message is too large (> maxMessageLength = 16088 bytes)
|
||||
@@ -1281,7 +1262,7 @@ transmissionP THandleParams {sessionId, implySessId} = do
|
||||
command <- A.takeByteString
|
||||
pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command}
|
||||
|
||||
class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
|
||||
class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
|
||||
type ProtoCommand msg = cmd | cmd -> msg
|
||||
type ProtoType msg = (sch :: ProtocolType) | sch -> msg
|
||||
protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c 'TClient)
|
||||
@@ -1342,7 +1323,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials (auth, _, EntityId entId, _) cmd = case cmd of
|
||||
checkCredentials (auth, _, entId, _) cmd = case cmd of
|
||||
-- NEW must have signature but NOT queue ID
|
||||
NEW {}
|
||||
| isNothing auth -> Left $ CMD NO_AUTH
|
||||
@@ -1430,9 +1411,6 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
RRES (EncFwdResponse encBlock) -> e (RRES_, ' ', Tail encBlock)
|
||||
PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock)
|
||||
END -> e END_
|
||||
DELD
|
||||
| v >= deletedEventSMPVersion -> e DELD_
|
||||
| otherwise -> e END_
|
||||
INFO info -> e (INFO_, ' ', info)
|
||||
OK -> e OK_
|
||||
ERR err -> e (ERR_, ' ', err)
|
||||
@@ -1458,7 +1436,6 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
RRES_ -> RRES <$> (EncFwdResponse . unTail <$> _smpP)
|
||||
PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP)
|
||||
END_ -> pure END
|
||||
DELD_ -> pure DELD
|
||||
INFO_ -> INFO <$> _smpP
|
||||
OK_ -> pure OK
|
||||
ERR_ -> ERR <$> _smpP
|
||||
@@ -1471,7 +1448,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
PEBlock -> BLOCK
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
|
||||
checkCredentials (_, _, entId, _) cmd = case cmd of
|
||||
-- IDS response should not have queue ID
|
||||
IDS _ -> Right cmd
|
||||
-- ERR response does not always have queue ID
|
||||
@@ -1515,7 +1492,6 @@ instance Encoding ErrorType where
|
||||
AUTH -> "AUTH"
|
||||
CRYPTO -> "CRYPTO"
|
||||
QUOTA -> "QUOTA"
|
||||
STORE err -> "STORE " <> smpEncode err
|
||||
EXPIRED -> "EXPIRED"
|
||||
NO_MSG -> "NO_MSG"
|
||||
LARGE_MSG -> "LARGE_MSG"
|
||||
@@ -1531,7 +1507,6 @@ instance Encoding ErrorType where
|
||||
"AUTH" -> pure AUTH
|
||||
"CRYPTO" -> pure CRYPTO
|
||||
"QUOTA" -> pure QUOTA
|
||||
"STORE" -> STORE <$> _smpP
|
||||
"EXPIRED" -> pure EXPIRED
|
||||
"NO_MSG" -> pure NO_MSG
|
||||
"LARGE_MSG" -> pure LARGE_MSG
|
||||
@@ -1668,8 +1643,8 @@ batchTransmissions' batch bSize ts
|
||||
batchTransmissions_ :: Int -> NonEmpty (Either TransportError ByteString, r) -> [TransportBatch r]
|
||||
batchTransmissions_ bSize = addBatch . foldr addTransmission ([], 0, 0, [], [])
|
||||
where
|
||||
-- 19 = 2 bytes reserved for pad size + 1 for transmission count + 16 auth tag from block encryption
|
||||
bSize' = bSize - 19
|
||||
-- 3 = 2 bytes reserved for pad size + 1 for transmission count
|
||||
bSize' = bSize - 3
|
||||
addTransmission :: (Either TransportError ByteString, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r])
|
||||
addTransmission (t_, r) acc@(bs, !len, !n, ss, rs) = case t_ of
|
||||
Left e -> (TBError e r : addBatch acc, 0, 0, [], [])
|
||||
@@ -1746,16 +1721,16 @@ tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \ca
|
||||
| implySessId || sessId == sessionId ->
|
||||
let decodedTransmission = (,corrId,entityId,command) <$> decodeTAuthBytes authenticator
|
||||
in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission
|
||||
| otherwise -> (Nothing, "", (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd PESession))
|
||||
| otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PESession))
|
||||
Left _ -> tError ""
|
||||
where
|
||||
tError :: CorrId -> SignedTransmission err cmd
|
||||
tError corrId = (Nothing, "", (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd PEBlock))
|
||||
tError :: ByteString -> SignedTransmission err cmd
|
||||
tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PEBlock))
|
||||
|
||||
tParseValidate :: ByteString -> SignedRawTransmission -> SignedTransmission err cmd
|
||||
tParseValidate signed t@(sig, corrId, entityId, command) =
|
||||
let cmd = parseProtocol @v @err @cmd v command >>= checkCredentials t
|
||||
in (sig, signed, (corrId, entityId, cmd))
|
||||
in (sig, signed, (CorrId corrId, entityId, cmd))
|
||||
|
||||
$(J.deriveJSON defaultJSON ''MsgFlags)
|
||||
|
||||
|
||||
+522
-890
File diff suppressed because it is too large
Load Diff
@@ -6,8 +6,6 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Messaging.Server.CLI where
|
||||
@@ -18,7 +16,6 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Either (fromRight)
|
||||
import Data.Ini (Ini, lookupValue)
|
||||
import Data.List ((\\))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
@@ -30,7 +27,7 @@ import Options.Applicative
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
|
||||
import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
|
||||
import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
|
||||
import Simplex.Messaging.Transport.Server (loadFingerprint)
|
||||
import Simplex.Messaging.Transport.WebSockets (WS)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, whenM)
|
||||
import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
|
||||
@@ -44,11 +41,11 @@ import Text.Read (readMaybe)
|
||||
exitError :: String -> IO a
|
||||
exitError msg = putStrLn msg >> exitFailure
|
||||
|
||||
confirmOrExit :: String -> String -> IO ()
|
||||
confirmOrExit s no =
|
||||
confirmOrExit :: String -> IO ()
|
||||
confirmOrExit s =
|
||||
withPrompt (s <> "\nContinue (Y/n): ") $ do
|
||||
ok <- getLine
|
||||
when (ok /= "Y") $ putStrLn no >> exitFailure
|
||||
when (ok /= "Y") $ putStrLn "Server NOT deleted" >> exitFailure
|
||||
|
||||
data SignAlgorithm = ED448 | ED25519
|
||||
deriving (Read, Show)
|
||||
@@ -140,7 +137,7 @@ createServerX509_ createCA cfgPath x509cfg = do
|
||||
)
|
||||
|
||||
saveFingerprint = do
|
||||
Fingerprint fp <- loadFileFingerprint $ c caCrtFile
|
||||
Fingerprint fp <- loadFingerprint $ c caCrtFile
|
||||
withFile (c fingerprintFile) WriteMode (`B.hPutStrLn` strEncode fp)
|
||||
pure fp
|
||||
|
||||
@@ -269,37 +266,26 @@ settingIsOn section name ini
|
||||
checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString
|
||||
checkSavedFingerprint cfgPath x509cfg = do
|
||||
savedFingerprint <- withFile (c fingerprintFile) ReadMode hGetLine
|
||||
Fingerprint fp <- loadFileFingerprint (c caCrtFile)
|
||||
Fingerprint fp <- loadFingerprint (c caCrtFile)
|
||||
when (B.pack savedFingerprint /= strEncode fp) $
|
||||
exitError "Stored fingerprint is invalid."
|
||||
pure fp
|
||||
where
|
||||
c = combine cfgPath . ($ x509cfg)
|
||||
|
||||
iniTransports :: Ini -> [(ServiceName, ATransport, AddHTTP)]
|
||||
iniTransports :: Ini -> [(String, ATransport)]
|
||||
iniTransports ini =
|
||||
let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
|
||||
ws = strictIni "TRANSPORT" "websockets" ini
|
||||
wsPorts
|
||||
| ws == "off" = []
|
||||
| ws == "on" = ["80"]
|
||||
| otherwise = ports ws \\ smpPorts
|
||||
in ts (transport @TLS) smpPorts <> ts (transport @WS) wsPorts
|
||||
where
|
||||
ts :: ATransport -> [ServiceName] -> [(ServiceName, ATransport, AddHTTP)]
|
||||
ts t = map (\port -> (port, t, webPort == Just port))
|
||||
webPort = T.unpack <$> eitherToMaybe (lookupValue "WEB" "https" ini)
|
||||
ports = map T.unpack . T.splitOn ","
|
||||
let port = T.unpack $ strictIni "TRANSPORT" "port" ini
|
||||
enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
|
||||
in (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
|
||||
|
||||
printServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
|
||||
printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO ()
|
||||
printServerConfig transports logFile = do
|
||||
putStrLn $ case logFile of
|
||||
Just f -> "Store log: " <> f
|
||||
_ -> "Store log disabled."
|
||||
forM_ transports $ \(p, ATransport t, addHTTP) -> do
|
||||
let descr = p <> " (" <> transportName t <> ")..."
|
||||
putStrLn $ "Serving SMP protocol on port " <> descr
|
||||
when addHTTP $ putStrLn $ "Serving static site on port " <> descr
|
||||
forM_ transports $ \(p, ATransport t) ->
|
||||
putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
|
||||
|
||||
deleteDirIfExists :: FilePath -> IO ()
|
||||
deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
|
||||
|
||||
@@ -4,8 +4,9 @@
|
||||
module Simplex.Messaging.Server.Control where
|
||||
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString (ByteString)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BasicAuth, SenderId)
|
||||
import Simplex.Messaging.Protocol (BasicAuth)
|
||||
|
||||
data CPClientRole = CPRNone | CPRUser | CPRAdmin
|
||||
deriving (Eq)
|
||||
@@ -21,7 +22,7 @@ data ControlProtocol
|
||||
| CPSockets
|
||||
| CPSocketThreads
|
||||
| CPServerInfo
|
||||
| CPDelete SenderId
|
||||
| CPDelete ByteString
|
||||
| CPSave
|
||||
| CPHelp
|
||||
| CPQuit
|
||||
|
||||
@@ -1,33 +1,27 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Simplex.Messaging.Server.Env.STM where
|
||||
|
||||
import Control.Concurrent (ThreadId)
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import qualified Crypto.PubKey.RSA as RSA
|
||||
import Crypto.Random
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Int (Int64)
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Data.List (intercalate)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (isJust, isNothing)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Clock.System (SystemTime)
|
||||
import qualified Data.X509 as X
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import Network.Socket (ServiceName)
|
||||
import qualified Network.TLS as T
|
||||
@@ -39,37 +33,28 @@ 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.NtfStore
|
||||
import Simplex.Messaging.Server.QueueStore
|
||||
import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..))
|
||||
import Simplex.Messaging.Server.QueueStore.STM
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP)
|
||||
import Simplex.Messaging.Transport.Server
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Exit (exitFailure)
|
||||
import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams, newSocketState)
|
||||
import System.IO (IOMode (..))
|
||||
import System.Mem.Weak (Weak)
|
||||
import UnliftIO.STM
|
||||
|
||||
data ServerConfig = ServerConfig
|
||||
{ transports :: [(ServiceName, ATransport, AddHTTP)],
|
||||
{ transports :: [(ServiceName, ATransport)],
|
||||
smpHandshakeTimeout :: Int,
|
||||
tbqSize :: Natural,
|
||||
msgStoreType :: AMSType,
|
||||
msgQueueQuota :: Int,
|
||||
maxJournalMsgCount :: Int,
|
||||
maxJournalStateLines :: Int,
|
||||
queueIdBytes :: Int,
|
||||
msgIdBytes :: Int,
|
||||
storeLogFile :: Maybe FilePath,
|
||||
storeMsgsFile :: Maybe FilePath,
|
||||
storeNtfsFile :: Maybe FilePath,
|
||||
-- | set to False to prohibit creating new queues
|
||||
allowNewQueues :: Bool,
|
||||
-- | simple password that the clients need to pass in handshake to be able to create new queues
|
||||
@@ -79,11 +64,6 @@ data ServerConfig = ServerConfig
|
||||
controlPortAdminAuth :: Maybe BasicAuth,
|
||||
-- | time after which the messages can be removed from the queues and check interval, seconds
|
||||
messageExpiration :: Maybe ExpirationConfig,
|
||||
expireMessagesOnStart :: 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),
|
||||
-- and check interval, seconds
|
||||
inactiveClientExpiration :: Maybe ExpirationConfig,
|
||||
@@ -96,12 +76,10 @@ data ServerConfig = ServerConfig
|
||||
serverStatsLogFile :: FilePath,
|
||||
-- | file to save and restore stats
|
||||
serverStatsBackupFile :: Maybe FilePath,
|
||||
-- | notification delivery interval
|
||||
ntfDeliveryInterval :: Int,
|
||||
-- | interval between sending pending END events to unsubscribed clients, seconds
|
||||
pendingENDInterval :: Int,
|
||||
smpCredentials :: ServerCredentials,
|
||||
httpCredentials :: Maybe ServerCredentials,
|
||||
-- | CA certificate private key is not needed for initialization
|
||||
caCertificateFile :: FilePath,
|
||||
privateKeyFile :: FilePath,
|
||||
certificateFile :: FilePath,
|
||||
-- | SMP client-server protocol version range
|
||||
smpServerVRange :: VersionRangeSMP,
|
||||
-- | TCP transport config
|
||||
@@ -123,20 +101,7 @@ defaultMessageExpiration :: ExpirationConfig
|
||||
defaultMessageExpiration =
|
||||
ExpirationConfig
|
||||
{ ttl = defMsgExpirationDays * 86400, -- seconds
|
||||
checkInterval = 14400 -- seconds, 4 hours
|
||||
}
|
||||
|
||||
defaultIdleQueueInterval :: Int64
|
||||
defaultIdleQueueInterval = 28800 -- seconds, 8 hours
|
||||
|
||||
defNtfExpirationHours :: Int64
|
||||
defNtfExpirationHours = 24
|
||||
|
||||
defaultNtfExpiration :: ExpirationConfig
|
||||
defaultNtfExpiration =
|
||||
ExpirationConfig
|
||||
{ ttl = defNtfExpirationHours * 3600, -- seconds
|
||||
checkInterval = 3600 -- seconds, 1 hour
|
||||
checkInterval = 43200 -- seconds, 12 hours
|
||||
}
|
||||
|
||||
defaultInactiveClientExpiration :: ExpirationConfig
|
||||
@@ -149,64 +114,30 @@ defaultInactiveClientExpiration =
|
||||
defaultProxyClientConcurrency :: Int
|
||||
defaultProxyClientConcurrency = 32
|
||||
|
||||
journalMsgStoreDepth :: Int
|
||||
journalMsgStoreDepth = 5
|
||||
|
||||
defaultMaxJournalStateLines :: Int
|
||||
defaultMaxJournalStateLines = 16
|
||||
|
||||
defaultMaxJournalMsgCount :: Int
|
||||
defaultMaxJournalMsgCount = 256
|
||||
|
||||
defaultMsgQueueQuota :: Int
|
||||
defaultMsgQueueQuota = 128
|
||||
|
||||
defaultStateTailSize :: Int
|
||||
defaultStateTailSize = 512
|
||||
|
||||
data Env = Env
|
||||
{ config :: ServerConfig,
|
||||
serverActive :: TVar Bool,
|
||||
serverInfo :: ServerInformation,
|
||||
server :: Server,
|
||||
serverIdentity :: KeyHash,
|
||||
msgStore :: AMsgStore,
|
||||
ntfStore :: NtfStore,
|
||||
queueStore :: QueueStore,
|
||||
msgStore :: STMMsgStore,
|
||||
random :: TVar ChaChaDRG,
|
||||
tlsServerCreds :: T.Credential,
|
||||
httpServerCreds :: Maybe T.Credential,
|
||||
storeLog :: Maybe (StoreLog 'WriteMode),
|
||||
tlsServerParams :: T.ServerParams,
|
||||
serverStats :: ServerStats,
|
||||
sockets :: TVar [(ServiceName, SocketState)],
|
||||
sockets :: SocketState,
|
||||
clientSeq :: TVar ClientId,
|
||||
clients :: TVar (IntMap (Maybe AClient)),
|
||||
clients :: TVar (IntMap Client),
|
||||
proxyAgent :: ProxyAgent -- senders served on this proxy
|
||||
}
|
||||
|
||||
type family MsgStore s where
|
||||
MsgStore 'MSMemory = STMMsgStore
|
||||
MsgStore 'MSJournal = JournalMsgStore
|
||||
|
||||
data AMsgStore = forall s. (STMQueueStore (MsgStore s), MsgStoreClass (MsgStore s)) => AMS (SMSType s) (MsgStore s)
|
||||
|
||||
data AStoreQueue = forall s. MsgStoreClass (MsgStore s) => ASQ (SMSType s) (StoreQueue (MsgStore s))
|
||||
|
||||
data AMsgStoreCfg = forall s. MsgStoreClass (MsgStore s) => AMSC (SMSType s) (MsgStoreConfig (MsgStore s))
|
||||
|
||||
msgPersistence :: AMsgStoreCfg -> Bool
|
||||
msgPersistence (AMSC SMSMemory (STMStoreConfig {storePath})) = isJust storePath
|
||||
msgPersistence (AMSC SMSJournal _) = True
|
||||
|
||||
type Subscribed = Bool
|
||||
|
||||
data Server = Server
|
||||
{ subscribedQ :: TQueue (RecipientId, ClientId, Subscribed),
|
||||
subscribers :: TMap RecipientId (TVar AClient),
|
||||
ntfSubscribedQ :: TQueue (NotifierId, ClientId, Subscribed),
|
||||
notifiers :: TMap NotifierId (TVar AClient),
|
||||
subClients :: TVar (IntMap AClient), -- clients with SMP subscriptions
|
||||
ntfSubClients :: TVar (IntMap AClient), -- clients with Ntf subscriptions
|
||||
pendingSubEvents :: TVar (IntMap (NonEmpty (RecipientId, Subscribed))),
|
||||
pendingNtfSubEvents :: TVar (IntMap (NonEmpty (NotifierId, Subscribed))),
|
||||
{ subscribedQ :: TQueue (RecipientId, Client, Subscribed),
|
||||
subscribers :: TMap RecipientId Client,
|
||||
ntfSubscribedQ :: TQueue (NotifierId, Client, Subscribed),
|
||||
notifiers :: TMap NotifierId Client,
|
||||
savingLock :: Lock
|
||||
}
|
||||
|
||||
@@ -216,16 +147,11 @@ newtype ProxyAgent = ProxyAgent
|
||||
|
||||
type ClientId = Int
|
||||
|
||||
data AClient = forall s. MsgStoreClass (MsgStore s) => AClient (SMSType s) (Client (MsgStore s))
|
||||
|
||||
clientId' :: AClient -> ClientId
|
||||
clientId' (AClient _ Client {clientId}) = clientId
|
||||
|
||||
data Client s = Client
|
||||
data Client = Client
|
||||
{ clientId :: ClientId,
|
||||
subscriptions :: TMap RecipientId Sub,
|
||||
ntfSubscriptions :: TMap NotifierId (),
|
||||
rcvQ :: TBQueue (NonEmpty (Maybe (StoreQueue s, QueueRec), Transmission Cmd)),
|
||||
rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
|
||||
sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
|
||||
msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
|
||||
procThreads :: TVar Int,
|
||||
@@ -254,15 +180,12 @@ newServer = do
|
||||
subscribers <- TM.emptyIO
|
||||
ntfSubscribedQ <- newTQueueIO
|
||||
notifiers <- TM.emptyIO
|
||||
subClients <- newTVarIO IM.empty
|
||||
ntfSubClients <- newTVarIO IM.empty
|
||||
pendingSubEvents <- newTVarIO IM.empty
|
||||
pendingNtfSubEvents <- newTVarIO IM.empty
|
||||
savingLock <- createLockIO
|
||||
return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, subClients, ntfSubClients, pendingSubEvents, pendingNtfSubEvents, savingLock}
|
||||
savingLock <- atomically createLock
|
||||
return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock}
|
||||
|
||||
newClient :: SMSType s -> ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO (Client (MsgStore s))
|
||||
newClient _msType clientId qSize thVersion sessionId createdAt = do
|
||||
newClient :: TVar ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client
|
||||
newClient nextClientId qSize thVersion sessionId createdAt = do
|
||||
clientId <- atomically $ stateTVar nextClientId $ \next -> (next, next + 1)
|
||||
subscriptions <- TM.emptyIO
|
||||
ntfSubscriptions <- TM.emptyIO
|
||||
rcvQ <- newTBQueueIO qSize
|
||||
@@ -288,54 +211,38 @@ newProhibitedSub = do
|
||||
return Sub {subThread = ProhibitSub, delivered}
|
||||
|
||||
newEnv :: ServerConfig -> IO Env
|
||||
newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgStoreType, storeMsgsFile, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines} = do
|
||||
serverActive <- newTVarIO True
|
||||
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg, transportConfig, information, messageExpiration} = do
|
||||
server <- newServer
|
||||
msgStore@(AMS _ store) <- case msgStoreType of
|
||||
AMSType SMSMemory -> AMS SMSMemory <$> newMsgStore STMStoreConfig {storePath = storeMsgsFile, quota = msgQueueQuota}
|
||||
AMSType SMSJournal -> case storeMsgsFile of
|
||||
Just storePath ->
|
||||
let cfg = JournalStoreConfig {storePath, quota = msgQueueQuota, pathParts = journalMsgStoreDepth, maxMsgCount = maxJournalMsgCount, maxStateLines = maxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = idleQueueInterval}
|
||||
in AMS SMSJournal <$> newMsgStore cfg
|
||||
Nothing -> putStrLn "Error: journal msg store require path in [STORE_LOG], restore_messages" >> exitFailure
|
||||
ntfStore <- NtfStore <$> TM.emptyIO
|
||||
queueStore <- newQueueStore
|
||||
msgStore <- newMsgStore
|
||||
random <- C.newRandom
|
||||
forM_ storeLogFile $ \f -> do
|
||||
logInfo $ "restoring queues from file " <> T.pack f
|
||||
sl <- readWriteQueueStore f store
|
||||
setStoreLog store sl
|
||||
tlsServerCreds <- getCredentials "SMP" smpCredentials
|
||||
httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials
|
||||
mapM_ checkHTTPSCredentials httpServerCreds
|
||||
Fingerprint fp <- loadFingerprint smpCredentials
|
||||
storeLog <-
|
||||
forM storeLogFile $ \f -> do
|
||||
logInfo $ "restoring queues from file " <> T.pack f
|
||||
restoreQueues queueStore f
|
||||
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
|
||||
Fingerprint fp <- loadFingerprint caCertificateFile
|
||||
let serverIdentity = KeyHash fp
|
||||
serverStats <- newServerStats =<< getCurrentTime
|
||||
sockets <- newTVarIO []
|
||||
sockets <- newSocketState
|
||||
clientSeq <- newTVarIO 0
|
||||
clients <- newTVarIO mempty
|
||||
proxyAgent <- newSMPProxyAgent smpAgentCfg random
|
||||
pure Env {serverActive, config, serverInfo, server, serverIdentity, msgStore, ntfStore, random, tlsServerCreds, httpServerCreds, serverStats, sockets, clientSeq, clients, proxyAgent}
|
||||
pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent}
|
||||
where
|
||||
getCredentials protocol creds = do
|
||||
files <- missingCreds
|
||||
unless (null files) $ do
|
||||
putStrLn $ "Error: no " <> protocol <> " credentials: " <> intercalate ", " files
|
||||
when (protocol == "HTTPS") $ putStrLn letsEncrypt
|
||||
exitFailure
|
||||
loadServerCredential creds
|
||||
where
|
||||
missingfile f = (\y -> [f | not y]) <$> doesFileExist f
|
||||
missingCreds = do
|
||||
let files = maybe id (:) (caCertificateFile creds) [certificateFile creds, privateKeyFile creds]
|
||||
in concat <$> mapM missingfile files
|
||||
checkHTTPSCredentials (X.CertificateChain cc, _k) =
|
||||
-- LetsEncrypt provides ECDSA with insecure curve p256 (https://safecurves.cr.yp.to)
|
||||
case map (X.signedObject . X.getSigned) cc of
|
||||
X.Certificate {X.certPubKey = X.PubKeyRSA rsa} : _ca | RSA.public_size rsa >= 512 -> pure ()
|
||||
_ -> do
|
||||
putStrLn $ "Error: unsupported HTTPS credentials, required 4096-bit RSA\n" <> letsEncrypt
|
||||
exitFailure
|
||||
letsEncrypt = "Use Let's Encrypt to generate: certbot certonly --standalone -d yourdomainname --key-type rsa --rsa-key-size 4096"
|
||||
restoreQueues :: QueueStore -> FilePath -> IO (StoreLog 'WriteMode)
|
||||
restoreQueues QueueStore {queues, senders, notifiers} f = do
|
||||
(qs, s) <- readWriteStoreLog f
|
||||
atomically . writeTVar queues =<< mapM newTVarIO qs
|
||||
atomically $ writeTVar senders $! M.foldr' addSender M.empty qs
|
||||
atomically $ writeTVar notifiers $! M.foldr' addNotifier M.empty qs
|
||||
pure s
|
||||
addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
|
||||
addSender q = M.insert (senderId q) (recipientId q)
|
||||
addNotifier :: QueueRec -> Map NotifierId RecipientId -> Map NotifierId RecipientId
|
||||
addNotifier q = case notifier q of
|
||||
Nothing -> id
|
||||
Just NtfCreds {notifierId} -> M.insert notifierId (recipientId q)
|
||||
serverInfo =
|
||||
ServerInformation
|
||||
{ information,
|
||||
@@ -351,13 +258,10 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, msgSt
|
||||
where
|
||||
persistence
|
||||
| isNothing storeLogFile = SPMMemoryOnly
|
||||
| isJust storeMsgsFile = SPMMessages
|
||||
| isJust (storeMsgsFile config) = SPMMessages
|
||||
| otherwise = SPMQueues
|
||||
|
||||
newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent
|
||||
newSMPProxyAgent smpAgentCfg random = do
|
||||
smpAgent <- newSMPClientAgent smpAgentCfg random
|
||||
pure ProxyAgent {smpAgent}
|
||||
|
||||
readWriteQueueStore :: STMQueueStore s => FilePath -> s -> IO (StoreLog 'WriteMode)
|
||||
readWriteQueueStore = readWriteStoreLog readQueueStore writeQueueStore
|
||||
|
||||
@@ -1,21 +1,14 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Simplex.Messaging.Server.Information where
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson.TH as J
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Messaging.Agent.Protocol (ConnectionMode (..), ConnectionRequestUri)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
|
||||
|
||||
data ServerInformation = ServerInformation
|
||||
@@ -43,59 +36,16 @@ data ServerPublicInfo = ServerPublicInfo
|
||||
adminContacts :: Maybe ServerContactAddress,
|
||||
complaintsContacts :: Maybe ServerContactAddress,
|
||||
hosting :: Maybe Entity,
|
||||
hostingType :: Maybe HostingType,
|
||||
serverCountry :: Maybe Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
emptyServerInfo :: Text -> ServerPublicInfo
|
||||
emptyServerInfo sourceCode =
|
||||
ServerPublicInfo
|
||||
{ sourceCode,
|
||||
usageConditions = Nothing,
|
||||
operator = Nothing,
|
||||
website = Nothing,
|
||||
adminContacts = Nothing,
|
||||
complaintsContacts = Nothing,
|
||||
hosting = Nothing,
|
||||
hostingType = Nothing,
|
||||
serverCountry = Nothing
|
||||
}
|
||||
|
||||
hasServerInfo :: ServerPublicInfo -> Bool
|
||||
hasServerInfo ServerPublicInfo {usageConditions, operator, website, adminContacts, complaintsContacts, hosting, hostingType, serverCountry} =
|
||||
isJust usageConditions || isJust operator || isJust website || isJust adminContacts || isJust complaintsContacts || isJust hosting || isJust hostingType || isJust serverCountry
|
||||
|
||||
data ServerPersistenceMode = SPMMemoryOnly | SPMQueues | SPMMessages
|
||||
deriving (Show)
|
||||
|
||||
data ServerConditions = ServerConditions {conditions :: Text, amendments :: Maybe Text}
|
||||
deriving (Show)
|
||||
|
||||
data HostingType = HTVirtual | HTDedicated | HTColocation | HTOwned
|
||||
deriving (Show)
|
||||
|
||||
instance StrEncoding HostingType where
|
||||
strEncode = \case
|
||||
HTVirtual -> "virtual"
|
||||
HTDedicated -> "dedicated"
|
||||
HTColocation -> "colocation"
|
||||
HTOwned -> "owned"
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"virtual" -> pure HTVirtual
|
||||
"dedicated" -> pure HTDedicated
|
||||
"colocation" -> pure HTColocation
|
||||
"owned" -> pure HTOwned
|
||||
_ -> fail "bad HostingType"
|
||||
|
||||
instance FromJSON HostingType where
|
||||
parseJSON = strParseJSON "HostingType"
|
||||
|
||||
instance ToJSON HostingType where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data Entity = Entity {name :: Text, country :: Maybe Text}
|
||||
deriving (Show)
|
||||
|
||||
|
||||
@@ -1,6 +1,5 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
@@ -9,18 +8,15 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Messaging.Server.Main where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (finally)
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad (void, when, (<$!>))
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isAlpha, isAscii, toUpper)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.Ini (Ini, lookupValue, readIniFile)
|
||||
import Data.List (find, isPrefixOf)
|
||||
@@ -28,149 +24,68 @@ import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import qualified Data.Text.IO as T
|
||||
import Network.Socket (HostName)
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Agent.Protocol (connReqUriP')
|
||||
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
|
||||
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig)
|
||||
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
|
||||
import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer)
|
||||
import Simplex.Messaging.Server (runSMPServer)
|
||||
import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Env.STM
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration, defaultProxyClientConcurrency)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.Information
|
||||
import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..))
|
||||
import Simplex.Messaging.Server.MsgStore.Types (AMSType (..), SMSType (..), newMsgStore)
|
||||
import Simplex.Messaging.Server.QueueStore.STM (readQueueStore)
|
||||
import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedServerSMPRelayVRange)
|
||||
import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), defaultSocksProxy)
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8, tshow)
|
||||
import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
|
||||
import Simplex.Messaging.Version (mkVersionRange)
|
||||
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
|
||||
import System.Exit (exitFailure)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist)
|
||||
import System.FilePath (combine)
|
||||
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
smpServerCLI :: FilePath -> FilePath -> IO ()
|
||||
smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) (\_ -> error "attachStaticFiles not available")
|
||||
smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ())
|
||||
|
||||
smpServerCLI_ ::
|
||||
(ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) ->
|
||||
(EmbeddedWebParams -> IO ()) ->
|
||||
(FilePath -> (AttachHTTP -> IO ()) -> IO ()) ->
|
||||
FilePath ->
|
||||
FilePath ->
|
||||
IO ()
|
||||
smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
smpServerCLI_ :: (ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) -> (EmbeddedWebParams -> IO ()) -> FilePath -> FilePath -> IO ()
|
||||
smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
|
||||
getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
|
||||
Init opts ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
|
||||
_ -> initializeServer opts
|
||||
OnlineCert certOpts -> withIniFile $ \_ -> genOnline cfgPath certOpts
|
||||
Start -> withIniFile runServer
|
||||
OnlineCert certOpts ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> genOnline cfgPath certOpts
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
Start ->
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> readIniFile iniFile >>= either exitError runServer
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
Delete -> do
|
||||
confirmOrExit
|
||||
"WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
"Server NOT deleted"
|
||||
confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
||||
deleteDirIfExists cfgPath
|
||||
deleteDirIfExists logPath
|
||||
putStrLn "Deleted configuration and log files"
|
||||
Journal cmd -> withIniFile $ \ini -> do
|
||||
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
|
||||
msgsFileExists <- doesFileExist storeMsgsFilePath
|
||||
let enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
storeLogFile <- case enableStoreLog $> storeLogFilePath of
|
||||
Just storeLogFile -> do
|
||||
ifM
|
||||
(doesFileExist storeLogFile)
|
||||
(pure storeLogFile)
|
||||
(putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
|
||||
Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
|
||||
case cmd of
|
||||
JCImport
|
||||
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
|
||||
| msgsDirExists -> do
|
||||
putStrLn $ storeMsgsJournalDir <> " directory already exists."
|
||||
exitFailure
|
||||
| not msgsFileExists -> do
|
||||
putStrLn $ storeMsgsFilePath <> " file does not exists."
|
||||
exitFailure
|
||||
| otherwise -> do
|
||||
confirmOrExit
|
||||
("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir)
|
||||
"Messages not imported"
|
||||
ms <- newJournalMsgStore
|
||||
readQueueStore storeLogFile ms
|
||||
msgStats <- importMessages True ms storeMsgsFilePath Nothing -- no expiration
|
||||
putStrLn "Import completed"
|
||||
printMessageStats "Messages" msgStats
|
||||
putStrLn $ case readMsgStoreType ini of
|
||||
Right (AMSType SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
|
||||
Right (AMSType SMSJournal) -> "store_messages set to `journal`"
|
||||
Left e -> e <> ", update it to `journal` in INI file"
|
||||
JCExport
|
||||
| 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"
|
||||
ms <- newJournalMsgStore
|
||||
readQueueStore storeLogFile ms
|
||||
exportMessages True ms storeMsgsFilePath False
|
||||
putStrLn "Export completed"
|
||||
putStrLn $ case readMsgStoreType ini of
|
||||
Right (AMSType SMSMemory) -> "store_messages set to `memory`"
|
||||
Right (AMSType SMSJournal) -> "store_messages set to `journal`, update it to `memory` in INI file"
|
||||
Left e -> e <> ", update it to `memory` in INI file"
|
||||
JCDelete
|
||||
| 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
|
||||
where
|
||||
withIniFile a =
|
||||
doesFileExist iniFile >>= \case
|
||||
True -> readIniFile iniFile >>= either exitError a
|
||||
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
||||
newJournalMsgStore = newMsgStore JournalStoreConfig {storePath = storeMsgsJournalDir, pathParts = journalMsgStoreDepth, quota = defaultMsgQueueQuota, maxMsgCount = defaultMaxJournalMsgCount, maxStateLines = defaultMaxJournalStateLines, stateTailSize = defaultStateTailSize, idleInterval = checkInterval defaultMessageExpiration}
|
||||
iniFile = combine cfgPath "smp-server.ini"
|
||||
serverVersion = "SMP server v" <> simplexMQVersion
|
||||
defaultServerPorts = "5223,443"
|
||||
defaultServerPort = "5223"
|
||||
executableName = "smp-server"
|
||||
storeLogFilePath = combine logPath "smp-server-store.log"
|
||||
storeMsgsFilePath = combine logPath "smp-server-messages.log"
|
||||
storeMsgsJournalDir = combine logPath "messages"
|
||||
storeNtfsFilePath = combine logPath "smp-server-ntfs.log"
|
||||
readMsgStoreType :: Ini -> Either String AMSType
|
||||
readMsgStoreType = textToMsgStoreType . fromRight "memory" . lookupValue "STORE_LOG" "store_messages"
|
||||
textToMsgStoreType = \case
|
||||
"memory" -> Right $ AMSType SMSMemory
|
||||
"journal" -> Right $ AMSType SMSJournal
|
||||
s -> Left $ "invalid store_messages: " <> T.unpack s
|
||||
httpsCertFile = combine cfgPath "web.crt"
|
||||
httpsCertFile = combine cfgPath "web.cert"
|
||||
httpsKeyFile = combine cfgPath "web.key"
|
||||
defaultStaticPath = combine logPath "www"
|
||||
initializeServer opts@InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted}
|
||||
| scripted = initialize opts
|
||||
| otherwise = do
|
||||
putStrLn "Use `smp-server init -h` for available options."
|
||||
checkInitOptions opts
|
||||
void $ withPrompt "SMP server will be initialized (press Enter)" getLine
|
||||
enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
|
||||
logStats <- onOffPrompt "Enable logging daily statistics" False
|
||||
@@ -180,15 +95,16 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
|
||||
sourceCode' <- withPrompt ("Enter server source code URI (" <> maybe simplexmqSource T.unpack src' <> "): ") getServerSourceCode
|
||||
staticPath' <- withPrompt ("Enter path to store generated static site with server information (" <> fromMaybe defaultStaticPath sp' <> "): ") getLine
|
||||
enableWeb <- onOffPrompt "Enable built-in web server for static site" (not noWeb')
|
||||
initialize
|
||||
opts
|
||||
{ enableStoreLog,
|
||||
logStats,
|
||||
fqdn = if null host' then fqdn else Just host',
|
||||
password,
|
||||
sourceCode = (T.pack <$> sourceCode') <|> src' <|> Just (T.pack simplexmqSource),
|
||||
sourceCode = (T.pack <$> sourceCode') <|> src',
|
||||
webStaticPath = if null staticPath' then sp' else Just staticPath',
|
||||
disableWeb = noWeb'
|
||||
disableWeb = not enableWeb
|
||||
}
|
||||
where
|
||||
serverPassword =
|
||||
@@ -200,18 +116,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
case strDecode $ encodeUtf8 $ T.pack s of
|
||||
Right auth -> pure . Just $ ServerPassword auth
|
||||
_ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword
|
||||
checkInitOptions InitOptions {sourceCode, serverInfo, operatorCountry, hostingCountry} = do
|
||||
let err_
|
||||
| isNothing sourceCode && hasServerInfo serverInfo =
|
||||
Just "Error: passing any server information requires passing --source-code"
|
||||
| isNothing (operator serverInfo) && isJust operatorCountry =
|
||||
Just "Error: passing --operator-country requires passing --operator"
|
||||
| isNothing (hosting serverInfo) && isJust hostingCountry =
|
||||
Just "Error: passing --hosting-country requires passing --hosting"
|
||||
| otherwise = Nothing
|
||||
forM_ err_ $ \err -> putStrLn err >> exitFailure
|
||||
initialize opts'@InitOptions {enableStoreLog, logStats, signAlgorithm, password, controlPort, socksProxy, ownDomains, sourceCode, webStaticPath, disableWeb} = do
|
||||
checkInitOptions opts'
|
||||
initialize InitOptions {enableStoreLog, logStats, signAlgorithm, password, sourceCode, webStaticPath, disableWeb} = do
|
||||
clearDirIfExists cfgPath
|
||||
clearDirIfExists logPath
|
||||
createDirectoryIfMissing True cfgPath
|
||||
@@ -219,10 +124,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
|
||||
fp <- createServerX509 cfgPath x509cfg
|
||||
basicAuth <- mapM createServerPassword password
|
||||
controlPortPwds <- forM controlPort $ \_ -> let pwd = decodeLatin1 <$> randomBase64 18 in (,) <$> pwd <*> pwd
|
||||
let host = fromMaybe (if ip == "127.0.0.1" then "<hostnames>" else ip) fqdn
|
||||
srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth
|
||||
T.writeFile iniFile $ iniFileContent host basicAuth controlPortPwds
|
||||
T.writeFile iniFile $ iniFileContent host basicAuth $ Just "https://github.com/simplex-chat/simplexmq"
|
||||
putStrLn $ "Server initialized, please provide additional server information in " <> iniFile <> "."
|
||||
putStrLn $ "Run `" <> executableName <> " start` to start server."
|
||||
warnCAPrivateKeyFile cfgPath x509cfg
|
||||
@@ -231,10 +135,9 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
where
|
||||
createServerPassword = \case
|
||||
ServerPassword s -> pure s
|
||||
SPRandom -> BasicAuth <$> randomBase64 32
|
||||
randomBase64 n = strEncode <$> (atomically . C.randomBytes n =<< C.newRandom)
|
||||
iniFileContent host basicAuth controlPortPwds =
|
||||
informationIniContent opts'
|
||||
SPRandom -> BasicAuth . strEncode <$> (atomically . C.randomBytes 32 =<< C.newRandom)
|
||||
iniFileContent host basicAuth sourceCode' =
|
||||
informationIniContent sourceCode'
|
||||
<> "[STORE_LOG]\n\
|
||||
\# The server uses STM memory for persistence,\n\
|
||||
\# that will be lost on restart (e.g., as with redis).\n\
|
||||
@@ -242,15 +145,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
\# and restoring it when the server is started.\n\
|
||||
\# Log is compacted on start (deleted objects are removed).\n"
|
||||
<> ("enable: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Message storage mode: `memory` or `journal`.\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"
|
||||
<> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
|
||||
<> "# Messages and notifications expiration periods.\n"
|
||||
<> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n")
|
||||
<> "expire_messages_on_start: on\n"
|
||||
<> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n")
|
||||
<> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
|
||||
\# they are preserved in the .bak file until the next restart.\n"
|
||||
<> ("restore_messages: " <> onOff enableStoreLog <> "\n")
|
||||
<> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n\n")
|
||||
<> "# Log daily server statistics to CSV file\n"
|
||||
<> ("log_stats: " <> onOff logStats <> "\n\n")
|
||||
<> "[AUTH]\n\
|
||||
@@ -262,77 +160,66 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
\# smp://fingerprint:password@host1,host2\n\
|
||||
\# The password will not be shared with the connecting contacts, you must share it only\n\
|
||||
\# with the users who you want to allow creating messaging queues on your server.\n"
|
||||
<> ( let noPassword = "password to create new queues and forward messages (any printable ASCII characters without whitespace, '@', ':' and '/')"
|
||||
in optDisabled basicAuth <> "create_password: " <> maybe noPassword (safeDecodeUtf8 . strEncode) basicAuth
|
||||
<> ( case basicAuth of
|
||||
Just auth -> "create_password: " <> safeDecodeUtf8 (strEncode auth)
|
||||
_ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
|
||||
)
|
||||
<> "\n\n"
|
||||
<> (optDisabled controlPortPwds <> "control_port_admin_password: " <> maybe "" fst controlPortPwds <> "\n")
|
||||
<> (optDisabled controlPortPwds <> "control_port_user_password: " <> maybe "" snd controlPortPwds <> "\n")
|
||||
<> "\n\
|
||||
\[TRANSPORT]\n\
|
||||
\# Host is only used to print server address on start.\n\
|
||||
\# You can specify multiple server ports.\n"
|
||||
<> ("host: " <> T.pack host <> "\n")
|
||||
<> ("port: " <> T.pack defaultServerPorts <> "\n")
|
||||
<> "log_tls_errors: off\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"
|
||||
<> (optDisabled controlPort <> "control_port: " <> tshow (fromMaybe defaultControlPort controlPort))
|
||||
<> "\n\n\
|
||||
\# control_port_admin_password:\n\
|
||||
\# control_port_user_password:\n\n\
|
||||
\[TRANSPORT]\n\
|
||||
\# host is only used to print server address on start\n"
|
||||
<> ("host: " <> T.pack host <> "\n")
|
||||
<> ("port: " <> T.pack defaultServerPort <> "\n")
|
||||
<> "log_tls_errors: off\n\
|
||||
\websockets: off\n\
|
||||
\# control_port: 5224\n\n\
|
||||
\[PROXY]\n\
|
||||
\# Network configuration for SMP proxy client.\n\
|
||||
\# `host_mode` can be 'public' (default) or 'onion'.\n\
|
||||
\# It defines prefferred hostname for destination servers with multiple hostnames.\n\
|
||||
\# host_mode: public\n\
|
||||
\# required_host_mode: off\n\n\
|
||||
\# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n"
|
||||
<> (optDisabled ownDomains <> "own_server_domains: " <> maybe "" (safeDecodeUtf8 . strEncode) ownDomains)
|
||||
<> "\n\n\
|
||||
\# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\
|
||||
\# own_server_domains: \n\n\
|
||||
\# SOCKS proxy port for forwarding messages to destination servers.\n\
|
||||
\# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n"
|
||||
<> (optDisabled socksProxy <> "socks_proxy: " <> maybe "localhost:9050" (safeDecodeUtf8 . strEncode) socksProxy)
|
||||
<> "\n\n\
|
||||
\# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\
|
||||
\# socks_proxy: localhost:9050\n\n\
|
||||
\# `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"
|
||||
<> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency)
|
||||
<> "\n\n\
|
||||
\[INACTIVE_CLIENTS]\n\
|
||||
<> ("# client_concurrency: " <> tshow defaultProxyClientConcurrency <> "\n\n")
|
||||
<> "[INACTIVE_CLIENTS]\n\
|
||||
\# TTL and interval to check inactive clients\n\
|
||||
\disconnect: on\n"
|
||||
<> ("ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
|
||||
<> ("check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration))
|
||||
\disconnect: off\n"
|
||||
<> ("# ttl: " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
|
||||
<> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
|
||||
<> "\n\n\
|
||||
\[WEB]\n\
|
||||
\# Set path to generate static mini-site for server information and qr codes/links\n"
|
||||
<> ("static_path: " <> T.pack (fromMaybe defaultStaticPath webStaticPath) <> "\n\n")
|
||||
<> "# Run an embedded server on this port\n\
|
||||
\# Onion sites can use any port and register it in the hidden service config.\n\
|
||||
\# Running on a port 80 may require setting process capabilities.\n\
|
||||
\# http: 8000\n\n\
|
||||
\# You can run an embedded TLS web server too if you provide port and cert and key files.\n\
|
||||
\# Not required for running relay on onion address.\n"
|
||||
<> (webDisabled <> "https: 443\n")
|
||||
<> (webDisabled <> "cert: " <> T.pack httpsCertFile <> "\n")
|
||||
<> (webDisabled <> "key: " <> T.pack httpsKeyFile <> "\n")
|
||||
where
|
||||
webDisabled = if disableWeb then "# " else ""
|
||||
\# Running on a port 80 may require setting process capabilities.\n"
|
||||
<> ((if disableWeb then "# " else "") <> "http: 8000\n\n")
|
||||
<> "# You can run an embedded TLS web server too if you provide port and cert and key files.\n\
|
||||
\# Not required for running relay on onion address.\n\
|
||||
\# https: 443\n"
|
||||
<> ("# cert: " <> T.pack httpsCertFile <> "\n")
|
||||
<> ("# key: " <> T.pack httpsKeyFile <> "\n")
|
||||
runServer ini = do
|
||||
hSetBuffering stdout LineBuffering
|
||||
hSetBuffering stderr LineBuffering
|
||||
fp <- checkSavedFingerprint cfgPath defaultX509Config
|
||||
let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
|
||||
port = T.unpack $ strictIni "TRANSPORT" "port" ini
|
||||
cfg@ServerConfig {information, storeLogFile, msgStoreType, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
|
||||
cfg@ServerConfig {information, transports, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
|
||||
sourceCode' = (\ServerPublicInfo {sourceCode} -> sourceCode) <$> information
|
||||
srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
|
||||
printServiceInfo serverVersion srv
|
||||
printSourceCode sourceCode'
|
||||
printServerConfig transports storeLogFile
|
||||
checkMsgStoreMode msgStoreType
|
||||
putStrLn $ case messageExpiration of
|
||||
Just ExpirationConfig {ttl} -> "expiring messages after " <> showTTL ttl
|
||||
_ -> "not expiring messages"
|
||||
@@ -357,54 +244,31 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
newQueuesAllowed = allowNewQueues cfg,
|
||||
basicAuthEnabled = isJust newQueueBasicAuth
|
||||
}
|
||||
case webStaticPath' of
|
||||
Just path | sharedHTTP -> do
|
||||
runWebServer path Nothing ServerInformation {config, information}
|
||||
attachStaticFiles path $ \attachHTTP -> do
|
||||
logDebug "Allocated web server resources"
|
||||
runSMPServer cfg (Just attachHTTP) `finally` logDebug "Releasing web server resources..."
|
||||
Just path -> do
|
||||
runWebServer path webHttpsParams' ServerInformation {config, information}
|
||||
runSMPServer cfg Nothing
|
||||
Nothing -> do
|
||||
logWarn "No server static path set"
|
||||
runSMPServer cfg Nothing
|
||||
logDebug "Bye"
|
||||
runWebServer ini ServerInformation {config, information}
|
||||
runSMPServer cfg
|
||||
where
|
||||
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
logStats = settingIsOn "STORE_LOG" "log_stats" ini
|
||||
c = combine cfgPath . ($ defaultX509Config)
|
||||
restoreMessagesFile path = case iniOnOff "STORE_LOG" "restore_messages" ini of
|
||||
Just True -> Just path
|
||||
Just False -> Nothing
|
||||
-- if the setting is not set, it is enabled when store log is enabled
|
||||
_ -> enableStoreLog $> path
|
||||
transports = iniTransports ini
|
||||
sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
|
||||
iniMsgStoreType = either error id $! readMsgStoreType ini
|
||||
serverConfig =
|
||||
ServerConfig
|
||||
{ transports,
|
||||
{ transports = iniTransports ini,
|
||||
smpHandshakeTimeout = 120000000,
|
||||
tbqSize = 128,
|
||||
msgStoreType = iniMsgStoreType,
|
||||
msgQueueQuota = defaultMsgQueueQuota,
|
||||
maxJournalMsgCount = defaultMaxJournalMsgCount,
|
||||
maxJournalStateLines = defaultMaxJournalStateLines,
|
||||
tbqSize = 64,
|
||||
msgQueueQuota = 128,
|
||||
queueIdBytes = 24,
|
||||
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
|
||||
smpCredentials =
|
||||
ServerCredentials
|
||||
{ caCertificateFile = Just $ c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c serverCrtFile
|
||||
},
|
||||
httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
|
||||
caCertificateFile = c caCrtFile,
|
||||
privateKeyFile = c serverKeyFile,
|
||||
certificateFile = c serverCrtFile,
|
||||
storeLogFile = enableStoreLog $> storeLogFilePath,
|
||||
storeMsgsFile = case iniMsgStoreType of
|
||||
AMSType SMSMemory -> restoreMessagesFile storeMsgsFilePath
|
||||
AMSType SMSJournal -> Just storeMsgsJournalDir,
|
||||
storeNtfsFile = restoreMessagesFile storeNtfsFilePath,
|
||||
storeMsgsFile =
|
||||
let messagesPath = combine logPath "smp-server-messages.log"
|
||||
in case iniOnOff "STORE_LOG" "restore_messages" ini of
|
||||
Just True -> Just messagesPath
|
||||
Just False -> Nothing
|
||||
-- if the setting is not set, it is enabled when store log is enabled
|
||||
_ -> enableStoreLog $> messagesPath,
|
||||
-- allow creating new queues by default
|
||||
allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
|
||||
newQueueBasicAuth = either error id <$!> strDecodeIni "AUTH" "create_password" ini,
|
||||
@@ -415,12 +279,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
defaultMessageExpiration
|
||||
{ ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
|
||||
},
|
||||
expireMessagesOnStart = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_start" ini,
|
||||
idleQueueInterval = defaultIdleQueueInterval,
|
||||
notificationExpiration =
|
||||
defaultNtfExpiration
|
||||
{ ttl = 3600 * readIniDefault defNtfExpirationHours "STORE_LOG" "expire_ntfs_hours" ini
|
||||
},
|
||||
inactiveClientExpiration =
|
||||
settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
|
||||
$> ExpirationConfig
|
||||
@@ -431,12 +289,11 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
logStatsStartTime = 0, -- seconds from 00:00 UTC
|
||||
serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
|
||||
serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
|
||||
pendingENDInterval = 15000000, -- 15 seconds
|
||||
ntfDeliveryInterval = 3000000, -- 3 seconds
|
||||
smpServerVRange = supportedServerSMPRelayVRange,
|
||||
transportConfig =
|
||||
defaultTransportServerConfig
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
|
||||
alpn = Just supportedSMPHandshakes
|
||||
},
|
||||
controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
|
||||
smpAgentCfg =
|
||||
@@ -449,7 +306,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
defaultNetworkConfig
|
||||
{ socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
|
||||
socksMode = maybe SMOnion (either error id) $! strDecodeIni "PROXY" "socks_mode" ini,
|
||||
hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "PROXY" "host_mode" ini,
|
||||
hostMode = either (const HMPublic) textToHostMode $ lookupValue "PROXY" "host_mode" ini,
|
||||
requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini
|
||||
}
|
||||
},
|
||||
@@ -460,50 +317,33 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini,
|
||||
information = serverPublicInfo ini
|
||||
}
|
||||
textToHostMode :: Text -> HostMode
|
||||
textToHostMode = \case
|
||||
"public" -> HMPublic
|
||||
"onion" -> HMOnionViaSocks
|
||||
s -> error . T.unpack $ "Invalid host_mode: " <> s
|
||||
textToOwnServers :: Text -> [ByteString]
|
||||
textToOwnServers = map encodeUtf8 . T.words
|
||||
runWebServer webStaticPath webHttpsParams si = do
|
||||
|
||||
runWebServer ini si =
|
||||
case eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini of
|
||||
Nothing -> logWarn "No server static path set"
|
||||
Just webStaticPath -> do
|
||||
let onionHost =
|
||||
either (const Nothing) (find isOnion) $
|
||||
strDecode @(L.NonEmpty TransportHost) . encodeUtf8 =<< lookupValue "TRANSPORT" "host" ini
|
||||
webHttpPort = eitherToMaybe $ read . T.unpack <$> lookupValue "WEB" "http" ini
|
||||
webHttpsParams =
|
||||
eitherToMaybe $ do
|
||||
port <- read . T.unpack <$> lookupValue "WEB" "https" ini
|
||||
cert <- T.unpack <$> lookupValue "WEB" "cert" ini
|
||||
key <- T.unpack <$> lookupValue "WEB" "key" ini
|
||||
pure WebHttpsParams {port, cert, key}
|
||||
generateSite si onionHost webStaticPath
|
||||
when (isJust webHttpPort || isJust webHttpsParams) $
|
||||
serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams}
|
||||
where
|
||||
isOnion = \case THOnionHost _ -> True; _ -> False
|
||||
webHttpsParams' =
|
||||
eitherToMaybe $ do
|
||||
port <- read . T.unpack <$> lookupValue "WEB" "https" ini
|
||||
cert <- T.unpack <$> lookupValue "WEB" "cert" ini
|
||||
key <- T.unpack <$> lookupValue "WEB" "key" ini
|
||||
pure WebHttpsParams {port, cert, key}
|
||||
webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
|
||||
|
||||
checkMsgStoreMode :: AMSType -> IO ()
|
||||
checkMsgStoreMode mode = do
|
||||
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
|
||||
msgsFileExists <- doesFileExist storeMsgsFilePath
|
||||
case mode of
|
||||
_ | msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
|
||||
AMSType SMSJournal
|
||||
| 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."
|
||||
AMSType SMSMemory
|
||||
| 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."
|
||||
exitFailure
|
||||
_ -> pure ()
|
||||
|
||||
exitConfigureMsgStorage = do
|
||||
putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present."
|
||||
putStrLn "Configure memory storage."
|
||||
exitFailure
|
||||
|
||||
data EmbeddedWebParams = EmbeddedWebParams
|
||||
{ webStaticPath :: FilePath,
|
||||
@@ -527,31 +367,28 @@ getServerSourceCode =
|
||||
simplexmqSource :: String
|
||||
simplexmqSource = "https://github.com/simplex-chat/simplexmq"
|
||||
|
||||
defaultControlPort :: Int
|
||||
defaultControlPort = 5224
|
||||
|
||||
informationIniContent :: InitOptions -> Text
|
||||
informationIniContent InitOptions {sourceCode, serverInfo} =
|
||||
informationIniContent :: Maybe Text -> Text
|
||||
informationIniContent sourceCode_ =
|
||||
"[INFORMATION]\n\
|
||||
\# AGPLv3 license requires that you make any source code modifications\n\
|
||||
\# available to the end users of the server.\n\
|
||||
\# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\
|
||||
\# Include correct source code URI in case the server source code is modified in any way.\n\
|
||||
\# If any other information fields are present, source code property also MUST be present.\n\n"
|
||||
<> (optDisabled sourceCode <> "source_code: " <> fromMaybe "URI" sourceCode)
|
||||
<> "\n\n\
|
||||
\# Declaring all below information is optional, any of these fields can be omitted.\n\
|
||||
<> (maybe "# source_code: URI" ("source_code: " <>) sourceCode_ <> "\n\n")
|
||||
<> "# Declaring all below information is optional, any of these fields can be omitted.\n\
|
||||
\\n\
|
||||
\# Server usage conditions and amendments.\n\
|
||||
\# It is recommended to use standard conditions with any amendments in a separate document.\n\
|
||||
\# usage_conditions: https://github.com/simplex-chat/simplex-chat/blob/stable/PRIVACY.md\n\
|
||||
\# condition_amendments: link\n\
|
||||
\\n\
|
||||
\# Server location and operator.\n"
|
||||
<> countryStr "server" serverCountry
|
||||
<> enitiyStrs "operator" operator
|
||||
<> (optDisabled website <> "website: " <> fromMaybe "" website)
|
||||
<> "\n\n\
|
||||
\# Server location and operator.\n\
|
||||
\# server_country: ISO-3166 2-letter code\n\
|
||||
\# operator: entity (organization or person name)\n\
|
||||
\# operator_country: ISO-3166 2-letter code\n\
|
||||
\# website:\n\
|
||||
\\n\
|
||||
\# Administrative contacts.\n\
|
||||
\# admin_simplex: SimpleX address\n\
|
||||
\# admin_email:\n\
|
||||
@@ -564,21 +401,9 @@ informationIniContent InitOptions {sourceCode, serverInfo} =
|
||||
\# complaints_pgp:\n\
|
||||
\# complaints_pgp_fingerprint:\n\
|
||||
\\n\
|
||||
\# Hosting provider.\n"
|
||||
<> enitiyStrs "hosting" hosting
|
||||
<> "\n\
|
||||
\# Hosting type can be `virtual`, `dedicated`, `colocation`, `owned`\n"
|
||||
<> ("hosting_type: " <> maybe "virtual" (decodeLatin1 . strEncode) hostingType <> "\n\n")
|
||||
where
|
||||
ServerPublicInfo {operator, website, hosting, hostingType, serverCountry} = serverInfo
|
||||
countryStr optName country = optDisabled country <> optName <> "_country: " <> fromMaybe "ISO-3166 2-letter code" country <> "\n"
|
||||
enitiyStrs optName entity =
|
||||
optDisabled entity
|
||||
<> optName
|
||||
<> ": "
|
||||
<> maybe "entity (organization or person name)" name entity
|
||||
<> "\n"
|
||||
<> countryStr optName (country =<< entity)
|
||||
\# Hosting provider.\n\
|
||||
\# hosting: entity (organization or person name)\n\
|
||||
\# hosting_country: ISO-3166 2-letter code\n\n"
|
||||
|
||||
serverPublicInfo :: Ini -> Maybe ServerPublicInfo
|
||||
serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
|
||||
@@ -594,14 +419,15 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
|
||||
website = infoValue "website",
|
||||
adminContacts = iniContacts "admin_simplex" "admin_email" "admin_pgp" "admin_pgp_fingerprint",
|
||||
complaintsContacts = iniContacts "complaints_simplex" "complaints_email" "complaints_pgp" "complaints_pgp_fingerprint",
|
||||
hosting = iniEntity "hosting" "hosting_country",
|
||||
hostingType = either error id <$!> strDecodeIni "INFORMATION" "hosting_type" ini
|
||||
hosting = iniEntity "hosting" "hosting_country"
|
||||
}
|
||||
infoValue name = eitherToMaybe $ lookupValue "INFORMATION" name ini
|
||||
iniEntity nameField countryField =
|
||||
(\name -> Entity {name, country = countryValue countryField})
|
||||
<$!> infoValue nameField
|
||||
countryValue field = (either error id . validCountryValue (T.unpack field) . T.unpack) <$!> infoValue field
|
||||
countryValue field =
|
||||
(\cs -> if T.length cs == 2 && T.all (\c -> isAscii c && isAlpha c) cs then T.map toUpper cs else error $ "Use ISO3166 2-letter code for " <> T.unpack field)
|
||||
<$!> infoValue field
|
||||
iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField =
|
||||
let simplex = either error id . parseAll (connReqUriP' Nothing) . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
|
||||
email = infoValue emailField
|
||||
@@ -612,14 +438,6 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
|
||||
(Nothing, Nothing, _, Nothing) -> Nothing
|
||||
(_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint}
|
||||
|
||||
optDisabled :: Maybe a -> Text
|
||||
optDisabled p = if isNothing p then "# " else ""
|
||||
|
||||
validCountryValue :: String -> String -> Either String Text
|
||||
validCountryValue field s
|
||||
| length s == 2 && all (\c -> isAscii c && isAlpha c) s = Right $ T.pack $ map toUpper s
|
||||
| otherwise = Left $ "Use ISO3166 2-letter code for " <> field
|
||||
|
||||
printSourceCode :: Maybe Text -> IO ()
|
||||
printSourceCode = \case
|
||||
Just sourceCode -> T.putStrLn $ "Server source code: " <> sourceCode
|
||||
@@ -632,9 +450,6 @@ data CliCommand
|
||||
| OnlineCert CertOptions
|
||||
| Start
|
||||
| Delete
|
||||
| Journal JournalCmd
|
||||
|
||||
data JournalCmd = JCImport | JCExport | JCDelete
|
||||
|
||||
data InitOptions = InitOptions
|
||||
{ enableStoreLog :: Bool,
|
||||
@@ -643,13 +458,7 @@ data InitOptions = InitOptions
|
||||
ip :: HostName,
|
||||
fqdn :: Maybe HostName,
|
||||
password :: Maybe ServerPassword,
|
||||
controlPort :: Maybe Int,
|
||||
socksProxy :: Maybe SocksProxy,
|
||||
ownDomains :: Maybe (L.NonEmpty TransportHost),
|
||||
sourceCode :: Maybe Text,
|
||||
serverInfo :: ServerPublicInfo,
|
||||
operatorCountry :: Maybe Text,
|
||||
hostingCountry :: Maybe Text,
|
||||
webStaticPath :: Maybe FilePath,
|
||||
disableWeb :: Bool,
|
||||
scripted :: Bool
|
||||
@@ -666,7 +475,6 @@ cliCommandP cfgPath logPath iniFile =
|
||||
<> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")"))
|
||||
<> command "start" (info (pure Start) (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"))
|
||||
)
|
||||
where
|
||||
initP :: Parser InitOptions
|
||||
@@ -719,45 +527,11 @@ cliCommandP cfgPath logPath iniFile =
|
||||
<> help "Set password to create new messaging queues"
|
||||
<> value SPRandom
|
||||
)
|
||||
controlPort <-
|
||||
flag' (Just defaultControlPort) (long "control-port" <> help ("Enable control port on " <> show defaultControlPort))
|
||||
<|> option strParse (long "control-port" <> help "Enable control port" <> metavar "PORT" <> value Nothing)
|
||||
socksProxy <-
|
||||
flag' (Just defaultSocksProxy) (long "socks-proxy" <> help "Outgoing SOCKS proxy on port 9050")
|
||||
<|> option
|
||||
strParse
|
||||
( long "socks-proxy"
|
||||
<> metavar "PROXY"
|
||||
<> help "Outgoing SOCKS proxy to forward messages to onion-only servers"
|
||||
<> value Nothing
|
||||
)
|
||||
ownDomains :: Maybe (L.NonEmpty TransportHost) <-
|
||||
option
|
||||
strParse
|
||||
( long "own-domains"
|
||||
<> metavar "DOMAINS"
|
||||
<> help "Own server domain names (comma-separated)"
|
||||
<> value Nothing
|
||||
)
|
||||
sourceCode <-
|
||||
flag' (Just simplexmqSource) (long "source-code" <> help ("Server source code (default: " <> simplexmqSource <> ")"))
|
||||
<|> (optional . strOption) (long "source-code" <> metavar "URI" <> help "Server source code")
|
||||
operator_ <- entityP "operator" "OPERATOR" "Server operator"
|
||||
hosting_ <- entityP "hosting" "HOSTING" "Hosting provider"
|
||||
hostingType <-
|
||||
option
|
||||
strParse
|
||||
( long "hosting-type"
|
||||
<> metavar "HOSTING_TYPE"
|
||||
<> help "Hosting type: virtual, dedicated, colocation, owned"
|
||||
<> value Nothing
|
||||
)
|
||||
serverCountry <- countryP "server" "SERVER" "Server datacenter"
|
||||
website <-
|
||||
(optional . strOption)
|
||||
( long "operator-website"
|
||||
<> help "Operator public website"
|
||||
<> metavar "WEBSITE"
|
||||
( long "source-code"
|
||||
<> help "Server source code will be communicated to the users"
|
||||
<> metavar "URI"
|
||||
)
|
||||
webStaticPath <-
|
||||
(optional . strOption)
|
||||
@@ -784,53 +558,10 @@ cliCommandP cfgPath logPath iniFile =
|
||||
ip,
|
||||
fqdn,
|
||||
password,
|
||||
controlPort,
|
||||
socksProxy,
|
||||
ownDomains,
|
||||
sourceCode = T.pack <$> sourceCode,
|
||||
serverInfo =
|
||||
ServerPublicInfo
|
||||
{ sourceCode = T.pack simplexmqSource,
|
||||
usageConditions = Nothing,
|
||||
operator = fst operator_,
|
||||
website,
|
||||
adminContacts = Nothing,
|
||||
complaintsContacts = Nothing,
|
||||
hosting = fst hosting_,
|
||||
hostingType,
|
||||
serverCountry
|
||||
},
|
||||
operatorCountry = snd operator_,
|
||||
hostingCountry = snd hosting_,
|
||||
sourceCode,
|
||||
webStaticPath,
|
||||
disableWeb,
|
||||
scripted
|
||||
}
|
||||
journalCmdP =
|
||||
hsubparser
|
||||
( command "import" (info (pure JCImport) (progDesc "Import message log file into a new journal storage"))
|
||||
<> command "export" (info (pure JCExport) (progDesc "Export journal storage to message log file"))
|
||||
<> command "delete" (info (pure JCDelete) (progDesc "Delete journal storage"))
|
||||
)
|
||||
|
||||
parseBasicAuth :: ReadM ServerPassword
|
||||
parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack
|
||||
entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)
|
||||
entityP opt' metavar' help' = do
|
||||
name_ <-
|
||||
(optional . strOption)
|
||||
( long opt'
|
||||
<> metavar (metavar' <> "_NAME")
|
||||
<> help (help' <> " name")
|
||||
)
|
||||
country <- countryP opt' metavar' help'
|
||||
pure ((\name -> Entity {name, country}) <$> name_, country)
|
||||
countryP :: String -> String -> String -> Parser (Maybe Text)
|
||||
countryP opt' metavar' help' =
|
||||
(optional . option (eitherReader $ validCountryValue opt'))
|
||||
( long (opt' <> "-country")
|
||||
<> metavar (metavar' <> "_COUNTRY")
|
||||
<> help (help' <> " country")
|
||||
)
|
||||
strParse :: StrEncoding a => ReadM a
|
||||
strParse = eitherReader $ parseAll strP . encodeUtf8 . T.pack
|
||||
|
||||
@@ -1,782 +0,0 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Server.MsgStore.Journal
|
||||
( JournalMsgStore (queues, senders, notifiers, random),
|
||||
JournalQueue,
|
||||
JournalMsgQueue (queue, state),
|
||||
JMQueue (queueDirectory, statePath),
|
||||
JournalStoreConfig (..),
|
||||
closeMsgQueue,
|
||||
closeMsgQueueHandles,
|
||||
-- below are exported for tests
|
||||
MsgQueueState (..),
|
||||
JournalState (..),
|
||||
SJournalType (..),
|
||||
msgQueueDirectory,
|
||||
msgQueueStatePath,
|
||||
readWriteQueueState,
|
||||
newMsgQueueState,
|
||||
newJournalId,
|
||||
appendState,
|
||||
queueLogFileName,
|
||||
journalFilePath,
|
||||
logFileExt,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import qualified Control.Exception as E
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isNothing)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import GHC.IO (catchAny)
|
||||
import Simplex.Messaging.Agent.Client (getMapLock, withLockMap)
|
||||
import Simplex.Messaging.Agent.Lock
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Server.MsgStore.Types
|
||||
import Simplex.Messaging.Server.QueueStore
|
||||
import Simplex.Messaging.Server.QueueStore.STM
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$>))
|
||||
import System.Directory
|
||||
import System.Exit
|
||||
import System.FilePath ((</>))
|
||||
import System.IO (BufferMode (..), Handle, IOMode (..), SeekMode (..), stdout)
|
||||
import qualified System.IO as IO
|
||||
import System.Random (StdGen, genByteString, newStdGen)
|
||||
|
||||
data JournalMsgStore = JournalMsgStore
|
||||
{ config :: JournalStoreConfig,
|
||||
random :: TVar StdGen,
|
||||
queueLocks :: TMap RecipientId Lock,
|
||||
queues :: TMap RecipientId JournalQueue,
|
||||
senders :: TMap SenderId RecipientId,
|
||||
notifiers :: TMap NotifierId RecipientId,
|
||||
storeLog :: TVar (Maybe (StoreLog 'WriteMode))
|
||||
}
|
||||
|
||||
data JournalStoreConfig = JournalStoreConfig
|
||||
{ storePath :: FilePath,
|
||||
pathParts :: Int,
|
||||
quota :: Int,
|
||||
-- Max number of messages per journal file - ignored in STM store.
|
||||
-- When this limit is reached, the file will be changed.
|
||||
-- This number should be set bigger than queue quota.
|
||||
maxMsgCount :: Int,
|
||||
maxStateLines :: Int,
|
||||
stateTailSize :: Int,
|
||||
-- time in seconds after which the queue will be closed after message expiration
|
||||
idleInterval :: Int64
|
||||
}
|
||||
|
||||
data JournalQueue = JournalQueue
|
||||
{ queueLock :: Lock,
|
||||
-- To avoid race conditions and errors when restoring queues,
|
||||
-- Nothing is written to TVar when queue is deleted.
|
||||
queueRec :: TVar (Maybe QueueRec),
|
||||
msgQueue_ :: TVar (Maybe JournalMsgQueue),
|
||||
-- system time in seconds since epoch
|
||||
activeAt :: TVar Int64,
|
||||
-- Just True - empty, Just False - non-empty, Nothing - unknown
|
||||
isEmpty :: TVar (Maybe Bool)
|
||||
}
|
||||
|
||||
data JMQueue = JMQueue
|
||||
{ queueDirectory :: FilePath,
|
||||
statePath :: FilePath
|
||||
}
|
||||
|
||||
data JournalMsgQueue = JournalMsgQueue
|
||||
{ queue :: JMQueue,
|
||||
state :: TVar MsgQueueState,
|
||||
-- tipMsg contains last message and length incl. newline
|
||||
-- Nothing - unknown, Just Nothing - empty queue.
|
||||
-- It prevents reading each message twice,
|
||||
-- and reading it after it was just written.
|
||||
tipMsg :: TVar (Maybe (Maybe (Message, Int64))),
|
||||
handles :: TVar (Maybe MsgQueueHandles)
|
||||
}
|
||||
|
||||
data MsgQueueState = MsgQueueState
|
||||
{ readState :: JournalState 'JTRead,
|
||||
writeState :: JournalState 'JTWrite,
|
||||
canWrite :: Bool,
|
||||
size :: Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data MsgQueueHandles = MsgQueueHandles
|
||||
{ stateHandle :: Handle, -- handle to queue state log file, rotates and removes old backups when server is restarted
|
||||
readHandle :: Handle,
|
||||
writeHandle :: Maybe Handle -- optional, used when write file is different from read file
|
||||
}
|
||||
|
||||
data JournalState t = JournalState
|
||||
{ journalType :: SJournalType t,
|
||||
journalId :: ByteString,
|
||||
msgPos :: Int,
|
||||
msgCount :: Int,
|
||||
bytePos :: Int64,
|
||||
byteCount :: Int64
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data JournalType = JTRead | JTWrite
|
||||
|
||||
data SJournalType (t :: JournalType) where
|
||||
SJTRead :: SJournalType 'JTRead
|
||||
SJTWrite :: SJournalType 'JTWrite
|
||||
|
||||
class JournalTypeI t where sJournalType :: SJournalType t
|
||||
|
||||
instance JournalTypeI 'JTRead where sJournalType = SJTRead
|
||||
|
||||
instance JournalTypeI 'JTWrite where sJournalType = SJTWrite
|
||||
|
||||
deriving instance Show (SJournalType t)
|
||||
|
||||
newMsgQueueState :: ByteString -> MsgQueueState
|
||||
newMsgQueueState journalId =
|
||||
MsgQueueState
|
||||
{ writeState = newJournalState journalId,
|
||||
readState = newJournalState journalId,
|
||||
canWrite = True,
|
||||
size = 0
|
||||
}
|
||||
|
||||
newJournalState :: JournalTypeI t => ByteString -> JournalState t
|
||||
newJournalState journalId = JournalState sJournalType journalId 0 0 0 0
|
||||
|
||||
journalFilePath :: FilePath -> ByteString -> FilePath
|
||||
journalFilePath dir journalId = dir </> (msgLogFileName <> "." <> B.unpack journalId <> logFileExt)
|
||||
|
||||
instance StrEncoding MsgQueueState where
|
||||
strEncode MsgQueueState {writeState, readState, canWrite, size} =
|
||||
B.unwords
|
||||
[ "write=" <> strEncode writeState,
|
||||
"read=" <> strEncode readState,
|
||||
"canWrite=" <> strEncode canWrite,
|
||||
"size=" <> strEncode size
|
||||
]
|
||||
strP = do
|
||||
writeState <- "write=" *> strP
|
||||
readState <- " read=" *> strP
|
||||
canWrite <- " canWrite=" *> strP
|
||||
size <- " size=" *> strP
|
||||
pure MsgQueueState {writeState, readState, canWrite, size}
|
||||
|
||||
instance JournalTypeI t => StrEncoding (JournalState t) where
|
||||
strEncode JournalState {journalId, msgPos, msgCount, bytePos, byteCount} =
|
||||
B.intercalate "," [journalId, e msgPos, e msgCount, e bytePos, e byteCount]
|
||||
where
|
||||
e :: StrEncoding a => a -> ByteString
|
||||
e = strEncode
|
||||
strP = do
|
||||
journalId <- A.takeTill (== ',')
|
||||
JournalState sJournalType journalId <$> i <*> i <*> i <*> i
|
||||
where
|
||||
i :: Integral a => A.Parser a
|
||||
i = A.char ',' *> A.decimal
|
||||
|
||||
queueLogFileName :: String
|
||||
queueLogFileName = "queue_state"
|
||||
|
||||
msgLogFileName :: String
|
||||
msgLogFileName = "messages"
|
||||
|
||||
logFileExt :: String
|
||||
logFileExt = ".log"
|
||||
|
||||
newtype StoreIO a = StoreIO {unStoreIO :: IO a}
|
||||
deriving newtype (Functor, Applicative, Monad)
|
||||
|
||||
instance STMQueueStore JournalMsgStore where
|
||||
queues' = queues
|
||||
senders' = senders
|
||||
notifiers' = notifiers
|
||||
storeLog' = storeLog
|
||||
mkQueue st qr = do
|
||||
lock <- getMapLock (queueLocks st) $ recipientId qr
|
||||
q <- newTVar $ Just qr
|
||||
mq <- newTVar Nothing
|
||||
activeAt <- newTVar 0
|
||||
isEmpty <- newTVar Nothing
|
||||
pure $ JournalQueue lock q mq activeAt isEmpty
|
||||
msgQueue_' = msgQueue_
|
||||
|
||||
instance MsgStoreClass JournalMsgStore where
|
||||
type StoreMonad JournalMsgStore = StoreIO
|
||||
type StoreQueue JournalMsgStore = JournalQueue
|
||||
type MsgQueue JournalMsgStore = JournalMsgQueue
|
||||
type MsgStoreConfig JournalMsgStore = JournalStoreConfig
|
||||
|
||||
newMsgStore :: JournalStoreConfig -> IO JournalMsgStore
|
||||
newMsgStore config = do
|
||||
random <- newTVarIO =<< newStdGen
|
||||
queueLocks <- TM.emptyIO
|
||||
queues <- TM.emptyIO
|
||||
senders <- TM.emptyIO
|
||||
notifiers <- TM.emptyIO
|
||||
storeLog <- newTVarIO Nothing
|
||||
pure JournalMsgStore {config, random, queueLocks, queues, senders, notifiers, storeLog}
|
||||
|
||||
setStoreLog :: JournalMsgStore -> StoreLog 'WriteMode -> IO ()
|
||||
setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl)
|
||||
|
||||
closeMsgStore st = do
|
||||
readTVarIO (storeLog st) >>= mapM_ closeStoreLog
|
||||
readTVarIO (queues st) >>= mapM_ closeMsgQueue
|
||||
|
||||
activeMsgQueues = queues
|
||||
{-# INLINE activeMsgQueues #-}
|
||||
|
||||
-- This function is a "foldr" that opens and closes all queues, processes them as defined by action and accumulates the result.
|
||||
-- It is used to export storage to a single file and also to expire messages and validate all queues when server is started.
|
||||
-- TODO this function requires case-sensitive file system, because it uses queue directory as recipient ID.
|
||||
-- It can be made to support case-insensite FS by supporting more than one queue per directory, by getting recipient ID from state file name.
|
||||
withAllMsgQueues :: forall a. Monoid a => Bool -> JournalMsgStore -> (RecipientId -> JournalQueue -> IO a) -> IO a
|
||||
withAllMsgQueues tty ms@JournalMsgStore {config} action = ifM (doesDirectoryExist storePath) processStore (pure mempty)
|
||||
where
|
||||
processStore = do
|
||||
(!count, !res) <- foldQueues 0 processQueue (0, mempty) ("", storePath)
|
||||
putStrLn $ progress count
|
||||
pure res
|
||||
JournalStoreConfig {storePath, pathParts} = config
|
||||
processQueue :: (Int, a) -> (String, FilePath) -> IO (Int, a)
|
||||
processQueue (!i, !r) (queueId, dir) = do
|
||||
when (tty && i `mod` 100 == 0) $ putStr (progress i <> "\r") >> IO.hFlush stdout
|
||||
r' <- case strDecode $ B.pack queueId of
|
||||
Right rId ->
|
||||
getQueue ms SRecipient rId >>= \case
|
||||
Right q -> unStoreIO (getMsgQueue ms rId q) *> action rId q <* closeMsgQueue q
|
||||
Left AUTH -> do
|
||||
logWarn $ "STORE: processQueue, queue " <> T.pack queueId <> " was removed, removing " <> T.pack dir
|
||||
removeQueueDirectory_ dir
|
||||
pure mempty
|
||||
Left e -> do
|
||||
logError $ "STORE: processQueue, error getting queue " <> T.pack queueId <> ", " <> tshow e
|
||||
exitFailure
|
||||
Left e -> do
|
||||
logError $ "STORE: processQueue, message queue directory " <> T.pack dir <> " is invalid, " <> tshow e
|
||||
exitFailure
|
||||
pure (i + 1, r <> r')
|
||||
progress i = "Processed: " <> show i <> " queues"
|
||||
foldQueues depth f acc (queueId, path) = do
|
||||
let f' = if depth == pathParts - 1 then f else foldQueues (depth + 1) f
|
||||
listDirs >>= foldM f' acc
|
||||
where
|
||||
listDirs = fmap catMaybes . mapM queuePath =<< listDirectory path
|
||||
queuePath dir = do
|
||||
let !path' = path </> dir
|
||||
!queueId' = queueId <> dir
|
||||
ifM
|
||||
(doesDirectoryExist path')
|
||||
(pure $ Just (queueId', path'))
|
||||
(Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping"))
|
||||
|
||||
logQueueStates :: JournalMsgStore -> IO ()
|
||||
logQueueStates ms = withActiveMsgQueues ms $ \_ -> unStoreIO . logQueueState
|
||||
|
||||
logQueueState :: JournalQueue -> StoreIO ()
|
||||
logQueueState q =
|
||||
StoreIO . void $
|
||||
readTVarIO (msgQueue_ q)
|
||||
$>>= \mq -> readTVarIO (handles mq)
|
||||
$>>= (\hs -> (readTVarIO (state mq) >>= appendState (stateHandle hs)) $> Just ())
|
||||
|
||||
queueRec' = queueRec
|
||||
{-# INLINE queueRec' #-}
|
||||
|
||||
getMsgQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> StoreIO JournalMsgQueue
|
||||
getMsgQueue ms@JournalMsgStore {random} rId JournalQueue {msgQueue_} =
|
||||
StoreIO $ readTVarIO msgQueue_ >>= maybe newQ pure
|
||||
where
|
||||
newQ = do
|
||||
let dir = msgQueueDirectory ms rId
|
||||
statePath = msgQueueStatePath dir $ B.unpack (strEncode rId)
|
||||
queue = JMQueue {queueDirectory = dir, statePath}
|
||||
q <- ifM (doesDirectoryExist dir) (openMsgQueue ms queue) (createQ queue)
|
||||
atomically $ writeTVar msgQueue_ $ Just q
|
||||
pure q
|
||||
where
|
||||
createQ :: JMQueue -> IO JournalMsgQueue
|
||||
createQ queue = do
|
||||
-- folder and files are not created here,
|
||||
-- to avoid file IO for queues without messages during subscription
|
||||
journalId <- newJournalId random
|
||||
mkJournalQueue queue (newMsgQueueState journalId) Nothing
|
||||
|
||||
getPeekMsgQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> StoreIO (Maybe (JournalMsgQueue, Message))
|
||||
getPeekMsgQueue ms rId q@JournalQueue {isEmpty} =
|
||||
StoreIO (readTVarIO isEmpty) >>= \case
|
||||
Just True -> pure Nothing
|
||||
Just False -> peek
|
||||
Nothing -> do
|
||||
-- We only close the queue if we just learnt it's empty.
|
||||
-- This is needed to reduce file descriptors and memory usage
|
||||
-- after the server just started and many clients subscribe.
|
||||
-- In case the queue became non-empty on write and then again empty on read
|
||||
-- we won't be closing it, to avoid frequent open/close on active queues.
|
||||
r <- peek
|
||||
when (isNothing r) $ StoreIO $ closeMsgQueue q
|
||||
pure r
|
||||
where
|
||||
peek = do
|
||||
mq <- getMsgQueue ms rId q
|
||||
(mq,) <$$> tryPeekMsg_ q mq
|
||||
|
||||
-- only runs action if queue is not empty
|
||||
withIdleMsgQueue :: Int64 -> JournalMsgStore -> RecipientId -> JournalQueue -> (JournalMsgQueue -> StoreIO a) -> StoreIO (Maybe a, Int)
|
||||
withIdleMsgQueue now ms@JournalMsgStore {config} rId q action =
|
||||
StoreIO $ readTVarIO (msgQueue_ q) >>= \case
|
||||
Nothing ->
|
||||
E.bracket
|
||||
(unStoreIO $ getPeekMsgQueue ms rId q)
|
||||
(mapM_ $ \_ -> closeMsgQueue q)
|
||||
(maybe (pure (Nothing, 0)) (unStoreIO . run))
|
||||
where
|
||||
run (mq, _) = do
|
||||
r <- action mq
|
||||
sz <- getQueueSize_ mq
|
||||
pure (Just r, sz)
|
||||
Just mq -> do
|
||||
ts <- readTVarIO $ activeAt q
|
||||
r <- if now - ts >= idleInterval config
|
||||
then Just <$> unStoreIO (action mq) `E.finally` closeMsgQueue q
|
||||
else pure Nothing
|
||||
sz <- unStoreIO $ getQueueSize_ mq
|
||||
pure (r, sz)
|
||||
|
||||
deleteQueue :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType QueueRec)
|
||||
deleteQueue ms rId q =
|
||||
fst <$$> deleteQueue_ ms rId q
|
||||
|
||||
deleteQueueSize :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType (QueueRec, Int))
|
||||
deleteQueueSize ms rId q =
|
||||
deleteQueue_ ms rId q >>= mapM (traverse getSize)
|
||||
-- traverse operates on the second tuple element
|
||||
where
|
||||
getSize = maybe (pure (-1)) (fmap size . readTVarIO . state)
|
||||
|
||||
getQueueMessages_ :: Bool -> JournalMsgQueue -> StoreIO [Message]
|
||||
getQueueMessages_ drainMsgs q = StoreIO (run [])
|
||||
where
|
||||
run msgs = readTVarIO (handles q) >>= maybe (pure []) (getMsg msgs)
|
||||
getMsg msgs hs = chooseReadJournal q drainMsgs hs >>= maybe (pure msgs) readMsg
|
||||
where
|
||||
readMsg (rs, h) = do
|
||||
(msg, len) <- hGetMsgAt h $ bytePos rs
|
||||
updateReadPos q drainMsgs len hs
|
||||
(msg :) <$> run msgs
|
||||
|
||||
writeMsg :: JournalMsgStore -> RecipientId -> JournalQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
|
||||
writeMsg ms rId q' logState msg = isolateQueue rId q' "writeMsg" $ do
|
||||
q <- getMsgQueue ms rId q'
|
||||
StoreIO $ (`E.finally` updateActiveAt q') $ do
|
||||
st@MsgQueueState {canWrite, size} <- readTVarIO (state q)
|
||||
let empty = size == 0
|
||||
if canWrite || empty
|
||||
then do
|
||||
atomically $ writeTVar (isEmpty q') (Just False)
|
||||
let canWrt' = quota > size
|
||||
if canWrt'
|
||||
then writeToJournal q st canWrt' msg $> Just (msg, empty)
|
||||
else writeToJournal q st canWrt' msgQuota $> Nothing
|
||||
else pure Nothing
|
||||
where
|
||||
JournalStoreConfig {quota, maxMsgCount} = config ms
|
||||
msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg}
|
||||
writeToJournal q st@MsgQueueState {writeState, readState = rs, size} canWrt' !msg' = do
|
||||
let msgStr = strEncode msg' `B.snoc` '\n'
|
||||
msgLen = fromIntegral $ B.length msgStr
|
||||
hs <- maybe createQueueDir pure =<< readTVarIO handles
|
||||
(ws, wh) <- case writeHandle hs of
|
||||
Nothing | msgCount writeState >= maxMsgCount -> switchWriteJournal hs
|
||||
wh_ -> pure (writeState, fromMaybe (readHandle hs) wh_)
|
||||
let msgPos' = msgPos ws + 1
|
||||
bytePos' = bytePos ws + msgLen
|
||||
ws' = ws {msgPos = msgPos', msgCount = msgPos', bytePos = bytePos', byteCount = bytePos'}
|
||||
rs' = if journalId ws == journalId rs then rs {msgCount = msgPos', byteCount = bytePos'} else rs
|
||||
!st' = st {writeState = ws', readState = rs', canWrite = canWrt', size = size + 1}
|
||||
hAppend wh (bytePos ws) msgStr
|
||||
updateQueueState q logState hs st' $
|
||||
when (size == 0) $ writeTVar (tipMsg q) $ Just (Just (msg, msgLen))
|
||||
where
|
||||
JournalMsgQueue {queue = JMQueue {queueDirectory, statePath}, handles} = q
|
||||
createQueueDir = do
|
||||
createDirectoryIfMissing True queueDirectory
|
||||
sh <- openFile statePath AppendMode
|
||||
B.hPutStr sh ""
|
||||
rh <- createNewJournal queueDirectory $ journalId rs
|
||||
let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = Nothing}
|
||||
atomically $ writeTVar handles $ Just hs
|
||||
pure hs
|
||||
switchWriteJournal hs = do
|
||||
journalId <- newJournalId $ random ms
|
||||
wh <- createNewJournal queueDirectory journalId
|
||||
atomically $ writeTVar handles $ Just $ hs {writeHandle = Just wh}
|
||||
pure (newJournalState journalId, wh)
|
||||
|
||||
-- can ONLY be used while restoring messages, not while server running
|
||||
setOverQuota_ :: JournalQueue -> IO ()
|
||||
setOverQuota_ q =
|
||||
readTVarIO (msgQueue_ q)
|
||||
>>= mapM_ (\JournalMsgQueue {state} -> atomically $ modifyTVar' state $ \st -> st {canWrite = False})
|
||||
|
||||
getQueueSize_ :: JournalMsgQueue -> StoreIO Int
|
||||
getQueueSize_ JournalMsgQueue {state} = StoreIO $ size <$> readTVarIO state
|
||||
|
||||
tryPeekMsg_ :: JournalQueue -> JournalMsgQueue -> StoreIO (Maybe Message)
|
||||
tryPeekMsg_ q mq@JournalMsgQueue {tipMsg, handles} =
|
||||
StoreIO $ (readTVarIO handles $>>= chooseReadJournal mq True $>>= peekMsg) >>= setEmpty
|
||||
where
|
||||
peekMsg (rs, h) = readTVarIO tipMsg >>= maybe readMsg (pure . fmap fst)
|
||||
where
|
||||
readMsg = do
|
||||
ml@(msg, _) <- hGetMsgAt h $ bytePos rs
|
||||
atomically $ writeTVar tipMsg $ Just (Just ml)
|
||||
pure $ Just msg
|
||||
setEmpty msg = do
|
||||
atomically $ writeTVar (isEmpty q) (Just $ isNothing msg)
|
||||
pure msg
|
||||
|
||||
tryDeleteMsg_ :: JournalQueue -> JournalMsgQueue -> Bool -> StoreIO ()
|
||||
tryDeleteMsg_ q mq@JournalMsgQueue {tipMsg, handles} logState = StoreIO $ (`E.finally` when logState (updateActiveAt q)) $
|
||||
void $
|
||||
readTVarIO tipMsg -- if there is no cached tipMsg, do nothing
|
||||
$>>= (pure . fmap snd)
|
||||
$>>= \len -> readTVarIO handles
|
||||
$>>= \hs -> updateReadPos mq logState len hs $> Just ()
|
||||
|
||||
isolateQueue :: RecipientId -> JournalQueue -> String -> StoreIO a -> ExceptT ErrorType IO a
|
||||
isolateQueue rId JournalQueue {queueLock} op =
|
||||
tryStore' op rId . withLock' queueLock op . unStoreIO
|
||||
|
||||
updateActiveAt :: JournalQueue -> IO ()
|
||||
updateActiveAt q = atomically . writeTVar (activeAt q) . systemSeconds =<< getSystemTime
|
||||
|
||||
tryStore' :: String -> RecipientId -> IO a -> ExceptT ErrorType IO a
|
||||
tryStore' op rId = tryStore op rId . fmap Right
|
||||
|
||||
tryStore :: forall a. String -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
|
||||
tryStore op rId a = ExceptT $ E.mask_ $ E.try a >>= either storeErr pure
|
||||
where
|
||||
storeErr :: E.SomeException -> IO (Either ErrorType a)
|
||||
storeErr e =
|
||||
let e' = intercalate ", " [op, B.unpack $ strEncode rId, show e]
|
||||
in logError ("STORE: " <> T.pack e') $> Left (STORE e')
|
||||
|
||||
isolateQueueId :: String -> JournalMsgStore -> RecipientId -> IO (Either ErrorType a) -> ExceptT ErrorType IO a
|
||||
isolateQueueId op ms rId = tryStore op rId . withLockMap (queueLocks ms) rId op
|
||||
|
||||
openMsgQueue :: JournalMsgStore -> JMQueue -> IO JournalMsgQueue
|
||||
openMsgQueue ms q@JMQueue {queueDirectory = dir, statePath} = do
|
||||
(st, sh) <- readWriteQueueState ms statePath
|
||||
(st', rh, wh_) <- closeOnException sh $ openJournals ms dir st sh
|
||||
let hs = MsgQueueHandles {stateHandle = sh, readHandle = rh, writeHandle = wh_}
|
||||
mkJournalQueue q st' (Just hs)
|
||||
|
||||
mkJournalQueue :: JMQueue -> MsgQueueState -> Maybe MsgQueueHandles -> IO JournalMsgQueue
|
||||
mkJournalQueue queue st hs_ = do
|
||||
state <- newTVarIO st
|
||||
tipMsg <- newTVarIO Nothing
|
||||
handles <- newTVarIO hs_
|
||||
-- using the same queue lock which is currently locked,
|
||||
-- to avoid map lookup on queue operations
|
||||
pure JournalMsgQueue {queue, state, tipMsg, handles}
|
||||
|
||||
chooseReadJournal :: JournalMsgQueue -> Bool -> MsgQueueHandles -> IO (Maybe (JournalState 'JTRead, Handle))
|
||||
chooseReadJournal q log' hs = do
|
||||
st@MsgQueueState {writeState = ws, readState = rs} <- readTVarIO (state q)
|
||||
case writeHandle hs of
|
||||
Just wh | msgPos rs >= msgCount rs && journalId rs /= journalId ws -> do
|
||||
-- switching to write journal
|
||||
atomically $ writeTVar (handles q) $ Just hs {readHandle = wh, writeHandle = Nothing}
|
||||
hClose $ readHandle hs
|
||||
when log' $ removeJournal (queueDirectory $ queue q) rs
|
||||
let !rs' = (newJournalState $ journalId ws) {msgCount = msgCount ws, byteCount = byteCount ws}
|
||||
!st' = st {readState = rs'}
|
||||
updateQueueState q log' hs st' $ pure ()
|
||||
pure $ Just (rs', wh)
|
||||
_ | msgPos rs >= msgCount rs && journalId rs == journalId ws -> pure Nothing
|
||||
_ -> pure $ Just (rs, readHandle hs)
|
||||
|
||||
updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> STM () -> IO ()
|
||||
updateQueueState q log' hs st a = do
|
||||
unless (validQueueState st) $ E.throwIO $ userError $ "updateQueueState invalid state: " <> show st
|
||||
when log' $ appendState (stateHandle hs) st
|
||||
atomically $ writeTVar (state q) st >> a
|
||||
|
||||
appendState :: Handle -> MsgQueueState -> IO ()
|
||||
appendState h st = E.uninterruptibleMask_ $ B.hPutStr h $ strEncode st `B.snoc` '\n'
|
||||
|
||||
updateReadPos :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO ()
|
||||
updateReadPos q log' len hs = do
|
||||
st@MsgQueueState {readState = rs, size} <- readTVarIO (state q)
|
||||
let JournalState {msgPos, bytePos} = rs
|
||||
let msgPos' = msgPos + 1
|
||||
rs' = rs {msgPos = msgPos', bytePos = bytePos + len}
|
||||
st' = st {readState = rs', size = size - 1}
|
||||
updateQueueState q log' hs st' $ writeTVar (tipMsg q) Nothing
|
||||
|
||||
msgQueueDirectory :: JournalMsgStore -> RecipientId -> FilePath
|
||||
msgQueueDirectory JournalMsgStore {config = JournalStoreConfig {storePath, pathParts}} rId =
|
||||
storePath </> B.unpack (B.intercalate "/" $ splitSegments pathParts $ strEncode rId)
|
||||
where
|
||||
splitSegments _ "" = []
|
||||
splitSegments 1 s = [s]
|
||||
splitSegments n s =
|
||||
let (seg, s') = B.splitAt 2 s
|
||||
in seg : splitSegments (n - 1) s'
|
||||
|
||||
msgQueueStatePath :: FilePath -> String -> FilePath
|
||||
msgQueueStatePath dir queueId = dir </> (queueLogFileName <> "." <> queueId <> logFileExt)
|
||||
|
||||
createNewJournal :: FilePath -> ByteString -> IO Handle
|
||||
createNewJournal dir journalId = do
|
||||
let path = journalFilePath dir journalId -- TODO retry if file exists
|
||||
h <- openFile path ReadWriteMode
|
||||
B.hPutStr h ""
|
||||
pure h
|
||||
|
||||
newJournalId :: TVar StdGen -> IO ByteString
|
||||
newJournalId g = strEncode <$> atomically (stateTVar g $ genByteString 12)
|
||||
|
||||
openJournals :: JournalMsgStore -> FilePath -> MsgQueueState -> Handle -> IO (MsgQueueState, Handle, Maybe Handle)
|
||||
openJournals ms dir st@MsgQueueState {readState = rs, writeState = ws} sh = do
|
||||
let rjId = journalId rs
|
||||
wjId = journalId ws
|
||||
openJournal rs >>= \case
|
||||
Left path
|
||||
| rjId == wjId -> do
|
||||
logError $ "STORE: openJournals, no read/write file - creating new file, " <> T.pack path
|
||||
newReadJournal
|
||||
| otherwise -> do
|
||||
let rs' = (newJournalState wjId) {msgCount = msgCount ws, byteCount = byteCount ws}
|
||||
st' = st {readState = rs', size = msgCount ws}
|
||||
openJournal rs' >>= \case
|
||||
Left path' -> do
|
||||
logError $ "STORE: openJournals, no read and write files - creating new file, read: " <> T.pack path <> ", write: " <> T.pack path'
|
||||
newReadJournal
|
||||
Right rh -> do
|
||||
logError $ "STORE: openJournals, no read file - switched to write file, " <> T.pack path
|
||||
closeOnException rh $ fixFileSize rh $ bytePos ws
|
||||
pure (st', rh, Nothing)
|
||||
Right rh
|
||||
| rjId == wjId -> do
|
||||
closeOnException rh $ fixFileSize rh $ bytePos ws
|
||||
pure (st, rh, Nothing)
|
||||
| otherwise -> closeOnException rh $ do
|
||||
fixFileSize rh $ byteCount rs
|
||||
openJournal ws >>= \case
|
||||
Left path -> do
|
||||
let msgs = msgCount rs
|
||||
bytes = byteCount rs
|
||||
size' = msgs - msgPos rs
|
||||
ws' = (newJournalState rjId) {msgPos = msgs, msgCount = msgs, bytePos = bytes, byteCount = bytes}
|
||||
st' = st {writeState = ws', size = size'} -- we don't amend canWrite to trigger QCONT
|
||||
logError $ "STORE: openJournals, no write file, " <> T.pack path
|
||||
pure (st', rh, Nothing)
|
||||
Right wh -> do
|
||||
closeOnException wh $ fixFileSize wh $ bytePos ws
|
||||
pure (st, rh, Just wh)
|
||||
where
|
||||
newReadJournal = do
|
||||
rjId' <- newJournalId $ random ms
|
||||
rh <- createNewJournal dir rjId'
|
||||
let st' = newMsgQueueState rjId'
|
||||
closeOnException rh $ appendState sh st'
|
||||
pure (st', rh, Nothing)
|
||||
openJournal :: JournalState t -> IO (Either FilePath Handle)
|
||||
openJournal JournalState {journalId} =
|
||||
let path = journalFilePath dir journalId
|
||||
in ifM (doesFileExist path) (Right <$> openFile path ReadWriteMode) (pure $ Left path)
|
||||
-- do that for all append operations
|
||||
|
||||
fixFileSize :: Handle -> Int64 -> IO ()
|
||||
fixFileSize h pos = do
|
||||
let pos' = fromIntegral pos
|
||||
size <- IO.hFileSize h
|
||||
if
|
||||
| size > pos' -> do
|
||||
name <- IO.hShow h
|
||||
logWarn $ "STORE: fixFileSize, size " <> tshow size <> " > pos " <> tshow pos <> " - truncating, " <> T.pack name
|
||||
IO.hSetFileSize h pos'
|
||||
| size < pos' -> do
|
||||
-- From code logic this can't happen.
|
||||
name <- IO.hShow h
|
||||
E.throwIO $ userError $ "fixFileSize size " <> show size <> " < pos " <> show pos <> " - aborting: " <> name
|
||||
| otherwise -> pure ()
|
||||
|
||||
removeJournal :: FilePath -> JournalState t -> IO ()
|
||||
removeJournal dir JournalState {journalId} = do
|
||||
let path = journalFilePath dir journalId
|
||||
removeFile path `catchAny` (\e -> logError $ "STORE: removeJournal, " <> T.pack path <> ", " <> tshow e)
|
||||
|
||||
-- This function is supposed to be resilient to crashes while updating state files,
|
||||
-- and also resilient to crashes during its execution.
|
||||
readWriteQueueState :: JournalMsgStore -> FilePath -> IO (MsgQueueState, Handle)
|
||||
readWriteQueueState JournalMsgStore {random, config} statePath =
|
||||
ifM
|
||||
(doesFileExist tempBackup)
|
||||
(renameFile tempBackup statePath >> readQueueState)
|
||||
(ifM (doesFileExist statePath) readQueueState writeNewQueueState)
|
||||
where
|
||||
tempBackup = statePath <> ".bak"
|
||||
readQueueState = do
|
||||
ls <- B.lines <$> readFileTail
|
||||
case ls of
|
||||
[] -> writeNewQueueState
|
||||
_ -> do
|
||||
r@(st, _) <- useLastLine (length ls) True ls
|
||||
unless (validQueueState st) $ E.throwIO $ userError $ "readWriteQueueState inconsistent state: " <> show st
|
||||
pure r
|
||||
writeNewQueueState = do
|
||||
logWarn $ "STORE: readWriteQueueState, empty queue state - initialized, " <> T.pack statePath
|
||||
st <- newMsgQueueState <$> newJournalId random
|
||||
writeQueueState st
|
||||
useLastLine len isLastLine ls = case strDecode $ last ls of
|
||||
Right st
|
||||
| len > maxStateLines config || not isLastLine ->
|
||||
backupWriteQueueState st
|
||||
| otherwise -> do
|
||||
-- when state file has fewer than maxStateLines, we don't compact it
|
||||
sh <- openFile statePath AppendMode
|
||||
pure (st, sh)
|
||||
Left e -- if the last line failed to parse
|
||||
| isLastLine -> case init ls of -- or use the previous line
|
||||
[] -> do
|
||||
logWarn $ "STORE: readWriteQueueState, invalid 1-line queue state - initialized, " <> T.pack statePath
|
||||
st <- newMsgQueueState <$> newJournalId random
|
||||
backupWriteQueueState st
|
||||
ls' -> do
|
||||
logWarn $ "STORE: readWriteQueueState, invalid last line in queue state - using the previous line, " <> T.pack statePath
|
||||
useLastLine len False ls'
|
||||
| otherwise -> E.throwIO $ userError $ "readWriteQueueState invalid state " <> statePath <> ": " <> show e
|
||||
backupWriteQueueState st = do
|
||||
-- State backup is made in two steps to mitigate the crash during the backup.
|
||||
-- Temporary backup file will be used when it is present.
|
||||
renameFile statePath tempBackup -- 1) temp backup
|
||||
r <- writeQueueState st -- 2) save state
|
||||
ts <- getCurrentTime
|
||||
renameFile tempBackup (statePath <> "." <> iso8601Show ts <> ".bak") -- 3) timed backup
|
||||
pure r
|
||||
writeQueueState st = do
|
||||
sh <- openFile statePath AppendMode
|
||||
closeOnException sh $ appendState sh st
|
||||
pure (st, sh)
|
||||
readFileTail =
|
||||
IO.withFile statePath ReadMode $ \h -> do
|
||||
size <- IO.hFileSize h
|
||||
let sz = stateTailSize config
|
||||
sz' = fromIntegral sz
|
||||
if size > sz'
|
||||
then IO.hSeek h AbsoluteSeek (size - sz') >> B.hGet h sz
|
||||
else B.hGet h (fromIntegral size)
|
||||
|
||||
validQueueState :: MsgQueueState -> Bool
|
||||
validQueueState MsgQueueState {readState = rs, writeState = ws, size}
|
||||
| journalId rs == journalId ws =
|
||||
alwaysValid
|
||||
&& msgPos rs <= msgPos ws
|
||||
&& msgCount rs == msgCount ws
|
||||
&& bytePos rs <= bytePos ws
|
||||
&& byteCount rs == byteCount ws
|
||||
&& size == msgCount rs - msgPos rs
|
||||
| otherwise =
|
||||
alwaysValid
|
||||
&& size == msgCount ws + msgCount rs - msgPos rs
|
||||
where
|
||||
alwaysValid =
|
||||
msgPos rs <= msgCount rs
|
||||
&& bytePos rs <= byteCount rs
|
||||
&& msgPos ws == msgCount ws
|
||||
&& bytePos ws == byteCount ws
|
||||
|
||||
deleteQueue_ :: JournalMsgStore -> RecipientId -> JournalQueue -> IO (Either ErrorType (QueueRec, Maybe JournalMsgQueue))
|
||||
deleteQueue_ ms rId q =
|
||||
runExceptT $ isolateQueueId "deleteQueue_" ms rId $
|
||||
deleteQueue' ms rId q >>= mapM remove
|
||||
where
|
||||
remove r@(_, mq_) = do
|
||||
mapM_ closeMsgQueueHandles mq_
|
||||
removeQueueDirectory ms rId
|
||||
pure r
|
||||
|
||||
closeMsgQueue :: JournalQueue -> IO ()
|
||||
closeMsgQueue JournalQueue {msgQueue_} = atomically (swapTVar msgQueue_ Nothing) >>= mapM_ closeMsgQueueHandles
|
||||
|
||||
closeMsgQueueHandles :: JournalMsgQueue -> IO ()
|
||||
closeMsgQueueHandles q = readTVarIO (handles q) >>= mapM_ closeHandles
|
||||
where
|
||||
closeHandles (MsgQueueHandles sh rh wh_) = do
|
||||
hClose sh
|
||||
hClose rh
|
||||
mapM_ hClose wh_
|
||||
|
||||
removeQueueDirectory :: JournalMsgStore -> RecipientId -> IO ()
|
||||
removeQueueDirectory st = removeQueueDirectory_ . msgQueueDirectory st
|
||||
|
||||
removeQueueDirectory_ :: FilePath -> IO ()
|
||||
removeQueueDirectory_ dir =
|
||||
removePathForcibly dir `catchAny` \e ->
|
||||
logError $ "STORE: removeQueueDirectory, " <> T.pack dir <> ", " <> tshow e
|
||||
|
||||
hAppend :: Handle -> Int64 -> ByteString -> IO ()
|
||||
hAppend h pos s = do
|
||||
fixFileSize h pos
|
||||
IO.hSeek h SeekFromEnd 0
|
||||
B.hPutStr h s
|
||||
|
||||
hGetMsgAt :: Handle -> Int64 -> IO (Message, Int64)
|
||||
hGetMsgAt h pos = do
|
||||
IO.hSeek h AbsoluteSeek $ fromIntegral pos
|
||||
s <- B.hGetLine h
|
||||
case strDecode s of
|
||||
Right !msg ->
|
||||
let !len = fromIntegral (B.length s) + 1
|
||||
in pure (msg, len)
|
||||
Left e -> E.throwIO $ userError $ "hGetMsgAt invalid message: " <> e
|
||||
|
||||
openFile :: FilePath -> IOMode -> IO Handle
|
||||
openFile f mode = do
|
||||
h <- IO.openFile f mode
|
||||
IO.hSetBuffering h LineBuffering
|
||||
pure h
|
||||
|
||||
hClose :: Handle -> IO ()
|
||||
hClose h =
|
||||
IO.hClose h `catchAny` \e -> do
|
||||
name <- IO.hShow h
|
||||
logError $ "STORE: hClose, " <> T.pack name <> ", " <> tshow e
|
||||
|
||||
closeOnException :: Handle -> IO a -> IO a
|
||||
closeOnException h a = a `E.onException` hClose h
|
||||
@@ -1,175 +1,119 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Server.MsgStore.STM
|
||||
( STMMsgStore (..),
|
||||
STMStoreConfig (..),
|
||||
( STMMsgStore,
|
||||
MsgQueue (..),
|
||||
newMsgStore,
|
||||
getMsgQueue,
|
||||
delMsgQueue,
|
||||
delMsgQueueSize,
|
||||
writeMsg,
|
||||
tryPeekMsg,
|
||||
peekMsg,
|
||||
tryDelMsg,
|
||||
tryDelPeekMsg,
|
||||
deleteExpiredMsgs,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Server.MsgStore.Types
|
||||
import Simplex.Messaging.Server.QueueStore
|
||||
import Simplex.Messaging.Server.QueueStore.STM
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Data.Time.Clock.System (SystemTime (systemSeconds))
|
||||
import Simplex.Messaging.Protocol (Message (..), MsgId, RecipientId)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util ((<$$>), ($>>=))
|
||||
import System.IO (IOMode (..))
|
||||
import UnliftIO.STM
|
||||
|
||||
data STMMsgStore = STMMsgStore
|
||||
{ storeConfig :: STMStoreConfig,
|
||||
queues :: TMap RecipientId STMQueue,
|
||||
senders :: TMap SenderId RecipientId,
|
||||
notifiers :: TMap NotifierId RecipientId,
|
||||
storeLog :: TVar (Maybe (StoreLog 'WriteMode))
|
||||
}
|
||||
|
||||
data STMQueue = STMQueue
|
||||
{ -- To avoid race conditions and errors when restoring queues,
|
||||
-- Nothing is written to TVar when queue is deleted.
|
||||
queueRec :: TVar (Maybe QueueRec),
|
||||
msgQueue_ :: TVar (Maybe STMMsgQueue)
|
||||
}
|
||||
|
||||
data STMMsgQueue = STMMsgQueue
|
||||
data MsgQueue = MsgQueue
|
||||
{ msgQueue :: TQueue Message,
|
||||
quota :: Int,
|
||||
canWrite :: TVar Bool,
|
||||
size :: TVar Int
|
||||
}
|
||||
|
||||
data STMStoreConfig = STMStoreConfig
|
||||
{ storePath :: Maybe FilePath,
|
||||
quota :: Int
|
||||
}
|
||||
type STMMsgStore = TMap RecipientId MsgQueue
|
||||
|
||||
instance STMQueueStore STMMsgStore where
|
||||
queues' = queues
|
||||
senders' = senders
|
||||
notifiers' = notifiers
|
||||
storeLog' = storeLog
|
||||
mkQueue _ qr = STMQueue <$> newTVar (Just qr) <*> newTVar Nothing
|
||||
msgQueue_' = msgQueue_
|
||||
newMsgStore :: IO STMMsgStore
|
||||
newMsgStore = TM.emptyIO
|
||||
|
||||
instance MsgStoreClass STMMsgStore where
|
||||
type StoreMonad STMMsgStore = STM
|
||||
type StoreQueue STMMsgStore = STMQueue
|
||||
type MsgQueue STMMsgStore = STMMsgQueue
|
||||
type MsgStoreConfig STMMsgStore = STMStoreConfig
|
||||
getMsgQueue :: STMMsgStore -> RecipientId -> Int -> STM MsgQueue
|
||||
getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st
|
||||
where
|
||||
newQ = do
|
||||
msgQueue <- newTQueue
|
||||
canWrite <- newTVar True
|
||||
size <- newTVar 0
|
||||
let q = MsgQueue {msgQueue, quota, canWrite, size}
|
||||
TM.insert rId q st
|
||||
pure q
|
||||
|
||||
newMsgStore :: STMStoreConfig -> IO STMMsgStore
|
||||
newMsgStore storeConfig = do
|
||||
queues <- TM.emptyIO
|
||||
senders <- TM.emptyIO
|
||||
notifiers <- TM.emptyIO
|
||||
storeLog <- newTVarIO Nothing
|
||||
pure STMMsgStore {storeConfig, queues, senders, notifiers, storeLog}
|
||||
delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
|
||||
delMsgQueue st rId = TM.delete rId st
|
||||
|
||||
setStoreLog :: STMMsgStore -> StoreLog 'WriteMode -> IO ()
|
||||
setStoreLog st sl = atomically $ writeTVar (storeLog st) (Just sl)
|
||||
delMsgQueueSize :: STMMsgStore -> RecipientId -> STM Int
|
||||
delMsgQueueSize st rId = TM.lookupDelete rId st >>= maybe (pure 0) (\MsgQueue {size} -> readTVar size)
|
||||
|
||||
closeMsgStore st = readTVarIO (storeLog st) >>= mapM_ closeStoreLog
|
||||
writeMsg :: MsgQueue -> Message -> STM (Maybe (Message, Bool))
|
||||
writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do
|
||||
canWrt <- readTVar canWrite
|
||||
empty <- isEmptyTQueue q
|
||||
if canWrt || empty
|
||||
then do
|
||||
canWrt' <- (quota >) <$> readTVar size
|
||||
writeTVar canWrite $! canWrt'
|
||||
modifyTVar' size (+ 1)
|
||||
if canWrt'
|
||||
then writeTQueue q msg $> Just (msg, empty)
|
||||
else (writeTQueue q $! msgQuota) $> Nothing
|
||||
else pure Nothing
|
||||
where
|
||||
msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
|
||||
|
||||
activeMsgQueues = queues
|
||||
{-# INLINE activeMsgQueues #-}
|
||||
tryPeekMsg :: MsgQueue -> STM (Maybe Message)
|
||||
tryPeekMsg = tryPeekTQueue . msgQueue
|
||||
{-# INLINE tryPeekMsg #-}
|
||||
|
||||
withAllMsgQueues _ = withActiveMsgQueues
|
||||
{-# INLINE withAllMsgQueues #-}
|
||||
peekMsg :: MsgQueue -> STM Message
|
||||
peekMsg = peekTQueue . msgQueue
|
||||
{-# INLINE peekMsg #-}
|
||||
|
||||
logQueueStates _ = pure ()
|
||||
tryDelMsg :: MsgQueue -> MsgId -> STM (Maybe Message)
|
||||
tryDelMsg mq msgId' =
|
||||
tryPeekMsg mq >>= \case
|
||||
msg_@(Just msg)
|
||||
| msgId msg == msgId' || B.null msgId' -> tryDeleteMsg mq >> pure msg_
|
||||
| otherwise -> pure Nothing
|
||||
_ -> pure Nothing
|
||||
|
||||
logQueueState _ = pure ()
|
||||
-- atomic delete (== read) last and peek next message if available
|
||||
tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Maybe Message, Maybe Message)
|
||||
tryDelPeekMsg mq msgId' =
|
||||
tryPeekMsg mq >>= \case
|
||||
msg_@(Just msg)
|
||||
| msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg mq >> tryPeekMsg mq)
|
||||
| otherwise -> pure (Nothing, msg_)
|
||||
_ -> pure (Nothing, Nothing)
|
||||
|
||||
queueRec' = queueRec
|
||||
{-# INLINE queueRec' #-}
|
||||
deleteExpiredMsgs :: MsgQueue -> Int64 -> STM Int
|
||||
deleteExpiredMsgs mq old = loop 0
|
||||
where
|
||||
loop dc =
|
||||
tryPeekMsg mq >>= \case
|
||||
Just Message {msgTs}
|
||||
| systemSeconds msgTs < old ->
|
||||
tryDeleteMsg mq >> loop (dc + 1)
|
||||
_ -> pure dc
|
||||
|
||||
getMsgQueue :: STMMsgStore -> RecipientId -> STMQueue -> STM STMMsgQueue
|
||||
getMsgQueue _ _ STMQueue {msgQueue_} = readTVar msgQueue_ >>= maybe newQ pure
|
||||
where
|
||||
newQ = do
|
||||
msgQueue <- newTQueue
|
||||
canWrite <- newTVar True
|
||||
size <- newTVar 0
|
||||
let q = STMMsgQueue {msgQueue, canWrite, size}
|
||||
writeTVar msgQueue_ (Just q)
|
||||
pure q
|
||||
|
||||
getPeekMsgQueue :: STMMsgStore -> RecipientId -> 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 -> RecipientId -> 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 -> RecipientId -> STMQueue -> IO (Either ErrorType QueueRec)
|
||||
deleteQueue ms rId q = fst <$$> deleteQueue' ms rId q
|
||||
|
||||
deleteQueueSize :: STMMsgStore -> RecipientId -> STMQueue -> IO (Either ErrorType (QueueRec, Int))
|
||||
deleteQueueSize ms rId q = deleteQueue' ms rId q >>= mapM (traverse getSize)
|
||||
-- traverse operates on the second tuple element
|
||||
where
|
||||
getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size)
|
||||
|
||||
getQueueMessages_ :: Bool -> STMMsgQueue -> STM [Message]
|
||||
getQueueMessages_ drainMsgs = (if drainMsgs then flushTQueue else snapshotTQueue) . msgQueue
|
||||
where
|
||||
snapshotTQueue q = do
|
||||
msgs <- flushTQueue q
|
||||
mapM_ (writeTQueue q) msgs
|
||||
pure msgs
|
||||
|
||||
writeMsg :: STMMsgStore -> RecipientId -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
|
||||
writeMsg ms rId q' _logState msg = liftIO $ atomically $ do
|
||||
STMMsgQueue {msgQueue = q, canWrite, size} <- getMsgQueue ms rId q'
|
||||
canWrt <- readTVar canWrite
|
||||
empty <- isEmptyTQueue q
|
||||
if canWrt || empty
|
||||
then do
|
||||
canWrt' <- (quota >) <$> readTVar size
|
||||
writeTVar canWrite $! canWrt'
|
||||
modifyTVar' size (+ 1)
|
||||
if canWrt'
|
||||
then (writeTQueue q $! msg) $> Just (msg, empty)
|
||||
else (writeTQueue q $! msgQuota) $> Nothing
|
||||
else pure Nothing
|
||||
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)
|
||||
|
||||
getQueueSize_ :: STMMsgQueue -> STM Int
|
||||
getQueueSize_ STMMsgQueue {size} = readTVar size
|
||||
|
||||
tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message)
|
||||
tryPeekMsg_ _ = tryPeekTQueue . msgQueue
|
||||
{-# INLINE tryPeekMsg_ #-}
|
||||
|
||||
tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM ()
|
||||
tryDeleteMsg_ _ STMMsgQueue {msgQueue = q, size} _logState =
|
||||
tryReadTQueue q >>= \case
|
||||
Just _ -> modifyTVar' size (subtract 1)
|
||||
_ -> pure ()
|
||||
|
||||
isolateQueue :: RecipientId -> STMQueue -> String -> STM a -> ExceptT ErrorType IO a
|
||||
isolateQueue _ _ _ = liftIO . atomically
|
||||
tryDeleteMsg :: MsgQueue -> STM ()
|
||||
tryDeleteMsg MsgQueue {msgQueue = q, size} =
|
||||
tryReadTQueue q >>= \case
|
||||
Just _ -> modifyTVar' size (subtract 1)
|
||||
_ -> pure ()
|
||||
|
||||
@@ -1,141 +0,0 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Redundant multi-way if" #-}
|
||||
|
||||
module Simplex.Messaging.Server.MsgStore.Types where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (foldM)
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Time.Clock.System (SystemTime (systemSeconds))
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Server.QueueStore
|
||||
import Simplex.Messaging.Server.StoreLog.Types
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import Simplex.Messaging.Util ((<$$>))
|
||||
import System.IO (IOMode (..))
|
||||
|
||||
class MsgStoreClass s => STMQueueStore s where
|
||||
queues' :: s -> TMap RecipientId (StoreQueue s)
|
||||
senders' :: s -> TMap SenderId RecipientId
|
||||
notifiers' :: s -> TMap NotifierId RecipientId
|
||||
storeLog' :: s -> TVar (Maybe (StoreLog 'WriteMode))
|
||||
mkQueue :: s -> QueueRec -> STM (StoreQueue s)
|
||||
msgQueue_' :: StoreQueue s -> TVar (Maybe (MsgQueue s))
|
||||
|
||||
class Monad (StoreMonad s) => MsgStoreClass s where
|
||||
type StoreMonad s = (m :: Type -> Type) | m -> s
|
||||
type MsgStoreConfig s = c | c -> s
|
||||
type StoreQueue s = q | q -> s
|
||||
type MsgQueue s = q | q -> s
|
||||
newMsgStore :: MsgStoreConfig s -> IO s
|
||||
setStoreLog :: s -> StoreLog 'WriteMode -> IO ()
|
||||
closeMsgStore :: s -> IO ()
|
||||
activeMsgQueues :: s -> TMap RecipientId (StoreQueue s)
|
||||
withAllMsgQueues :: Monoid a => Bool -> s -> (RecipientId -> StoreQueue s -> IO a) -> IO a
|
||||
logQueueStates :: s -> IO ()
|
||||
logQueueState :: StoreQueue s -> StoreMonad s ()
|
||||
queueRec' :: StoreQueue s -> TVar (Maybe QueueRec)
|
||||
getPeekMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message))
|
||||
getMsgQueue :: s -> RecipientId -> StoreQueue s -> StoreMonad s (MsgQueue s)
|
||||
|
||||
-- the journal queue will be closed after action if it was initially closed or idle longer than interval in config
|
||||
withIdleMsgQueue :: Int64 -> s -> RecipientId -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
|
||||
deleteQueue :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType QueueRec)
|
||||
deleteQueueSize :: s -> RecipientId -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
|
||||
getQueueMessages_ :: Bool -> MsgQueue s -> StoreMonad s [Message]
|
||||
writeMsg :: s -> RecipientId -> 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 :: RecipientId -> StoreQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a
|
||||
|
||||
data MSType = MSMemory | MSJournal
|
||||
|
||||
data SMSType :: MSType -> Type where
|
||||
SMSMemory :: SMSType 'MSMemory
|
||||
SMSJournal :: SMSType 'MSJournal
|
||||
|
||||
data AMSType = forall s. AMSType (SMSType s)
|
||||
|
||||
withActiveMsgQueues :: (MsgStoreClass s, Monoid a) => s -> (RecipientId -> StoreQueue s -> IO a) -> IO a
|
||||
withActiveMsgQueues st f = readTVarIO (activeMsgQueues st) >>= foldM run mempty . M.assocs
|
||||
where
|
||||
run !acc (k, v) = do
|
||||
r <- f k v
|
||||
pure $! acc <> r
|
||||
|
||||
getQueueMessages :: MsgStoreClass s => Bool -> s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO [Message]
|
||||
getQueueMessages drainMsgs st rId q = withPeekMsgQueue st rId q "getQueueSize" $ maybe (pure []) (getQueueMessages_ drainMsgs . fst)
|
||||
{-# INLINE getQueueMessages #-}
|
||||
|
||||
getQueueSize :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO Int
|
||||
getQueueSize st rId q = withPeekMsgQueue st rId q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst)
|
||||
{-# INLINE getQueueSize #-}
|
||||
|
||||
tryPeekMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
|
||||
tryPeekMsg st rId q = snd <$$> withPeekMsgQueue st rId q "tryPeekMsg" pure
|
||||
{-# INLINE tryPeekMsg #-}
|
||||
|
||||
tryDelMsg :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message)
|
||||
tryDelMsg st rId q msgId' =
|
||||
withPeekMsgQueue st rId 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 :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
|
||||
tryDelPeekMsg st rId q msgId' =
|
||||
withPeekMsgQueue st rId 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)
|
||||
|
||||
-- The action is called with Nothing when it is known that the queue is empty
|
||||
withPeekMsgQueue :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> String -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
|
||||
withPeekMsgQueue st rId q op a = isolateQueue rId q op $ getPeekMsgQueue st rId q >>= a
|
||||
{-# INLINE withPeekMsgQueue #-}
|
||||
|
||||
deleteExpiredMsgs :: MsgStoreClass s => s -> RecipientId -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int
|
||||
deleteExpiredMsgs st rId q old =
|
||||
isolateQueue rId q "deleteExpiredMsgs" $
|
||||
getMsgQueue st rId q >>= deleteExpireMsgs_ old q
|
||||
|
||||
-- closed and idle queues will be closed after expiration
|
||||
-- returns (expired count, queue size after expiration)
|
||||
idleDeleteExpiredMsgs :: MsgStoreClass s => Int64 -> s -> RecipientId -> StoreQueue s -> Int64 -> ExceptT ErrorType IO (Maybe Int, Int)
|
||||
idleDeleteExpiredMsgs now st rId q old =
|
||||
isolateQueue rId q "idleDeleteExpiredMsgs" $
|
||||
withIdleMsgQueue now st rId q (deleteExpireMsgs_ old q)
|
||||
|
||||
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
|
||||
@@ -1,67 +0,0 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Messaging.Server.NtfStore where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (foldM)
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Time.Clock.System (SystemTime (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (EncNMsgMeta, MsgId, NotifierId)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
|
||||
newtype NtfStore = NtfStore (TMap NotifierId (TVar [MsgNtf]))
|
||||
|
||||
data MsgNtf = MsgNtf
|
||||
{ ntfMsgId :: MsgId,
|
||||
ntfTs :: SystemTime,
|
||||
ntfNonce :: C.CbNonce,
|
||||
ntfEncMeta :: EncNMsgMeta
|
||||
}
|
||||
|
||||
storeNtf :: NtfStore -> NotifierId -> MsgNtf -> IO ()
|
||||
storeNtf (NtfStore ns) nId ntf = do
|
||||
TM.lookupIO nId ns >>= atomically . maybe newNtfs (`modifyTVar'` (ntf :))
|
||||
-- TODO coalesce messages here once the client is updated to process multiple messages
|
||||
-- for single notification.
|
||||
-- when (isJust prevNtf) $ incStat $ msgNtfReplaced stats
|
||||
where
|
||||
newNtfs = TM.lookup nId ns >>= maybe (TM.insertM nId (newTVar [ntf]) ns) (`modifyTVar'` (ntf :))
|
||||
|
||||
deleteNtfs :: NtfStore -> NotifierId -> IO Int
|
||||
deleteNtfs (NtfStore ns) nId = atomically (TM.lookupDelete nId ns) >>= maybe (pure 0) (fmap length . readTVarIO)
|
||||
|
||||
deleteExpiredNtfs :: NtfStore -> Int64 -> IO Int
|
||||
deleteExpiredNtfs (NtfStore ns) old =
|
||||
foldM (\expired -> fmap (expired +) . expireQueue) 0 . M.keys =<< readTVarIO ns
|
||||
where
|
||||
expireQueue nId = TM.lookupIO nId ns >>= maybe (pure 0) expire
|
||||
expire v = readTVarIO v >>= \case
|
||||
[] -> pure 0
|
||||
_ ->
|
||||
atomically $ readTVar v >>= \case
|
||||
[] -> pure 0
|
||||
-- check the last message first, it is the earliest
|
||||
ntfs | systemSeconds (ntfTs $ last $ ntfs) < old -> do
|
||||
let !ntfs' = filter (\MsgNtf {ntfTs = ts} -> systemSeconds ts >= old) ntfs
|
||||
writeTVar v ntfs'
|
||||
pure $! length ntfs - length ntfs'
|
||||
_ -> pure 0
|
||||
|
||||
data NtfLogRecord = NLRv1 NotifierId MsgNtf
|
||||
|
||||
instance StrEncoding MsgNtf where
|
||||
strEncode MsgNtf {ntfMsgId, ntfTs, ntfNonce, ntfEncMeta} = strEncode (ntfMsgId, ntfTs, ntfNonce, ntfEncMeta)
|
||||
strP = do
|
||||
(ntfMsgId, ntfTs, ntfNonce, ntfEncMeta) <- strP
|
||||
pure MsgNtf {ntfMsgId, ntfTs, ntfNonce, ntfEncMeta}
|
||||
|
||||
instance StrEncoding NtfLogRecord where
|
||||
strEncode (NLRv1 nId ntf) = strEncode (Str "v1", nId, ntf)
|
||||
strP = "v1 " *> (NLRv1 <$> strP_ <*> strP)
|
||||
@@ -1,13 +1,10 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Simplex.Messaging.Server.QueueStore where
|
||||
|
||||
import Data.Int (Int64)
|
||||
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
|
||||
@@ -19,8 +16,7 @@ data QueueRec = QueueRec
|
||||
senderKey :: !(Maybe SndPublicAuthKey),
|
||||
sndSecure :: !SenderCanSecure,
|
||||
notifier :: !(Maybe NtfCreds),
|
||||
status :: !ServerQueueStatus,
|
||||
updatedAt :: !(Maybe RoundedSystemTime)
|
||||
status :: !ServerQueueStatus
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@@ -38,16 +34,3 @@ instance StrEncoding NtfCreds where
|
||||
pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
|
||||
|
||||
data ServerQueueStatus = QueueActive | QueueOff deriving (Eq, Show)
|
||||
|
||||
newtype RoundedSystemTime = RoundedSystemTime Int64
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance StrEncoding RoundedSystemTime where
|
||||
strEncode (RoundedSystemTime t) = strEncode t
|
||||
strP = RoundedSystemTime <$> strP
|
||||
|
||||
getRoundedSystemTime :: Int64 -> IO RoundedSystemTime
|
||||
getRoundedSystemTime prec = (\t -> RoundedSystemTime $ (systemSeconds t `div` prec) * prec) <$> getSystemTime
|
||||
|
||||
getSystemDate :: IO RoundedSystemTime
|
||||
getSystemDate = getRoundedSystemTime 86400
|
||||
|
||||
@@ -1,196 +1,112 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Simplex.Messaging.Server.QueueStore.STM
|
||||
( addQueue,
|
||||
( QueueStore (..),
|
||||
newQueueStore,
|
||||
addQueue,
|
||||
getQueue,
|
||||
getQueueRec,
|
||||
secureQueue,
|
||||
addQueueNotifier,
|
||||
deleteQueueNotifier,
|
||||
suspendQueue,
|
||||
updateQueueTime,
|
||||
deleteQueue',
|
||||
readQueueStore,
|
||||
withLog',
|
||||
deleteQueue,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Control.Exception as E
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Bitraversable (bimapM)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Functor (($>))
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Server.MsgStore.Types
|
||||
import Simplex.Messaging.Server.QueueStore
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (ifM, tshow, ($>>=), (<$$))
|
||||
import System.IO
|
||||
import Simplex.Messaging.Util (ifM, ($>>=))
|
||||
import UnliftIO.STM
|
||||
|
||||
addQueue :: STMQueueStore s => s -> QueueRec -> IO (Either ErrorType (StoreQueue s))
|
||||
addQueue st qr@QueueRec {recipientId = rId, senderId = sId, notifier}=
|
||||
atomically add
|
||||
$>>= \q -> q <$$ withLog "addQueue" st (`logCreateQueue` qr)
|
||||
data QueueStore = QueueStore
|
||||
{ queues :: TMap RecipientId (TVar QueueRec),
|
||||
senders :: TMap SenderId RecipientId,
|
||||
notifiers :: TMap NotifierId RecipientId
|
||||
}
|
||||
|
||||
newQueueStore :: IO QueueStore
|
||||
newQueueStore = do
|
||||
queues <- TM.emptyIO
|
||||
senders <- TM.emptyIO
|
||||
notifiers <- TM.emptyIO
|
||||
pure QueueStore {queues, senders, notifiers}
|
||||
|
||||
addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())
|
||||
addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = do
|
||||
ifM hasId (pure $ Left DUPLICATE_) $ do
|
||||
qVar <- newTVar q
|
||||
TM.insert rId qVar queues
|
||||
TM.insert sId rId senders
|
||||
pure $ Right ()
|
||||
where
|
||||
add = ifM hasId (pure $ Left DUPLICATE_) $ do
|
||||
q <- mkQueue st qr -- STMQueue lock <$> (newTVar $! Just qr) <*> newTVar Nothing
|
||||
TM.insert rId q $ queues' st
|
||||
TM.insert sId rId $ senders' st
|
||||
forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId $ notifiers' st
|
||||
pure $ Right q
|
||||
hasId = or <$> sequence [TM.member rId $ queues' st, TM.member sId $ senders' st, hasNotifier]
|
||||
hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId (notifiers' st)) notifier
|
||||
hasId = (||) <$> TM.member rId queues <*> TM.member sId senders
|
||||
|
||||
getQueue :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
|
||||
getQueue st party qId =
|
||||
maybe (Left AUTH) Right <$> case party of
|
||||
SRecipient -> TM.lookupIO qId $ queues' st
|
||||
SSender -> TM.lookupIO qId (senders' st) $>>= (`TM.lookupIO` queues' st)
|
||||
SNotifier -> TM.lookupIO qId (notifiers' st) $>>= (`TM.lookupIO` queues' st)
|
||||
|
||||
getQueueRec :: (STMQueueStore s, DirectParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s, QueueRec))
|
||||
getQueueRec st party qId =
|
||||
getQueue st party qId
|
||||
$>>= (\q -> maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec' q))
|
||||
|
||||
secureQueue :: STMQueueStore s => s -> StoreQueue s -> SndPublicAuthKey -> IO (Either ErrorType ())
|
||||
secureQueue st sq sKey =
|
||||
atomically (readQueueRec qr $>>= secure)
|
||||
$>>= \rId -> withLog "secureQueue" st $ \s -> logSecureQueue s rId sKey
|
||||
getQueue :: DirectParty p => QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec)
|
||||
getQueue QueueStore {queues, senders, notifiers} party qId =
|
||||
toResult <$> (mapM readTVar =<< getVar)
|
||||
where
|
||||
qr = queueRec' sq
|
||||
secure q@QueueRec {recipientId = rId} = case senderKey q of
|
||||
Just k -> pure $ if sKey == k then Right rId else Left AUTH
|
||||
Nothing -> do
|
||||
writeTVar qr $ Just q {senderKey = Just sKey}
|
||||
pure $ Right rId
|
||||
getVar = case party of
|
||||
SRecipient -> TM.lookup qId queues
|
||||
SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues)
|
||||
SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues)
|
||||
|
||||
addQueueNotifier :: STMQueueStore s => s -> StoreQueue s -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
|
||||
addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId} =
|
||||
atomically (readQueueRec qr $>>= add)
|
||||
$>>= \(rId, nId_) -> nId_ <$$ withLog "addQueueNotifier" st (\s -> logAddNotifier s rId ntfCreds)
|
||||
where
|
||||
qr = queueRec' sq
|
||||
add q@QueueRec {recipientId = rId} = ifM (TM.member nId (notifiers' st)) (pure $ Left DUPLICATE_) $ do
|
||||
nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId (notifiers' st) $> notifierId
|
||||
let !q' = q {notifier = Just ntfCreds}
|
||||
writeTVar qr $ Just q'
|
||||
TM.insert nId rId $ notifiers' st
|
||||
pure $ Right (rId, nId_)
|
||||
secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> STM (Either ErrorType QueueRec)
|
||||
secureQueue QueueStore {queues} rId sKey =
|
||||
withQueue rId queues $ \qVar ->
|
||||
readTVar qVar >>= \q -> case senderKey q of
|
||||
Just k -> pure $ if sKey == k then Just q else Nothing
|
||||
_ ->
|
||||
let !q' = q {senderKey = Just sKey}
|
||||
in writeTVar qVar q' $> Just q'
|
||||
|
||||
deleteQueueNotifier :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType (Maybe NotifierId))
|
||||
deleteQueueNotifier st sq =
|
||||
atomically (readQueueRec qr >>= mapM delete)
|
||||
$>>= \(rId, nId_) -> nId_ <$$ withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
|
||||
where
|
||||
qr = queueRec' sq
|
||||
delete q = fmap (recipientId q,) $ forM (notifier q) $ \NtfCreds {notifierId} -> do
|
||||
TM.delete notifierId $ notifiers' st
|
||||
writeTVar qr $! Just q {notifier = Nothing}
|
||||
pure notifierId
|
||||
addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec)
|
||||
addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do
|
||||
ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $
|
||||
withQueue rId queues $ \qVar -> do
|
||||
q <- readTVar qVar
|
||||
forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId
|
||||
writeTVar qVar $! q {notifier = Just ntfCreds}
|
||||
TM.insert nId rId notifiers
|
||||
pure $ Just q
|
||||
|
||||
suspendQueue :: STMQueueStore s => s -> StoreQueue s -> IO (Either ErrorType ())
|
||||
suspendQueue st sq =
|
||||
atomically (readQueueRec qr >>= mapM suspend)
|
||||
$>>= \rId -> withLog "suspendQueue" st (`logSuspendQueue` rId)
|
||||
where
|
||||
qr = queueRec' sq
|
||||
suspend q = do
|
||||
writeTVar qr $! Just q {status = QueueOff}
|
||||
pure $ recipientId q
|
||||
deleteQueueNotifier :: QueueStore -> RecipientId -> STM (Either ErrorType ())
|
||||
deleteQueueNotifier QueueStore {queues, notifiers} rId =
|
||||
withQueue rId queues $ \qVar -> do
|
||||
q <- readTVar qVar
|
||||
forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
|
||||
writeTVar qVar $! q {notifier = Nothing}
|
||||
pure $ Just ()
|
||||
|
||||
updateQueueTime :: STMQueueStore s => s -> StoreQueue s -> RoundedSystemTime -> IO (Either ErrorType QueueRec)
|
||||
updateQueueTime st sq t = atomically (readQueueRec qr >>= mapM update) $>>= log'
|
||||
where
|
||||
qr = queueRec' sq
|
||||
update q@QueueRec {updatedAt}
|
||||
| updatedAt == Just t = pure (q, False)
|
||||
| otherwise =
|
||||
let !q' = q {updatedAt = Just t}
|
||||
in (writeTVar qr $! Just q') $> (q', True)
|
||||
log' (q, changed)
|
||||
| changed = q <$$ withLog "updateQueueTime" st (\sl -> logUpdateQueueTime sl (recipientId q) t)
|
||||
| otherwise = pure $ Right q
|
||||
suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
|
||||
suspendQueue QueueStore {queues} rId =
|
||||
withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just ()
|
||||
|
||||
deleteQueue' :: STMQueueStore s => s -> RecipientId -> StoreQueue s -> IO (Either ErrorType (QueueRec, Maybe (MsgQueue s)))
|
||||
deleteQueue' st rId sq =
|
||||
atomically (readQueueRec qr >>= mapM delete)
|
||||
$>>= \q -> withLog "deleteQueue" st (`logDeleteQueue` rId)
|
||||
>>= bimapM pure (\_ -> (q,) <$> atomically (swapTVar (msgQueue_' sq) Nothing))
|
||||
where
|
||||
qr = queueRec' sq
|
||||
delete q = do
|
||||
writeTVar qr Nothing
|
||||
TM.delete (senderId q) $ senders' st
|
||||
forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId $ notifiers' st
|
||||
pure q
|
||||
deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType QueueRec)
|
||||
deleteQueue QueueStore {queues, senders, notifiers} rId = do
|
||||
TM.lookupDelete rId queues >>= \case
|
||||
Just qVar ->
|
||||
readTVar qVar >>= \q -> do
|
||||
TM.delete (senderId q) senders
|
||||
forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers
|
||||
pure $ Right q
|
||||
_ -> pure $ Left AUTH
|
||||
|
||||
readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
|
||||
readQueueRec qr = maybe (Left AUTH) Right <$> readTVar qr
|
||||
{-# INLINE readQueueRec #-}
|
||||
toResult :: Maybe a -> Either ErrorType a
|
||||
toResult = maybe (Left AUTH) Right
|
||||
|
||||
withLog' :: String -> TVar (Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
|
||||
withLog' name sl action =
|
||||
readTVarIO sl
|
||||
>>= maybe (pure $ Right ()) (E.try . action >=> bimapM logErr pure)
|
||||
where
|
||||
logErr :: E.SomeException -> IO ErrorType
|
||||
logErr e = logError ("STORE: " <> T.pack err) $> STORE err
|
||||
where
|
||||
err = name <> ", withLog, " <> show e
|
||||
|
||||
withLog :: STMQueueStore s => String -> s -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
|
||||
withLog name = withLog' name . storeLog'
|
||||
|
||||
readQueueStore :: forall s. STMQueueStore s => FilePath -> s -> IO ()
|
||||
readQueueStore f st = withFile f ReadMode $ LB.hGetContents >=> mapM_ processLine . LB.lines
|
||||
where
|
||||
processLine :: LB.ByteString -> IO ()
|
||||
processLine s' = either printError procLogRecord (strDecode s)
|
||||
where
|
||||
s = LB.toStrict s'
|
||||
procLogRecord :: StoreLogRecord -> IO ()
|
||||
procLogRecord = \case
|
||||
CreateQueue q -> addQueue st q >>= qError (recipientId q) "CreateQueue"
|
||||
SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey
|
||||
AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds
|
||||
SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st
|
||||
DeleteQueue qId -> withQueue qId "DeleteQueue" $ deleteQueue st qId
|
||||
DeleteNotifier qId -> withQueue qId "DeleteNotifier" $ deleteQueueNotifier st
|
||||
UpdateTime qId t -> withQueue qId "UpdateTime" $ \q -> updateQueueTime st q t
|
||||
printError :: String -> IO ()
|
||||
printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
|
||||
withQueue :: forall a. RecipientId -> T.Text -> (StoreQueue s -> IO (Either ErrorType a)) -> IO ()
|
||||
withQueue qId op a = runExceptT go >>= qError qId op
|
||||
where
|
||||
go = do
|
||||
q <- ExceptT $ getQueue st SRecipient qId
|
||||
liftIO (readTVarIO $ queueRec' q) >>= \case
|
||||
Nothing -> logWarn $ logPfx qId op <> "already deleted"
|
||||
Just _ -> void $ ExceptT $ a q
|
||||
qError qId op = \case
|
||||
Left e -> logError $ logPfx qId op <> tshow e
|
||||
Right _ -> pure ()
|
||||
logPfx qId op = "STORE: " <> op <> ", stored queue " <> decodeLatin1 (strEncode qId) <> ", "
|
||||
withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM (Maybe a)) -> STM (Either ErrorType a)
|
||||
withQueue rId queues f = toResult <$> TM.lookup rId queues $>>= f
|
||||
|
||||
@@ -4,81 +4,65 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Messaging.Server.Stats where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Hashable (hash)
|
||||
import Data.IORef
|
||||
import Data.IntSet (IntSet)
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Time.Calendar.Month (pattern MonthDay)
|
||||
import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
|
||||
import Data.Time.Clock (UTCTime (..))
|
||||
import GHC.IORef (atomicSwapIORef)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (EntityId (..))
|
||||
import Simplex.Messaging.Util (atomicModifyIORef'_, unlessM)
|
||||
import Simplex.Messaging.Protocol (RecipientId)
|
||||
import UnliftIO.STM
|
||||
|
||||
data ServerStats = ServerStats
|
||||
{ fromTime :: IORef UTCTime,
|
||||
qCreated :: IORef Int,
|
||||
qSecured :: IORef Int,
|
||||
qDeletedAll :: IORef Int,
|
||||
qDeletedAllB :: IORef Int,
|
||||
qDeletedNew :: IORef Int,
|
||||
qDeletedSecured :: IORef Int,
|
||||
qSub :: IORef Int, -- only includes subscriptions when there were pending messages
|
||||
-- qSubNoMsg :: IORef Int, -- this stat creates too many STM transactions
|
||||
qSubAllB :: IORef Int, -- count of all subscription batches (with and without pending messages)
|
||||
qSubAuth :: IORef Int,
|
||||
qSubDuplicate :: IORef Int,
|
||||
qSubProhibited :: IORef Int,
|
||||
qSubEnd :: IORef Int,
|
||||
qSubEndB :: IORef Int,
|
||||
ntfCreated :: IORef Int,
|
||||
ntfDeleted :: IORef Int,
|
||||
ntfDeletedB :: IORef Int,
|
||||
ntfSub :: IORef Int,
|
||||
ntfSubB :: IORef Int,
|
||||
ntfSubAuth :: IORef Int,
|
||||
ntfSubDuplicate :: IORef Int,
|
||||
msgSent :: IORef Int,
|
||||
msgSentAuth :: IORef Int,
|
||||
msgSentQuota :: IORef Int,
|
||||
msgSentLarge :: IORef Int,
|
||||
msgRecv :: IORef Int,
|
||||
msgRecvGet :: IORef Int,
|
||||
msgGet :: IORef Int,
|
||||
msgGetNoMsg :: IORef Int,
|
||||
msgGetAuth :: IORef Int,
|
||||
msgGetDuplicate :: IORef Int,
|
||||
msgGetProhibited :: IORef Int,
|
||||
msgExpired :: IORef Int,
|
||||
activeQueues :: PeriodStats,
|
||||
-- subscribedQueues :: PeriodStats, -- this stat uses too much memory
|
||||
msgSentNtf :: IORef Int, -- sent messages with NTF flag
|
||||
msgRecvNtf :: IORef Int, -- received messages with NTF flag
|
||||
activeQueuesNtf :: PeriodStats,
|
||||
msgNtfs :: IORef Int, -- messages notications delivered to NTF server (<= msgSentNtf)
|
||||
msgNtfsB :: IORef Int, -- messages notication batches delivered to NTF server
|
||||
msgNtfNoSub :: IORef Int, -- no subscriber to notifications (e.g., NTF server not connected)
|
||||
msgNtfLost :: IORef Int, -- notification is lost because NTF delivery queue is full
|
||||
msgNtfExpired :: IORef Int, -- expired
|
||||
{ fromTime :: TVar UTCTime,
|
||||
qCreated :: TVar Int,
|
||||
qSecured :: TVar Int,
|
||||
qDeletedAll :: TVar Int,
|
||||
qDeletedNew :: TVar Int,
|
||||
qDeletedSecured :: TVar Int,
|
||||
qSub :: TVar Int,
|
||||
qSubNoMsg :: TVar Int,
|
||||
qSubAuth :: TVar Int,
|
||||
qSubDuplicate :: TVar Int,
|
||||
qSubProhibited :: TVar Int,
|
||||
ntfCreated :: TVar Int,
|
||||
ntfDeleted :: TVar Int,
|
||||
ntfSub :: TVar Int,
|
||||
ntfSubAuth :: TVar Int,
|
||||
ntfSubDuplicate :: TVar Int,
|
||||
msgSent :: TVar Int,
|
||||
msgSentAuth :: TVar Int,
|
||||
msgSentQuota :: TVar Int,
|
||||
msgSentLarge :: TVar Int,
|
||||
msgRecv :: TVar Int,
|
||||
msgRecvGet :: TVar Int,
|
||||
msgGet :: TVar Int,
|
||||
msgGetNoMsg :: TVar Int,
|
||||
msgGetAuth :: TVar Int,
|
||||
msgGetDuplicate :: TVar Int,
|
||||
msgGetProhibited :: TVar Int,
|
||||
msgExpired :: TVar Int,
|
||||
activeQueues :: PeriodStats RecipientId,
|
||||
subscribedQueues :: PeriodStats RecipientId,
|
||||
msgSentNtf :: TVar Int, -- sent messages with NTF flag
|
||||
msgRecvNtf :: TVar Int, -- received messages with NTF flag
|
||||
activeQueuesNtf :: PeriodStats RecipientId,
|
||||
msgNtfs :: TVar Int, -- messages notications delivered to NTF server (<= msgSentNtf)
|
||||
msgNtfNoSub :: TVar Int, -- no subscriber to notifications (e.g., NTF server not connected)
|
||||
msgNtfLost :: TVar Int, -- notification is lost because NTF delivery queue is full
|
||||
pRelays :: ProxyStats,
|
||||
pRelaysOwn :: ProxyStats,
|
||||
pMsgFwds :: ProxyStats,
|
||||
pMsgFwdsOwn :: ProxyStats,
|
||||
pMsgFwdsRecv :: IORef Int,
|
||||
qCount :: IORef Int,
|
||||
msgCount :: IORef Int,
|
||||
ntfCount :: IORef Int
|
||||
pMsgFwdsRecv :: TVar Int,
|
||||
qCount :: TVar Int,
|
||||
msgCount :: TVar Int
|
||||
}
|
||||
|
||||
data ServerStatsData = ServerStatsData
|
||||
@@ -86,21 +70,16 @@ data ServerStatsData = ServerStatsData
|
||||
_qCreated :: Int,
|
||||
_qSecured :: Int,
|
||||
_qDeletedAll :: Int,
|
||||
_qDeletedAllB :: Int,
|
||||
_qDeletedNew :: Int,
|
||||
_qDeletedSecured :: Int,
|
||||
_qSub :: Int,
|
||||
_qSubAllB :: Int,
|
||||
_qSubNoMsg :: Int,
|
||||
_qSubAuth :: Int,
|
||||
_qSubDuplicate :: Int,
|
||||
_qSubProhibited :: Int,
|
||||
_qSubEnd :: Int,
|
||||
_qSubEndB :: Int,
|
||||
_ntfCreated :: Int,
|
||||
_ntfDeleted :: Int,
|
||||
_ntfDeletedB :: Int,
|
||||
_ntfSub :: Int,
|
||||
_ntfSubB :: Int,
|
||||
_ntfSubAuth :: Int,
|
||||
_ntfSubDuplicate :: Int,
|
||||
_msgSent :: Int,
|
||||
@@ -115,99 +94,85 @@ data ServerStatsData = ServerStatsData
|
||||
_msgGetDuplicate :: Int,
|
||||
_msgGetProhibited :: Int,
|
||||
_msgExpired :: Int,
|
||||
_activeQueues :: PeriodStatsData,
|
||||
_activeQueues :: PeriodStatsData RecipientId,
|
||||
_subscribedQueues :: PeriodStatsData RecipientId,
|
||||
_msgSentNtf :: Int,
|
||||
_msgRecvNtf :: Int,
|
||||
_activeQueuesNtf :: PeriodStatsData,
|
||||
_activeQueuesNtf :: PeriodStatsData RecipientId,
|
||||
_msgNtfs :: Int,
|
||||
_msgNtfsB :: Int,
|
||||
_msgNtfNoSub :: Int,
|
||||
_msgNtfLost :: Int,
|
||||
_msgNtfExpired :: Int,
|
||||
_pRelays :: ProxyStatsData,
|
||||
_pRelaysOwn :: ProxyStatsData,
|
||||
_pMsgFwds :: ProxyStatsData,
|
||||
_pMsgFwdsOwn :: ProxyStatsData,
|
||||
_pMsgFwdsRecv :: Int,
|
||||
_qCount :: Int,
|
||||
_msgCount :: Int,
|
||||
_ntfCount :: Int
|
||||
_msgCount :: Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
newServerStats :: UTCTime -> IO ServerStats
|
||||
newServerStats ts = do
|
||||
fromTime <- newIORef ts
|
||||
qCreated <- newIORef 0
|
||||
qSecured <- newIORef 0
|
||||
qDeletedAll <- newIORef 0
|
||||
qDeletedAllB <- newIORef 0
|
||||
qDeletedNew <- newIORef 0
|
||||
qDeletedSecured <- newIORef 0
|
||||
qSub <- newIORef 0
|
||||
qSubAllB <- newIORef 0
|
||||
qSubAuth <- newIORef 0
|
||||
qSubDuplicate <- newIORef 0
|
||||
qSubProhibited <- newIORef 0
|
||||
qSubEnd <- newIORef 0
|
||||
qSubEndB <- newIORef 0
|
||||
ntfCreated <- newIORef 0
|
||||
ntfDeleted <- newIORef 0
|
||||
ntfDeletedB <- newIORef 0
|
||||
ntfSub <- newIORef 0
|
||||
ntfSubB <- newIORef 0
|
||||
ntfSubAuth <- newIORef 0
|
||||
ntfSubDuplicate <- newIORef 0
|
||||
msgSent <- newIORef 0
|
||||
msgSentAuth <- newIORef 0
|
||||
msgSentQuota <- newIORef 0
|
||||
msgSentLarge <- newIORef 0
|
||||
msgRecv <- newIORef 0
|
||||
msgRecvGet <- newIORef 0
|
||||
msgGet <- newIORef 0
|
||||
msgGetNoMsg <- newIORef 0
|
||||
msgGetAuth <- newIORef 0
|
||||
msgGetDuplicate <- newIORef 0
|
||||
msgGetProhibited <- newIORef 0
|
||||
msgExpired <- newIORef 0
|
||||
fromTime <- newTVarIO ts
|
||||
qCreated <- newTVarIO 0
|
||||
qSecured <- newTVarIO 0
|
||||
qDeletedAll <- newTVarIO 0
|
||||
qDeletedNew <- newTVarIO 0
|
||||
qDeletedSecured <- newTVarIO 0
|
||||
qSub <- newTVarIO 0
|
||||
qSubNoMsg <- newTVarIO 0
|
||||
qSubAuth <- newTVarIO 0
|
||||
qSubDuplicate <- newTVarIO 0
|
||||
qSubProhibited <- newTVarIO 0
|
||||
ntfCreated <- newTVarIO 0
|
||||
ntfDeleted <- newTVarIO 0
|
||||
ntfSub <- newTVarIO 0
|
||||
ntfSubAuth <- newTVarIO 0
|
||||
ntfSubDuplicate <- newTVarIO 0
|
||||
msgSent <- newTVarIO 0
|
||||
msgSentAuth <- newTVarIO 0
|
||||
msgSentQuota <- newTVarIO 0
|
||||
msgSentLarge <- newTVarIO 0
|
||||
msgRecv <- newTVarIO 0
|
||||
msgRecvGet <- newTVarIO 0
|
||||
msgGet <- newTVarIO 0
|
||||
msgGetNoMsg <- newTVarIO 0
|
||||
msgGetAuth <- newTVarIO 0
|
||||
msgGetDuplicate <- newTVarIO 0
|
||||
msgGetProhibited <- newTVarIO 0
|
||||
msgExpired <- newTVarIO 0
|
||||
activeQueues <- newPeriodStats
|
||||
msgSentNtf <- newIORef 0
|
||||
msgRecvNtf <- newIORef 0
|
||||
subscribedQueues <- newPeriodStats
|
||||
msgSentNtf <- newTVarIO 0
|
||||
msgRecvNtf <- newTVarIO 0
|
||||
activeQueuesNtf <- newPeriodStats
|
||||
msgNtfs <- newIORef 0
|
||||
msgNtfsB <- newIORef 0
|
||||
msgNtfNoSub <- newIORef 0
|
||||
msgNtfLost <- newIORef 0
|
||||
msgNtfExpired <- newIORef 0
|
||||
msgNtfs <- newTVarIO 0
|
||||
msgNtfNoSub <- newTVarIO 0
|
||||
msgNtfLost <- newTVarIO 0
|
||||
pRelays <- newProxyStats
|
||||
pRelaysOwn <- newProxyStats
|
||||
pMsgFwds <- newProxyStats
|
||||
pMsgFwdsOwn <- newProxyStats
|
||||
pMsgFwdsRecv <- newIORef 0
|
||||
qCount <- newIORef 0
|
||||
msgCount <- newIORef 0
|
||||
ntfCount <- newIORef 0
|
||||
pMsgFwdsRecv <- newTVarIO 0
|
||||
qCount <- newTVarIO 0
|
||||
msgCount <- newTVarIO 0
|
||||
pure
|
||||
ServerStats
|
||||
{ fromTime,
|
||||
qCreated,
|
||||
qSecured,
|
||||
qDeletedAll,
|
||||
qDeletedAllB,
|
||||
qDeletedNew,
|
||||
qDeletedSecured,
|
||||
qSub,
|
||||
qSubAllB,
|
||||
qSubNoMsg,
|
||||
qSubAuth,
|
||||
qSubDuplicate,
|
||||
qSubProhibited,
|
||||
qSubEnd,
|
||||
qSubEndB,
|
||||
ntfCreated,
|
||||
ntfDeleted,
|
||||
ntfDeletedB,
|
||||
ntfSub,
|
||||
ntfSubB,
|
||||
ntfSubAuth,
|
||||
ntfSubDuplicate,
|
||||
msgSent,
|
||||
@@ -223,97 +188,83 @@ newServerStats ts = do
|
||||
msgGetProhibited,
|
||||
msgExpired,
|
||||
activeQueues,
|
||||
subscribedQueues,
|
||||
msgSentNtf,
|
||||
msgRecvNtf,
|
||||
activeQueuesNtf,
|
||||
msgNtfs,
|
||||
msgNtfsB,
|
||||
msgNtfNoSub,
|
||||
msgNtfLost,
|
||||
msgNtfExpired,
|
||||
pRelays,
|
||||
pRelaysOwn,
|
||||
pMsgFwds,
|
||||
pMsgFwdsOwn,
|
||||
pMsgFwdsRecv,
|
||||
qCount,
|
||||
msgCount,
|
||||
ntfCount
|
||||
msgCount
|
||||
}
|
||||
|
||||
getServerStatsData :: ServerStats -> IO ServerStatsData
|
||||
getServerStatsData s = do
|
||||
_fromTime <- readIORef $ fromTime s
|
||||
_qCreated <- readIORef $ qCreated s
|
||||
_qSecured <- readIORef $ qSecured s
|
||||
_qDeletedAll <- readIORef $ qDeletedAll s
|
||||
_qDeletedAllB <- readIORef $ qDeletedAllB s
|
||||
_qDeletedNew <- readIORef $ qDeletedNew s
|
||||
_qDeletedSecured <- readIORef $ qDeletedSecured s
|
||||
_qSub <- readIORef $ qSub s
|
||||
_qSubAllB <- readIORef $ qSubAllB s
|
||||
_qSubAuth <- readIORef $ qSubAuth s
|
||||
_qSubDuplicate <- readIORef $ qSubDuplicate s
|
||||
_qSubProhibited <- readIORef $ qSubProhibited s
|
||||
_qSubEnd <- readIORef $ qSubEnd s
|
||||
_qSubEndB <- readIORef $ qSubEndB s
|
||||
_ntfCreated <- readIORef $ ntfCreated s
|
||||
_ntfDeleted <- readIORef $ ntfDeleted s
|
||||
_ntfDeletedB <- readIORef $ ntfDeletedB s
|
||||
_ntfSub <- readIORef $ ntfSub s
|
||||
_ntfSubB <- readIORef $ ntfSubB s
|
||||
_ntfSubAuth <- readIORef $ ntfSubAuth s
|
||||
_ntfSubDuplicate <- readIORef $ ntfSubDuplicate s
|
||||
_msgSent <- readIORef $ msgSent s
|
||||
_msgSentAuth <- readIORef $ msgSentAuth s
|
||||
_msgSentQuota <- readIORef $ msgSentQuota s
|
||||
_msgSentLarge <- readIORef $ msgSentLarge s
|
||||
_msgRecv <- readIORef $ msgRecv s
|
||||
_msgRecvGet <- readIORef $ msgRecvGet s
|
||||
_msgGet <- readIORef $ msgGet s
|
||||
_msgGetNoMsg <- readIORef $ msgGetNoMsg s
|
||||
_msgGetAuth <- readIORef $ msgGetAuth s
|
||||
_msgGetDuplicate <- readIORef $ msgGetDuplicate s
|
||||
_msgGetProhibited <- readIORef $ msgGetProhibited s
|
||||
_msgExpired <- readIORef $ msgExpired s
|
||||
_fromTime <- readTVarIO $ fromTime s
|
||||
_qCreated <- readTVarIO $ qCreated s
|
||||
_qSecured <- readTVarIO $ qSecured s
|
||||
_qDeletedAll <- readTVarIO $ qDeletedAll s
|
||||
_qDeletedNew <- readTVarIO $ qDeletedNew s
|
||||
_qDeletedSecured <- readTVarIO $ qDeletedSecured s
|
||||
_qSub <- readTVarIO $ qSub s
|
||||
_qSubNoMsg <- readTVarIO $ qSubNoMsg s
|
||||
_qSubAuth <- readTVarIO $ qSubAuth s
|
||||
_qSubDuplicate <- readTVarIO $ qSubDuplicate s
|
||||
_qSubProhibited <- readTVarIO $ qSubProhibited s
|
||||
_ntfCreated <- readTVarIO $ ntfCreated s
|
||||
_ntfDeleted <- readTVarIO $ ntfDeleted s
|
||||
_ntfSub <- readTVarIO $ ntfSub s
|
||||
_ntfSubAuth <- readTVarIO $ ntfSubAuth s
|
||||
_ntfSubDuplicate <- readTVarIO $ ntfSubDuplicate s
|
||||
_msgSent <- readTVarIO $ msgSent s
|
||||
_msgSentAuth <- readTVarIO $ msgSentAuth s
|
||||
_msgSentQuota <- readTVarIO $ msgSentQuota s
|
||||
_msgSentLarge <- readTVarIO $ msgSentLarge s
|
||||
_msgRecv <- readTVarIO $ msgRecv s
|
||||
_msgRecvGet <- readTVarIO $ msgRecvGet s
|
||||
_msgGet <- readTVarIO $ msgGet s
|
||||
_msgGetNoMsg <- readTVarIO $ msgGetNoMsg s
|
||||
_msgGetAuth <- readTVarIO $ msgGetAuth s
|
||||
_msgGetDuplicate <- readTVarIO $ msgGetDuplicate s
|
||||
_msgGetProhibited <- readTVarIO $ msgGetProhibited s
|
||||
_msgExpired <- readTVarIO $ msgExpired s
|
||||
_activeQueues <- getPeriodStatsData $ activeQueues s
|
||||
_msgSentNtf <- readIORef $ msgSentNtf s
|
||||
_msgRecvNtf <- readIORef $ msgRecvNtf s
|
||||
_subscribedQueues <- getPeriodStatsData $ subscribedQueues s
|
||||
_msgSentNtf <- readTVarIO $ msgSentNtf s
|
||||
_msgRecvNtf <- readTVarIO $ msgRecvNtf s
|
||||
_activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
|
||||
_msgNtfs <- readIORef $ msgNtfs s
|
||||
_msgNtfsB <- readIORef $ msgNtfsB s
|
||||
_msgNtfNoSub <- readIORef $ msgNtfNoSub s
|
||||
_msgNtfLost <- readIORef $ msgNtfLost s
|
||||
_msgNtfExpired <- readIORef $ msgNtfExpired s
|
||||
_msgNtfs <- readTVarIO $ msgNtfs s
|
||||
_msgNtfNoSub <- readTVarIO $ msgNtfNoSub s
|
||||
_msgNtfLost <- readTVarIO $ msgNtfLost s
|
||||
_pRelays <- getProxyStatsData $ pRelays s
|
||||
_pRelaysOwn <- getProxyStatsData $ pRelaysOwn s
|
||||
_pMsgFwds <- getProxyStatsData $ pMsgFwds s
|
||||
_pMsgFwdsOwn <- getProxyStatsData $ pMsgFwdsOwn s
|
||||
_pMsgFwdsRecv <- readIORef $ pMsgFwdsRecv s
|
||||
_qCount <- readIORef $ qCount s
|
||||
_msgCount <- readIORef $ msgCount s
|
||||
_ntfCount <- readIORef $ ntfCount s
|
||||
_pMsgFwdsRecv <- readTVarIO $ pMsgFwdsRecv s
|
||||
_qCount <- readTVarIO $ qCount s
|
||||
_msgCount <- readTVarIO $ msgCount s
|
||||
pure
|
||||
ServerStatsData
|
||||
{ _fromTime,
|
||||
_qCreated,
|
||||
_qSecured,
|
||||
_qDeletedAll,
|
||||
_qDeletedAllB,
|
||||
_qDeletedNew,
|
||||
_qDeletedSecured,
|
||||
_qSub,
|
||||
_qSubAllB,
|
||||
_qSubNoMsg,
|
||||
_qSubAuth,
|
||||
_qSubDuplicate,
|
||||
_qSubProhibited,
|
||||
_qSubEnd,
|
||||
_qSubEndB,
|
||||
_ntfCreated,
|
||||
_ntfDeleted,
|
||||
_ntfDeletedB,
|
||||
_ntfSub,
|
||||
_ntfSubB,
|
||||
_ntfSubAuth,
|
||||
_ntfSubDuplicate,
|
||||
_msgSent,
|
||||
@@ -329,77 +280,67 @@ getServerStatsData s = do
|
||||
_msgGetProhibited,
|
||||
_msgExpired,
|
||||
_activeQueues,
|
||||
_subscribedQueues,
|
||||
_msgSentNtf,
|
||||
_msgRecvNtf,
|
||||
_activeQueuesNtf,
|
||||
_msgNtfs,
|
||||
_msgNtfsB,
|
||||
_msgNtfNoSub,
|
||||
_msgNtfLost,
|
||||
_msgNtfExpired,
|
||||
_pRelays,
|
||||
_pRelaysOwn,
|
||||
_pMsgFwds,
|
||||
_pMsgFwdsOwn,
|
||||
_pMsgFwdsRecv,
|
||||
_qCount,
|
||||
_msgCount,
|
||||
_ntfCount
|
||||
_msgCount
|
||||
}
|
||||
|
||||
-- this function is not thread safe, it is used on server start only
|
||||
setServerStats :: ServerStats -> ServerStatsData -> IO ()
|
||||
setServerStats :: ServerStats -> ServerStatsData -> STM ()
|
||||
setServerStats s d = do
|
||||
writeIORef (fromTime s) $! _fromTime d
|
||||
writeIORef (qCreated s) $! _qCreated d
|
||||
writeIORef (qSecured s) $! _qSecured d
|
||||
writeIORef (qDeletedAll s) $! _qDeletedAll d
|
||||
writeIORef (qDeletedAllB s) $! _qDeletedAllB d
|
||||
writeIORef (qDeletedNew s) $! _qDeletedNew d
|
||||
writeIORef (qDeletedSecured s) $! _qDeletedSecured d
|
||||
writeIORef (qSub s) $! _qSub d
|
||||
writeIORef (qSubAllB s) $! _qSubAllB d
|
||||
writeIORef (qSubAuth s) $! _qSubAuth d
|
||||
writeIORef (qSubDuplicate s) $! _qSubDuplicate d
|
||||
writeIORef (qSubProhibited s) $! _qSubProhibited d
|
||||
writeIORef (qSubEnd s) $! _qSubEnd d
|
||||
writeIORef (qSubEndB s) $! _qSubEndB d
|
||||
writeIORef (ntfCreated s) $! _ntfCreated d
|
||||
writeIORef (ntfDeleted s) $! _ntfDeleted d
|
||||
writeIORef (ntfDeletedB s) $! _ntfDeletedB d
|
||||
writeIORef (ntfSub s) $! _ntfSub d
|
||||
writeIORef (ntfSubB s) $! _ntfSubB d
|
||||
writeIORef (ntfSubAuth s) $! _ntfSubAuth d
|
||||
writeIORef (ntfSubDuplicate s) $! _ntfSubDuplicate d
|
||||
writeIORef (msgSent s) $! _msgSent d
|
||||
writeIORef (msgSentAuth s) $! _msgSentAuth d
|
||||
writeIORef (msgSentQuota s) $! _msgSentQuota d
|
||||
writeIORef (msgSentLarge s) $! _msgSentLarge d
|
||||
writeIORef (msgRecv s) $! _msgRecv d
|
||||
writeIORef (msgRecvGet s) $! _msgRecvGet d
|
||||
writeIORef (msgGet s) $! _msgGet d
|
||||
writeIORef (msgGetNoMsg s) $! _msgGetNoMsg d
|
||||
writeIORef (msgGetAuth s) $! _msgGetAuth d
|
||||
writeIORef (msgGetDuplicate s) $! _msgGetDuplicate d
|
||||
writeIORef (msgGetProhibited s) $! _msgGetProhibited d
|
||||
writeIORef (msgExpired s) $! _msgExpired d
|
||||
writeTVar (fromTime s) $! _fromTime d
|
||||
writeTVar (qCreated s) $! _qCreated d
|
||||
writeTVar (qSecured s) $! _qSecured d
|
||||
writeTVar (qDeletedAll s) $! _qDeletedAll d
|
||||
writeTVar (qDeletedNew s) $! _qDeletedNew d
|
||||
writeTVar (qDeletedSecured s) $! _qDeletedSecured d
|
||||
writeTVar (qSub s) $! _qSub d
|
||||
writeTVar (qSubNoMsg s) $! _qSubNoMsg d
|
||||
writeTVar (qSubAuth s) $! _qSubAuth d
|
||||
writeTVar (qSubDuplicate s) $! _qSubDuplicate d
|
||||
writeTVar (qSubProhibited s) $! _qSubProhibited d
|
||||
writeTVar (ntfCreated s) $! _ntfCreated d
|
||||
writeTVar (ntfDeleted s) $! _ntfDeleted d
|
||||
writeTVar (ntfSub s) $! _ntfSub d
|
||||
writeTVar (ntfSubAuth s) $! _ntfSubAuth d
|
||||
writeTVar (ntfSubDuplicate s) $! _ntfSubDuplicate d
|
||||
writeTVar (msgSent s) $! _msgSent d
|
||||
writeTVar (msgSentAuth s) $! _msgSentAuth d
|
||||
writeTVar (msgSentQuota s) $! _msgSentQuota d
|
||||
writeTVar (msgSentLarge s) $! _msgSentLarge d
|
||||
writeTVar (msgRecv s) $! _msgRecv d
|
||||
writeTVar (msgRecvGet s) $! _msgRecvGet d
|
||||
writeTVar (msgGet s) $! _msgGet d
|
||||
writeTVar (msgGetNoMsg s) $! _msgGetNoMsg d
|
||||
writeTVar (msgGetAuth s) $! _msgGetAuth d
|
||||
writeTVar (msgGetDuplicate s) $! _msgGetDuplicate d
|
||||
writeTVar (msgGetProhibited s) $! _msgGetProhibited d
|
||||
writeTVar (msgExpired s) $! _msgExpired d
|
||||
setPeriodStats (activeQueues s) (_activeQueues d)
|
||||
writeIORef (msgSentNtf s) $! _msgSentNtf d
|
||||
writeIORef (msgRecvNtf s) $! _msgRecvNtf d
|
||||
setPeriodStats (subscribedQueues s) (_subscribedQueues d)
|
||||
writeTVar (msgSentNtf s) $! _msgSentNtf d
|
||||
writeTVar (msgRecvNtf s) $! _msgRecvNtf d
|
||||
setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
|
||||
writeIORef (msgNtfs s) $! _msgNtfs d
|
||||
writeIORef (msgNtfsB s) $! _msgNtfsB d
|
||||
writeIORef (msgNtfNoSub s) $! _msgNtfNoSub d
|
||||
writeIORef (msgNtfLost s) $! _msgNtfLost d
|
||||
writeIORef (msgNtfExpired s) $! _msgNtfExpired d
|
||||
writeTVar (msgNtfs s) $! _msgNtfs d
|
||||
writeTVar (msgNtfNoSub s) $! _msgNtfNoSub d
|
||||
writeTVar (msgNtfLost s) $! _msgNtfLost d
|
||||
setProxyStats (pRelays s) $! _pRelays d
|
||||
setProxyStats (pRelaysOwn s) $! _pRelaysOwn d
|
||||
setProxyStats (pMsgFwds s) $! _pMsgFwds d
|
||||
setProxyStats (pMsgFwdsOwn s) $! _pMsgFwdsOwn d
|
||||
writeIORef (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
|
||||
writeIORef (qCount s) $! _qCount d
|
||||
writeIORef (msgCount s) $! _msgCount d
|
||||
writeIORef (ntfCount s) $! _ntfCount d
|
||||
writeTVar (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
|
||||
writeTVar (qCount s) $! _qCount d
|
||||
writeTVar (msgCount s) $! _msgCount d
|
||||
|
||||
instance StrEncoding ServerStatsData where
|
||||
strEncode d =
|
||||
@@ -410,20 +351,15 @@ instance StrEncoding ServerStatsData where
|
||||
"qDeletedAll=" <> strEncode (_qDeletedAll d),
|
||||
"qDeletedNew=" <> strEncode (_qDeletedNew d),
|
||||
"qDeletedSecured=" <> strEncode (_qDeletedSecured d),
|
||||
"qDeletedAllB=" <> strEncode (_qDeletedAllB d),
|
||||
"qCount=" <> strEncode (_qCount d),
|
||||
"qSub=" <> strEncode (_qSub d),
|
||||
"qSubAllB=" <> strEncode (_qSubAllB d),
|
||||
"qSubNoMsg=" <> strEncode (_qSubNoMsg d),
|
||||
"qSubAuth=" <> strEncode (_qSubAuth d),
|
||||
"qSubDuplicate=" <> strEncode (_qSubDuplicate d),
|
||||
"qSubProhibited=" <> strEncode (_qSubProhibited d),
|
||||
"qSubEnd=" <> strEncode (_qSubEnd d),
|
||||
"qSubEndB=" <> strEncode (_qSubEndB d),
|
||||
"ntfCreated=" <> strEncode (_ntfCreated d),
|
||||
"ntfDeleted=" <> strEncode (_ntfDeleted d),
|
||||
"ntfDeletedB=" <> strEncode (_ntfDeletedB d),
|
||||
"ntfSub=" <> strEncode (_ntfSub d),
|
||||
"ntfSubB=" <> strEncode (_ntfSubB d),
|
||||
"ntfSubAuth=" <> strEncode (_ntfSubAuth d),
|
||||
"ntfSubDuplicate=" <> strEncode (_ntfSubDuplicate d),
|
||||
"msgSent=" <> strEncode (_msgSent d),
|
||||
@@ -441,12 +377,12 @@ instance StrEncoding ServerStatsData where
|
||||
"msgSentNtf=" <> strEncode (_msgSentNtf d),
|
||||
"msgRecvNtf=" <> strEncode (_msgRecvNtf d),
|
||||
"msgNtfs=" <> strEncode (_msgNtfs d),
|
||||
"msgNtfsB=" <> strEncode (_msgNtfsB d),
|
||||
"msgNtfNoSub=" <> strEncode (_msgNtfNoSub d),
|
||||
"msgNtfLost=" <> strEncode (_msgNtfLost d),
|
||||
"msgNtfExpired=" <> strEncode (_msgNtfExpired d),
|
||||
"activeQueues:",
|
||||
strEncode (_activeQueues d),
|
||||
"subscribedQueues:",
|
||||
strEncode (_subscribedQueues d),
|
||||
"activeQueuesNtf:",
|
||||
strEncode (_activeQueuesNtf d),
|
||||
"pRelays:",
|
||||
@@ -466,21 +402,15 @@ instance StrEncoding ServerStatsData where
|
||||
(_qDeletedAll, _qDeletedNew, _qDeletedSecured) <-
|
||||
(,0,0) <$> ("qDeleted=" *> strP <* A.endOfLine)
|
||||
<|> ((,,) <$> ("qDeletedAll=" *> strP <* A.endOfLine) <*> ("qDeletedNew=" *> strP <* A.endOfLine) <*> ("qDeletedSecured=" *> strP <* A.endOfLine))
|
||||
_qDeletedAllB <- opt "qDeletedAllB="
|
||||
_qCount <- opt "qCount="
|
||||
_qSub <- opt "qSub="
|
||||
_qSubNoMsg <- skipInt "qSubNoMsg=" -- skipping it for backward compatibility
|
||||
_qSubAllB <- opt "qSubAllB="
|
||||
_qSubNoMsg <- opt "qSubNoMsg="
|
||||
_qSubAuth <- opt "qSubAuth="
|
||||
_qSubDuplicate <- opt "qSubDuplicate="
|
||||
_qSubProhibited <- opt "qSubProhibited="
|
||||
_qSubEnd <- opt "qSubEnd="
|
||||
_qSubEndB <- opt "qSubEndB="
|
||||
_ntfCreated <- opt "ntfCreated="
|
||||
_ntfDeleted <- opt "ntfDeleted="
|
||||
_ntfDeletedB <- opt "ntfDeletedB="
|
||||
_ntfSub <- opt "ntfSub="
|
||||
_ntfSubB <- opt "ntfSubB="
|
||||
_ntfSubAuth <- opt "ntfSubAuth="
|
||||
_ntfSubDuplicate <- opt "ntfSubDuplicate="
|
||||
_msgSent <- "msgSent=" *> strP <* A.endOfLine
|
||||
@@ -498,10 +428,8 @@ instance StrEncoding ServerStatsData where
|
||||
_msgSentNtf <- opt "msgSentNtf="
|
||||
_msgRecvNtf <- opt "msgRecvNtf="
|
||||
_msgNtfs <- opt "msgNtfs="
|
||||
_msgNtfsB <- opt "msgNtfsB="
|
||||
_msgNtfNoSub <- opt "msgNtfNoSub="
|
||||
_msgNtfLost <- opt "msgNtfLost="
|
||||
_msgNtfExpired <- opt "msgNtfExpired="
|
||||
_activeQueues <-
|
||||
optional ("activeQueues:" <* A.endOfLine) >>= \case
|
||||
Just _ -> strP <* optional A.endOfLine
|
||||
@@ -512,7 +440,7 @@ instance StrEncoding ServerStatsData where
|
||||
pure PeriodStatsData {_day, _week, _month}
|
||||
_subscribedQueues <-
|
||||
optional ("subscribedQueues:" <* A.endOfLine) >>= \case
|
||||
Just _ -> newPeriodStatsData <$ (strP @PeriodStatsData <* optional A.endOfLine)
|
||||
Just _ -> strP <* optional A.endOfLine
|
||||
_ -> pure newPeriodStatsData
|
||||
_activeQueuesNtf <-
|
||||
optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
|
||||
@@ -529,21 +457,16 @@ instance StrEncoding ServerStatsData where
|
||||
_qCreated,
|
||||
_qSecured,
|
||||
_qDeletedAll,
|
||||
_qDeletedAllB,
|
||||
_qDeletedNew,
|
||||
_qDeletedSecured,
|
||||
_qSub,
|
||||
_qSubAllB,
|
||||
_qSubNoMsg,
|
||||
_qSubAuth,
|
||||
_qSubDuplicate,
|
||||
_qSubProhibited,
|
||||
_qSubEnd,
|
||||
_qSubEndB,
|
||||
_ntfCreated,
|
||||
_ntfDeleted,
|
||||
_ntfDeletedB,
|
||||
_ntfSub,
|
||||
_ntfSubB,
|
||||
_ntfSubAuth,
|
||||
_ntfSubDuplicate,
|
||||
_msgSent,
|
||||
@@ -561,11 +484,10 @@ instance StrEncoding ServerStatsData where
|
||||
_msgSentNtf,
|
||||
_msgRecvNtf,
|
||||
_msgNtfs,
|
||||
_msgNtfsB,
|
||||
_msgNtfNoSub,
|
||||
_msgNtfLost,
|
||||
_msgNtfExpired,
|
||||
_activeQueues,
|
||||
_subscribedQueues,
|
||||
_activeQueuesNtf,
|
||||
_pRelays,
|
||||
_pRelaysOwn,
|
||||
@@ -573,64 +495,59 @@ instance StrEncoding ServerStatsData where
|
||||
_pMsgFwdsOwn,
|
||||
_pMsgFwdsRecv,
|
||||
_qCount,
|
||||
_msgCount = 0,
|
||||
_ntfCount = 0
|
||||
_msgCount = 0
|
||||
}
|
||||
where
|
||||
opt s = A.string s *> strP <* A.endOfLine <|> pure 0
|
||||
skipInt s = (0 :: Int) <$ optional (A.string s *> strP @Int *> A.endOfLine)
|
||||
proxyStatsP key =
|
||||
optional (A.string key >> A.endOfLine) >>= \case
|
||||
Just _ -> strP <* optional A.endOfLine
|
||||
_ -> pure newProxyStatsData
|
||||
|
||||
data PeriodStats = PeriodStats
|
||||
{ day :: IORef IntSet,
|
||||
week :: IORef IntSet,
|
||||
month :: IORef IntSet
|
||||
data PeriodStats a = PeriodStats
|
||||
{ day :: TVar (Set a),
|
||||
week :: TVar (Set a),
|
||||
month :: TVar (Set a)
|
||||
}
|
||||
|
||||
newPeriodStats :: IO PeriodStats
|
||||
newPeriodStats :: IO (PeriodStats a)
|
||||
newPeriodStats = do
|
||||
day <- newIORef IS.empty
|
||||
week <- newIORef IS.empty
|
||||
month <- newIORef IS.empty
|
||||
day <- newTVarIO S.empty
|
||||
week <- newTVarIO S.empty
|
||||
month <- newTVarIO S.empty
|
||||
pure PeriodStats {day, week, month}
|
||||
|
||||
data PeriodStatsData = PeriodStatsData
|
||||
{ _day :: IntSet,
|
||||
_week :: IntSet,
|
||||
_month :: IntSet
|
||||
data PeriodStatsData a = PeriodStatsData
|
||||
{ _day :: Set a,
|
||||
_week :: Set a,
|
||||
_month :: Set a
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
newPeriodStatsData :: PeriodStatsData
|
||||
newPeriodStatsData = PeriodStatsData {_day = IS.empty, _week = IS.empty, _month = IS.empty}
|
||||
newPeriodStatsData :: PeriodStatsData a
|
||||
newPeriodStatsData = PeriodStatsData {_day = S.empty, _week = S.empty, _month = S.empty}
|
||||
|
||||
getPeriodStatsData :: PeriodStats -> IO PeriodStatsData
|
||||
getPeriodStatsData :: PeriodStats a -> IO (PeriodStatsData a)
|
||||
getPeriodStatsData s = do
|
||||
_day <- readIORef $ day s
|
||||
_week <- readIORef $ week s
|
||||
_month <- readIORef $ month s
|
||||
_day <- readTVarIO $ day s
|
||||
_week <- readTVarIO $ week s
|
||||
_month <- readTVarIO $ month s
|
||||
pure PeriodStatsData {_day, _week, _month}
|
||||
|
||||
-- this function is not thread safe, it is used on server start only
|
||||
setPeriodStats :: PeriodStats -> PeriodStatsData -> IO ()
|
||||
setPeriodStats :: PeriodStats a -> PeriodStatsData a -> STM ()
|
||||
setPeriodStats s d = do
|
||||
writeIORef (day s) $! _day d
|
||||
writeIORef (week s) $! _week d
|
||||
writeIORef (month s) $! _month d
|
||||
writeTVar (day s) $! _day d
|
||||
writeTVar (week s) $! _week d
|
||||
writeTVar (month s) $! _month d
|
||||
|
||||
instance StrEncoding PeriodStatsData where
|
||||
instance (Ord a, StrEncoding a) => StrEncoding (PeriodStatsData a) where
|
||||
strEncode PeriodStatsData {_day, _week, _month} =
|
||||
"dayHashes=" <> strEncode _day <> "\nweekHashes=" <> strEncode _week <> "\nmonthHashes=" <> strEncode _month
|
||||
"day=" <> strEncode _day <> "\nweek=" <> strEncode _week <> "\nmonth=" <> strEncode _month
|
||||
strP = do
|
||||
_day <- ("day=" *> bsSetP <|> "dayHashes=" *> strP) <* A.endOfLine
|
||||
_week <- ("week=" *> bsSetP <|> "weekHashes=" *> strP) <* A.endOfLine
|
||||
_month <- "month=" *> bsSetP <|> "monthHashes=" *> strP
|
||||
_day <- "day=" *> strP <* A.endOfLine
|
||||
_week <- "week=" *> strP <* A.endOfLine
|
||||
_month <- "month=" *> strP
|
||||
pure PeriodStatsData {_day, _week, _month}
|
||||
where
|
||||
bsSetP = S.foldl' (\s -> (`IS.insert` s) . hash) IS.empty <$> strP @(Set ByteString)
|
||||
|
||||
data PeriodStatCounts = PeriodStatCounts
|
||||
{ dayCount :: String,
|
||||
@@ -638,7 +555,7 @@ data PeriodStatCounts = PeriodStatCounts
|
||||
monthCount :: String
|
||||
}
|
||||
|
||||
periodStatCounts :: PeriodStats -> UTCTime -> IO PeriodStatCounts
|
||||
periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts
|
||||
periodStatCounts ps ts = do
|
||||
let d = utctDay ts
|
||||
(_, wDay) = mondayStartWeek d
|
||||
@@ -648,34 +565,33 @@ periodStatCounts ps ts = do
|
||||
monthCount <- periodCount mDay $ month ps
|
||||
pure PeriodStatCounts {dayCount, weekCount, monthCount}
|
||||
where
|
||||
periodCount :: Int -> IORef IntSet -> IO String
|
||||
periodCount 1 ref = show . IS.size <$> atomicSwapIORef ref IS.empty
|
||||
periodCount :: Int -> TVar (Set a) -> STM String
|
||||
periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty
|
||||
periodCount _ _ = pure ""
|
||||
|
||||
updatePeriodStats :: PeriodStats -> EntityId -> IO ()
|
||||
updatePeriodStats ps (EntityId pId) = do
|
||||
updatePeriod $ day ps
|
||||
updatePeriod $ week ps
|
||||
updatePeriod $ month ps
|
||||
updatePeriodStats :: Ord a => PeriodStats a -> a -> STM ()
|
||||
updatePeriodStats stats pId = do
|
||||
updatePeriod day
|
||||
updatePeriod week
|
||||
updatePeriod month
|
||||
where
|
||||
ph = hash pId
|
||||
updatePeriod ref = unlessM (IS.member ph <$> readIORef ref) $ atomicModifyIORef'_ ref $ IS.insert ph
|
||||
updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId)
|
||||
|
||||
data ProxyStats = ProxyStats
|
||||
{ pRequests :: IORef Int,
|
||||
pSuccesses :: IORef Int, -- includes destination server error responses that will be forwarded to the client
|
||||
pErrorsConnect :: IORef Int,
|
||||
pErrorsCompat :: IORef Int,
|
||||
pErrorsOther :: IORef Int
|
||||
{ pRequests :: TVar Int,
|
||||
pSuccesses :: TVar Int, -- includes destination server error responses that will be forwarded to the client
|
||||
pErrorsConnect :: TVar Int,
|
||||
pErrorsCompat :: TVar Int,
|
||||
pErrorsOther :: TVar Int
|
||||
}
|
||||
|
||||
newProxyStats :: IO ProxyStats
|
||||
newProxyStats = do
|
||||
pRequests <- newIORef 0
|
||||
pSuccesses <- newIORef 0
|
||||
pErrorsConnect <- newIORef 0
|
||||
pErrorsCompat <- newIORef 0
|
||||
pErrorsOther <- newIORef 0
|
||||
pRequests <- newTVarIO 0
|
||||
pSuccesses <- newTVarIO 0
|
||||
pErrorsConnect <- newTVarIO 0
|
||||
pErrorsCompat <- newTVarIO 0
|
||||
pErrorsOther <- newTVarIO 0
|
||||
pure ProxyStats {pRequests, pSuccesses, pErrorsConnect, pErrorsCompat, pErrorsOther}
|
||||
|
||||
data ProxyStatsData = ProxyStatsData
|
||||
@@ -692,30 +608,29 @@ newProxyStatsData = ProxyStatsData {_pRequests = 0, _pSuccesses = 0, _pErrorsCon
|
||||
|
||||
getProxyStatsData :: ProxyStats -> IO ProxyStatsData
|
||||
getProxyStatsData s = do
|
||||
_pRequests <- readIORef $ pRequests s
|
||||
_pSuccesses <- readIORef $ pSuccesses s
|
||||
_pErrorsConnect <- readIORef $ pErrorsConnect s
|
||||
_pErrorsCompat <- readIORef $ pErrorsCompat s
|
||||
_pErrorsOther <- readIORef $ pErrorsOther s
|
||||
_pRequests <- readTVarIO $ pRequests s
|
||||
_pSuccesses <- readTVarIO $ pSuccesses s
|
||||
_pErrorsConnect <- readTVarIO $ pErrorsConnect s
|
||||
_pErrorsCompat <- readTVarIO $ pErrorsCompat s
|
||||
_pErrorsOther <- readTVarIO $ pErrorsOther s
|
||||
pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
|
||||
|
||||
getResetProxyStatsData :: ProxyStats -> IO ProxyStatsData
|
||||
getResetProxyStatsData :: ProxyStats -> STM ProxyStatsData
|
||||
getResetProxyStatsData s = do
|
||||
_pRequests <- atomicSwapIORef (pRequests s) 0
|
||||
_pSuccesses <- atomicSwapIORef (pSuccesses s) 0
|
||||
_pErrorsConnect <- atomicSwapIORef (pErrorsConnect s) 0
|
||||
_pErrorsCompat <- atomicSwapIORef (pErrorsCompat s) 0
|
||||
_pErrorsOther <- atomicSwapIORef (pErrorsOther s) 0
|
||||
_pRequests <- swapTVar (pRequests s) 0
|
||||
_pSuccesses <- swapTVar (pSuccesses s) 0
|
||||
_pErrorsConnect <- swapTVar (pErrorsConnect s) 0
|
||||
_pErrorsCompat <- swapTVar (pErrorsCompat s) 0
|
||||
_pErrorsOther <- swapTVar (pErrorsOther s) 0
|
||||
pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
|
||||
|
||||
-- this function is not thread safe, it is used on server start only
|
||||
setProxyStats :: ProxyStats -> ProxyStatsData -> IO ()
|
||||
setProxyStats :: ProxyStats -> ProxyStatsData -> STM ()
|
||||
setProxyStats s d = do
|
||||
writeIORef (pRequests s) $! _pRequests d
|
||||
writeIORef (pSuccesses s) $! _pSuccesses d
|
||||
writeIORef (pErrorsConnect s) $! _pErrorsConnect d
|
||||
writeIORef (pErrorsCompat s) $! _pErrorsCompat d
|
||||
writeIORef (pErrorsOther s) $! _pErrorsOther d
|
||||
writeTVar (pRequests s) $! _pRequests d
|
||||
writeTVar (pSuccesses s) $! _pSuccesses d
|
||||
writeTVar (pErrorsConnect s) $! _pErrorsConnect d
|
||||
writeTVar (pErrorsCompat s) $! _pErrorsCompat d
|
||||
writeTVar (pErrorsOther s) $! _pErrorsOther d
|
||||
|
||||
instance StrEncoding ProxyStatsData where
|
||||
strEncode ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} =
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
@@ -6,12 +5,10 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Simplex.Messaging.Server.StoreLog
|
||||
( StoreLog, -- constructors are not exported
|
||||
StoreLogRecord (..), -- used in tests
|
||||
openWriteStoreLog,
|
||||
openReadStoreLog,
|
||||
storeLogFilePath,
|
||||
@@ -23,34 +20,31 @@ module Simplex.Messaging.Server.StoreLog
|
||||
logSuspendQueue,
|
||||
logDeleteQueue,
|
||||
logDeleteNotifier,
|
||||
logUpdateQueueTime,
|
||||
readWriteStoreLog,
|
||||
writeQueueStore,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Concurrent.STM
|
||||
import qualified Control.Exception as E
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Control.Monad (foldM, unless, when)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Functor (($>))
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import GHC.IO (catchAny)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Server.MsgStore.Types
|
||||
import Simplex.Messaging.Server.QueueStore
|
||||
import Simplex.Messaging.Server.StoreLog.Types
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util (ifM, tshow, unlessM, whenM)
|
||||
import System.Directory (doesFileExist, renameFile)
|
||||
import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), ServerQueueStatus (..))
|
||||
import Simplex.Messaging.Transport.Buffer (trimCR)
|
||||
import Simplex.Messaging.Util (ifM)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.IO
|
||||
|
||||
-- | opaque container for file handle with a type-safe IOMode
|
||||
-- constructors are not exported, openWriteStoreLog and openReadStoreLog should be used instead
|
||||
data StoreLog (a :: IOMode) where
|
||||
ReadStoreLog :: FilePath -> Handle -> StoreLog 'ReadMode
|
||||
WriteStoreLog :: FilePath -> Handle -> StoreLog 'WriteMode
|
||||
|
||||
data StoreLogRecord
|
||||
= CreateQueue QueueRec
|
||||
| SecureQueue QueueId SndPublicAuthKey
|
||||
@@ -58,20 +52,9 @@ data StoreLogRecord
|
||||
| SuspendQueue QueueId
|
||||
| DeleteQueue QueueId
|
||||
| DeleteNotifier QueueId
|
||||
| UpdateTime QueueId RoundedSystemTime
|
||||
deriving (Show)
|
||||
|
||||
data SLRTag
|
||||
= CreateQueue_
|
||||
| SecureQueue_
|
||||
| AddNotifier_
|
||||
| SuspendQueue_
|
||||
| DeleteQueue_
|
||||
| DeleteNotifier_
|
||||
| UpdateTime_
|
||||
|
||||
instance StrEncoding QueueRec where
|
||||
strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, updatedAt} =
|
||||
strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier} =
|
||||
B.unwords
|
||||
[ "rid=" <> strEncode recipientId,
|
||||
"rk=" <> strEncode recipientKey,
|
||||
@@ -79,13 +62,10 @@ instance StrEncoding QueueRec where
|
||||
"sid=" <> strEncode senderId,
|
||||
"sk=" <> strEncode senderKey
|
||||
]
|
||||
<> sndSecureStr
|
||||
<> if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
|
||||
<> maybe "" notifierStr notifier
|
||||
<> maybe "" updatedAtStr updatedAt
|
||||
where
|
||||
sndSecureStr = if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
|
||||
notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
|
||||
updatedAtStr t = " updated_at=" <> strEncode t
|
||||
|
||||
strP = do
|
||||
recipientId <- "rid=" *> strP_
|
||||
@@ -95,49 +75,24 @@ instance StrEncoding QueueRec where
|
||||
senderKey <- "sk=" *> strP
|
||||
sndSecure <- (" sndSecure=" *> strP) <|> pure False
|
||||
notifier <- optional $ " notifier=" *> strP
|
||||
updatedAt <- optional $ " updated_at=" *> strP
|
||||
pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive, updatedAt}
|
||||
|
||||
instance StrEncoding SLRTag where
|
||||
strEncode = \case
|
||||
CreateQueue_ -> "CREATE"
|
||||
SecureQueue_ -> "SECURE"
|
||||
AddNotifier_ -> "NOTIFIER"
|
||||
SuspendQueue_ -> "SUSPEND"
|
||||
DeleteQueue_ -> "DELETE"
|
||||
DeleteNotifier_ -> "NDELETE"
|
||||
UpdateTime_ -> "TIME"
|
||||
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"CREATE" -> pure CreateQueue_
|
||||
"SECURE" -> pure SecureQueue_
|
||||
"NOTIFIER" -> pure AddNotifier_
|
||||
"SUSPEND" -> pure SuspendQueue_
|
||||
"DELETE" -> pure DeleteQueue_
|
||||
"NDELETE" -> pure DeleteNotifier_
|
||||
"TIME" -> pure UpdateTime_
|
||||
s -> fail $ "invalid log record tag: " <> B.unpack s
|
||||
pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive}
|
||||
|
||||
instance StrEncoding StoreLogRecord where
|
||||
strEncode = \case
|
||||
CreateQueue q -> strEncode (CreateQueue_, q)
|
||||
SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey)
|
||||
AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds)
|
||||
SuspendQueue rId -> strEncode (SuspendQueue_, rId)
|
||||
DeleteQueue rId -> strEncode (DeleteQueue_, rId)
|
||||
DeleteNotifier rId -> strEncode (DeleteNotifier_, rId)
|
||||
UpdateTime rId t -> strEncode (UpdateTime_, rId, t)
|
||||
CreateQueue q -> strEncode (Str "CREATE", q)
|
||||
SecureQueue rId sKey -> strEncode (Str "SECURE", rId, sKey)
|
||||
AddNotifier rId ntfCreds -> strEncode (Str "NOTIFIER", rId, ntfCreds)
|
||||
SuspendQueue rId -> strEncode (Str "SUSPEND", rId)
|
||||
DeleteQueue rId -> strEncode (Str "DELETE", rId)
|
||||
DeleteNotifier rId -> strEncode (Str "NDELETE", rId)
|
||||
|
||||
strP =
|
||||
strP_ >>= \case
|
||||
CreateQueue_ -> CreateQueue <$> strP
|
||||
SecureQueue_ -> SecureQueue <$> strP_ <*> strP
|
||||
AddNotifier_ -> AddNotifier <$> strP_ <*> strP
|
||||
SuspendQueue_ -> SuspendQueue <$> strP
|
||||
DeleteQueue_ -> DeleteQueue <$> strP
|
||||
DeleteNotifier_ -> DeleteNotifier <$> strP
|
||||
UpdateTime_ -> UpdateTime <$> strP_ <*> strP
|
||||
"CREATE " *> (CreateQueue <$> strP)
|
||||
<|> "SECURE " *> (SecureQueue <$> strP_ <*> strP)
|
||||
<|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP)
|
||||
<|> "SUSPEND " *> (SuspendQueue <$> strP)
|
||||
<|> "DELETE " *> (DeleteQueue <$> strP)
|
||||
<|> "NDELETE " *> (DeleteNotifier <$> strP)
|
||||
|
||||
openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode)
|
||||
openWriteStoreLog f = do
|
||||
@@ -147,7 +102,7 @@ openWriteStoreLog f = do
|
||||
|
||||
openReadStoreLog :: FilePath -> IO (StoreLog 'ReadMode)
|
||||
openReadStoreLog f = do
|
||||
unlessM (doesFileExist f) (writeFile f "")
|
||||
doesFileExist f >>= (`unless` writeFile f "")
|
||||
ReadStoreLog f <$> openFile f ReadMode
|
||||
|
||||
storeLogFilePath :: StoreLog a -> FilePath
|
||||
@@ -157,13 +112,11 @@ storeLogFilePath = \case
|
||||
|
||||
closeStoreLog :: StoreLog a -> IO ()
|
||||
closeStoreLog = \case
|
||||
WriteStoreLog _ h -> close_ h
|
||||
ReadStoreLog _ h -> close_ h
|
||||
where
|
||||
close_ h = hClose h `catchAny` \e -> logError ("STORE: closeStoreLog, error closing, " <> tshow e)
|
||||
WriteStoreLog _ h -> hClose h
|
||||
ReadStoreLog _ h -> hClose h
|
||||
|
||||
writeStoreLogRecord :: StrEncoding r => StoreLog 'WriteMode -> r -> IO ()
|
||||
writeStoreLogRecord (WriteStoreLog _ h) r = E.uninterruptibleMask_ $ do
|
||||
writeStoreLogRecord (WriteStoreLog _ h) r = do
|
||||
B.hPut h $ strEncode r `B.snoc` '\n' -- hPutStrLn makes write non-atomic for length > 1024
|
||||
hFlush h
|
||||
|
||||
@@ -185,49 +138,34 @@ logDeleteQueue s = writeStoreLogRecord s . DeleteQueue
|
||||
logDeleteNotifier :: StoreLog 'WriteMode -> QueueId -> IO ()
|
||||
logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier
|
||||
|
||||
logUpdateQueueTime :: StoreLog 'WriteMode -> QueueId -> RoundedSystemTime -> IO ()
|
||||
logUpdateQueueTime s qId t = writeStoreLogRecord s $ UpdateTime qId t
|
||||
readWriteStoreLog :: FilePath -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode)
|
||||
readWriteStoreLog f = do
|
||||
qs <- ifM (doesFileExist f) (readQueues f) (pure M.empty)
|
||||
s <- openWriteStoreLog f
|
||||
writeQueues s qs
|
||||
pure (qs, s)
|
||||
|
||||
readWriteStoreLog :: (FilePath -> s -> IO ()) -> (StoreLog 'WriteMode -> s -> IO ()) -> FilePath -> s -> IO (StoreLog 'WriteMode)
|
||||
readWriteStoreLog readStore writeStore f st =
|
||||
ifM
|
||||
(doesFileExist tempBackup)
|
||||
(useTempBackup >> readWriteLog)
|
||||
(ifM (doesFileExist f) readWriteLog (writeLog "creating store log..."))
|
||||
writeQueues :: StoreLog 'WriteMode -> Map RecipientId QueueRec -> IO ()
|
||||
writeQueues s = mapM_ $ \q -> when (active q) $ logCreateQueue s q
|
||||
where
|
||||
f' = T.pack f
|
||||
tempBackup = f <> ".start"
|
||||
useTempBackup = do
|
||||
-- preserve current file, use temp backup
|
||||
logWarn $ "Server terminated abnormally on last start, restoring state from " <> T.pack tempBackup
|
||||
whenM (doesFileExist f) $ do
|
||||
renameFile f (f <> ".bak")
|
||||
logInfo $ "preserved incomplete state " <> f' <> " as " <> (f' <> ".bak")
|
||||
renameFile tempBackup f
|
||||
readWriteLog = do
|
||||
-- log backup is made in two steps to mitigate the crash during the compacting.
|
||||
-- Temporary backup file .start will be used when it is present.
|
||||
readStore f st
|
||||
renameFile f tempBackup -- 1) make temp backup
|
||||
s <- writeLog "compacting store log (do not terminate)..." -- 2) save state
|
||||
renameBackup -- 3) timed backup
|
||||
pure s
|
||||
writeLog msg = do
|
||||
s <- openWriteStoreLog f
|
||||
logInfo msg
|
||||
writeStore s st
|
||||
pure s
|
||||
renameBackup = do
|
||||
ts <- getCurrentTime
|
||||
let timedBackup = f <> "." <> iso8601Show ts
|
||||
renameFile tempBackup timedBackup
|
||||
logInfo $ "original state preserved as " <> T.pack timedBackup
|
||||
|
||||
writeQueueStore :: STMQueueStore s => StoreLog 'WriteMode -> s -> IO ()
|
||||
writeQueueStore s st = readTVarIO (activeMsgQueues st) >>= mapM_ writeQueue . M.assocs
|
||||
where
|
||||
writeQueue (rId, q) =
|
||||
readTVarIO (queueRec' q) >>= \case
|
||||
Just q' -> when (active q') $ logCreateQueue s q' -- TODO we should log suspended queues when we use them
|
||||
Nothing -> atomically $ TM.delete rId $ activeMsgQueues st
|
||||
active QueueRec {status} = status == QueueActive
|
||||
|
||||
readQueues :: FilePath -> IO (Map RecipientId QueueRec)
|
||||
readQueues f = foldM processLine M.empty . LB.lines =<< LB.readFile f
|
||||
where
|
||||
processLine :: Map RecipientId QueueRec -> LB.ByteString -> IO (Map RecipientId QueueRec)
|
||||
processLine m s' = case strDecode $ trimCR s of
|
||||
Right r -> pure $ procLogRecord r
|
||||
Left e -> printError e $> m
|
||||
where
|
||||
s = LB.toStrict s'
|
||||
procLogRecord :: StoreLogRecord -> Map RecipientId QueueRec
|
||||
procLogRecord = \case
|
||||
CreateQueue q -> M.insert (recipientId q) q m
|
||||
SecureQueue qId sKey -> M.adjust (\q -> q {senderKey = Just sKey}) qId m
|
||||
AddNotifier qId ntfCreds -> M.adjust (\q -> q {notifier = Just ntfCreds}) qId m
|
||||
SuspendQueue qId -> M.adjust (\q -> q {status = QueueOff}) qId m
|
||||
DeleteQueue qId -> M.delete qId m
|
||||
DeleteNotifier qId -> M.adjust (\q -> q {notifier = Nothing}) qId m
|
||||
printError :: String -> IO ()
|
||||
printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
|
||||
|
||||
@@ -1,13 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
|
||||
module Simplex.Messaging.Server.StoreLog.Types where
|
||||
|
||||
import System.IO (Handle, IOMode (..))
|
||||
|
||||
-- | opaque container for file handle with a type-safe IOMode
|
||||
-- constructors are not exported, openWriteStoreLog and openReadStoreLog should be used instead
|
||||
data StoreLog (a :: IOMode) where
|
||||
ReadStoreLog :: FilePath -> Handle -> StoreLog 'ReadMode
|
||||
WriteStoreLog :: FilePath -> Handle -> StoreLog 'WriteMode
|
||||
@@ -9,7 +9,6 @@ module Simplex.Messaging.TMap
|
||||
member,
|
||||
memberIO,
|
||||
insert,
|
||||
insertM,
|
||||
delete,
|
||||
lookupInsert,
|
||||
lookupDelete,
|
||||
@@ -63,10 +62,6 @@ insert :: Ord k => k -> a -> TMap k a -> STM ()
|
||||
insert k v m = modifyTVar' m $ M.insert k v
|
||||
{-# INLINE insert #-}
|
||||
|
||||
insertM :: Ord k => k -> STM a -> TMap k a -> STM ()
|
||||
insertM k f m = modifyTVar' m . M.insert k =<< f
|
||||
{-# INLINE insertM #-}
|
||||
|
||||
delete :: Ord k => k -> TMap k a -> STM ()
|
||||
delete k m = modifyTVar' m $ M.delete k
|
||||
{-# INLINE delete #-}
|
||||
|
||||
@@ -47,8 +47,6 @@ module Simplex.Messaging.Transport
|
||||
authCmdsSMPVersion,
|
||||
sendingProxySMPVersion,
|
||||
sndAuthKeySMPVersion,
|
||||
deletedEventSMPVersion,
|
||||
encryptedBlockSMPVersion,
|
||||
simplexMQVersion,
|
||||
smpBlockSize,
|
||||
TransportConfig (..),
|
||||
@@ -66,15 +64,13 @@ module Simplex.Messaging.Transport
|
||||
ALPN,
|
||||
connectTLS,
|
||||
closeTLS,
|
||||
defaultSupportedParams,
|
||||
defaultSupportedParamsHTTPS,
|
||||
supportedParameters,
|
||||
withTlsUnique,
|
||||
|
||||
-- * SMP transport
|
||||
THandle (..),
|
||||
THandleParams (..),
|
||||
THandleAuth (..),
|
||||
TSbChainKeys (..),
|
||||
TransportError (..),
|
||||
HandshakeError (..),
|
||||
smpServerHandshake,
|
||||
@@ -88,10 +84,8 @@ module Simplex.Messaging.Transport
|
||||
where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (forM, (<$!>))
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import qualified Data.Aeson.TH as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
@@ -103,8 +97,6 @@ import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Default (def)
|
||||
import Data.Functor (($>))
|
||||
import Data.Tuple (swap)
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Version (showVersion)
|
||||
import Data.Word (Word16)
|
||||
import qualified Data.X509 as X
|
||||
@@ -121,9 +113,9 @@ import Simplex.Messaging.Transport.Buffer
|
||||
import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith)
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.Messaging.Version.Internal
|
||||
import System.IO.Error (isEOFError)
|
||||
import UnliftIO.Exception (Exception)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
|
||||
-- * Transport parameters
|
||||
|
||||
@@ -138,10 +130,6 @@ smpBlockSize = 16384
|
||||
-- 5 - basic auth for SMP servers (11/12/2022)
|
||||
-- 6 - allow creating queues without subscribing (9/10/2023)
|
||||
-- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024)
|
||||
-- 8 - SMP proxy for sender commands
|
||||
-- 9 - faster handshake: SKEY command for sender to secure queue
|
||||
-- 10 - DELD event to subscriber when queue is deleted via another connnection
|
||||
-- 11 - additional encryption of transport blocks with forward secrecy (9/14/2024)
|
||||
|
||||
data SMPVersion
|
||||
|
||||
@@ -172,20 +160,14 @@ sendingProxySMPVersion = VersionSMP 8
|
||||
sndAuthKeySMPVersion :: VersionSMP
|
||||
sndAuthKeySMPVersion = VersionSMP 9
|
||||
|
||||
deletedEventSMPVersion :: VersionSMP
|
||||
deletedEventSMPVersion = VersionSMP 10
|
||||
|
||||
encryptedBlockSMPVersion :: VersionSMP
|
||||
encryptedBlockSMPVersion = VersionSMP 11
|
||||
|
||||
currentClientSMPRelayVersion :: VersionSMP
|
||||
currentClientSMPRelayVersion = VersionSMP 11
|
||||
currentClientSMPRelayVersion = VersionSMP 9
|
||||
|
||||
legacyServerSMPRelayVersion :: VersionSMP
|
||||
legacyServerSMPRelayVersion = VersionSMP 6
|
||||
|
||||
currentServerSMPRelayVersion :: VersionSMP
|
||||
currentServerSMPRelayVersion = VersionSMP 11
|
||||
currentServerSMPRelayVersion = VersionSMP 9
|
||||
|
||||
-- Max SMP protocol version to be used in e2e encrypted
|
||||
-- connection between client and server, as defined by SMP proxy.
|
||||
@@ -223,7 +205,7 @@ data TransportConfig = TransportConfig
|
||||
transportTimeout :: Maybe Int
|
||||
}
|
||||
|
||||
class Typeable c => Transport c where
|
||||
class Transport c where
|
||||
transport :: ATransport
|
||||
transport = ATransport (TProxy @c)
|
||||
|
||||
@@ -321,8 +303,8 @@ closeTLS ctx =
|
||||
`E.finally` T.contextClose ctx
|
||||
`catchAll_` pure ()
|
||||
|
||||
defaultSupportedParams :: T.Supported
|
||||
defaultSupportedParams =
|
||||
supportedParameters :: T.Supported
|
||||
supportedParameters =
|
||||
def
|
||||
{ T.supportedVersions = [T.TLS13, T.TLS12],
|
||||
T.supportedCiphers =
|
||||
@@ -330,29 +312,8 @@ defaultSupportedParams =
|
||||
TE.cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 -- for TLS12
|
||||
],
|
||||
T.supportedHashSignatures = [(T.HashIntrinsic, T.SignatureEd448), (T.HashIntrinsic, T.SignatureEd25519)],
|
||||
T.supportedGroups = [T.X448, T.X25519],
|
||||
T.supportedSecureRenegotiation = False
|
||||
}
|
||||
|
||||
-- | A selection of extra parameters to accomodate browser chains
|
||||
defaultSupportedParamsHTTPS :: T.Supported
|
||||
defaultSupportedParamsHTTPS =
|
||||
defaultSupportedParams
|
||||
{ T.supportedCiphers = TE.ciphersuite_strong,
|
||||
T.supportedGroups = [T.X25519, T.X448, T.FFDHE4096, T.FFDHE6144, T.FFDHE8192, T.P521],
|
||||
T.supportedHashSignatures =
|
||||
[ (T.HashIntrinsic, T.SignatureEd448),
|
||||
(T.HashIntrinsic, T.SignatureEd25519),
|
||||
(T.HashSHA256, T.SignatureECDSA),
|
||||
(T.HashSHA384, T.SignatureECDSA),
|
||||
(T.HashSHA512, T.SignatureECDSA),
|
||||
(T.HashIntrinsic, T.SignatureRSApssRSAeSHA512),
|
||||
(T.HashIntrinsic, T.SignatureRSApssRSAeSHA384),
|
||||
(T.HashIntrinsic, T.SignatureRSApssRSAeSHA256),
|
||||
(T.HashSHA512, T.SignatureRSA),
|
||||
(T.HashSHA384, T.SignatureRSA),
|
||||
(T.HashSHA256, T.SignatureRSA)
|
||||
]
|
||||
T.supportedSecureRenegotiation = False,
|
||||
T.supportedGroups = [T.X448, T.X25519]
|
||||
}
|
||||
|
||||
instance Transport TLS where
|
||||
@@ -378,12 +339,11 @@ instance Transport TLS where
|
||||
|
||||
getLn :: TLS -> IO ByteString
|
||||
getLn TLS {tlsContext, tlsBuffer} = do
|
||||
getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catches` [E.Handler handleTlsEOF, E.Handler handleEOF]
|
||||
getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catch` handleEOF
|
||||
where
|
||||
handleTlsEOF = \case
|
||||
T.PostHandshake T.Error_EOF -> E.throwIO TEBadBlock
|
||||
handleEOF = \case
|
||||
T.Error_EOF -> E.throwIO TEBadBlock
|
||||
e -> E.throwIO e
|
||||
handleEOF e = if isEOFError e then E.throwIO TEBadBlock else E.throwIO e
|
||||
|
||||
-- * SMP transport
|
||||
|
||||
@@ -407,8 +367,6 @@ data THandleParams v p = THandleParams
|
||||
-- | do NOT send session ID in transmission, but include it into signed message
|
||||
-- based on protocol version
|
||||
implySessId :: Bool,
|
||||
-- -- | additional block encryption
|
||||
encryptBlock :: Maybe TSbChainKeys,
|
||||
-- | send multiple transmissions in a single block
|
||||
-- based on protocol version
|
||||
batch :: Bool
|
||||
@@ -427,11 +385,6 @@ data THandleAuth (p :: TransportPeer) where
|
||||
} ->
|
||||
THandleAuth 'TServer
|
||||
|
||||
data TSbChainKeys = TSbChainKeys
|
||||
{ sndKey :: TVar C.SbChainKey,
|
||||
rcvKey :: TVar C.SbChainKey
|
||||
}
|
||||
|
||||
-- | TLS-unique channel binding
|
||||
type SessionId = ByteString
|
||||
|
||||
@@ -534,26 +487,16 @@ instance Encoding TransportError where
|
||||
|
||||
-- | Pad and send block to SMP transport.
|
||||
tPutBlock :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
|
||||
tPutBlock THandle {connection = c, params = THandleParams {blockSize, encryptBlock}} block = do
|
||||
block_ <- case encryptBlock of
|
||||
Just TSbChainKeys {sndKey} -> do
|
||||
(sk, nonce) <- atomically $ stateTVar sndKey C.sbcHkdf
|
||||
pure $ C.sbEncrypt sk nonce block (blockSize - 16)
|
||||
Nothing -> pure $ C.pad block blockSize
|
||||
bimapM (const $ pure TELargeMsg) (cPut c) block_
|
||||
tPutBlock THandle {connection = c, params = THandleParams {blockSize}} block =
|
||||
bimapM (const $ pure TELargeMsg) (cPut c) $
|
||||
C.pad block blockSize
|
||||
|
||||
-- | Receive block from SMP transport.
|
||||
tGetBlock :: Transport c => THandle v c p -> IO (Either TransportError ByteString)
|
||||
tGetBlock THandle {connection = c, params = THandleParams {blockSize, encryptBlock}} = do
|
||||
tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
|
||||
msg <- cGet c blockSize
|
||||
if B.length msg == blockSize
|
||||
then
|
||||
first (const TELargeMsg) <$>
|
||||
case encryptBlock of
|
||||
Just TSbChainKeys {rcvKey} -> do
|
||||
(sk, nonce) <- atomically $ stateTVar rcvKey C.sbcHkdf
|
||||
pure $ C.sbDecrypt sk nonce msg
|
||||
Nothing -> pure $ C.unPad msg
|
||||
then pure . first (const TELargeMsg) $ C.unPad msg
|
||||
else ioe_EOF
|
||||
|
||||
-- | Server SMP transport handshake.
|
||||
@@ -572,7 +515,7 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
|
||||
throwE $ TEHandshake IDENTITY
|
||||
| otherwise ->
|
||||
case compatibleVRange' smpVersionRange v of
|
||||
Just (Compatible vr) -> liftIO $ smpTHandleServer th v vr pk k'
|
||||
Just (Compatible vr) -> pure $ smpTHandleServer th v vr pk k'
|
||||
Nothing -> throwE TEVersion
|
||||
|
||||
-- | Client SMP transport handshake.
|
||||
@@ -596,36 +539,23 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
|
||||
(,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
|
||||
let v = maxVersion vr
|
||||
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_}
|
||||
liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_
|
||||
pure $ smpTHandleClient th v vr (snd <$> ks_) ck_
|
||||
Nothing -> throwE TEVersion
|
||||
|
||||
smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> IO (THandleSMP c 'TServer)
|
||||
smpTHandleServer th v vr pk k_ = do
|
||||
let thAuth = Just THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
|
||||
be <- blockEncryption th v thAuth
|
||||
pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys <$> be
|
||||
smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer
|
||||
smpTHandleServer th v vr pk k_ =
|
||||
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$!> k_}
|
||||
in smpTHandle_ th v vr (Just thAuth)
|
||||
|
||||
smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> IO (THandleSMP c 'TClient)
|
||||
smpTHandleClient th v vr pk_ ck_ = do
|
||||
smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient
|
||||
smpTHandleClient th v vr pk_ ck_ =
|
||||
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = forceCertChain ck, sessSecret = C.dh' k <$!> pk_}) <$!> ck_
|
||||
be <- blockEncryption th v thAuth
|
||||
-- swap is needed to use client's sndKey as server's rcvKey and vice versa
|
||||
pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys . swap <$> be
|
||||
in smpTHandle_ th v vr thAuth
|
||||
|
||||
blockEncryption :: THandleSMP c p -> VersionSMP -> Maybe (THandleAuth p) -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
|
||||
blockEncryption THandle {params = THandleParams {sessionId}} v = \case
|
||||
Just thAuth | v >= encryptedBlockSMPVersion -> case thAuth of
|
||||
THAuthClient {sessSecret} -> be sessSecret
|
||||
THAuthServer {sessSecret'} -> be sessSecret'
|
||||
_ -> pure Nothing
|
||||
where
|
||||
be :: Maybe C.DhSecretX25519 -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
|
||||
be = mapM $ \(C.DhSecretX25519 secret) -> bimapM newTVarIO newTVarIO $ C.sbcInit sessionId secret
|
||||
|
||||
smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> Maybe TSbChainKeys -> THandleSMP c p
|
||||
smpTHandle_ th@THandle {params} v vr thAuth encryptBlock =
|
||||
smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> THandleSMP c p
|
||||
smpTHandle_ th@THandle {params} v vr thAuth =
|
||||
-- TODO drop SMP v6: make thAuth non-optional
|
||||
let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion, encryptBlock}
|
||||
let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion}
|
||||
in (th :: THandleSMP c p) {params = params'}
|
||||
|
||||
{-# INLINE forceCertChain #-}
|
||||
@@ -657,7 +587,6 @@ smpTHandle c = THandle {connection = c, params}
|
||||
thVersion = v,
|
||||
thAuth = Nothing,
|
||||
implySessId = False,
|
||||
encryptBlock = Nothing,
|
||||
batch = True
|
||||
}
|
||||
|
||||
|
||||
@@ -13,13 +13,9 @@ module Simplex.Messaging.Transport.Client
|
||||
defaultSMPPort,
|
||||
defaultTcpConnectTimeout,
|
||||
defaultTransportClientConfig,
|
||||
defaultSocksProxyWithAuth,
|
||||
defaultSocksProxy,
|
||||
defaultSocksHost,
|
||||
TransportClientConfig (..),
|
||||
SocksProxy (..),
|
||||
SocksProxyWithAuth (..),
|
||||
SocksAuth (..),
|
||||
SocksProxy,
|
||||
TransportHost (..),
|
||||
TransportHosts (..),
|
||||
TransportHosts_ (..),
|
||||
@@ -27,7 +23,7 @@ module Simplex.Messaging.Transport.Client
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Applicative (optional)
|
||||
import Control.Logger.Simple (logError)
|
||||
import Control.Monad (when)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
@@ -83,7 +79,7 @@ instance StrEncoding TransportHost where
|
||||
strP =
|
||||
A.choice
|
||||
[ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
|
||||
maybe (Left "bad IPv6") (Right . THIPv6 . fromIPv6w) . readMaybe . B.unpack <$?> ipv6StrP,
|
||||
maybe (Left "bad IPv6") (Right . THIPv6 . fromIPv6w) . readMaybe . B.unpack <$?> A.takeWhile1 (\c -> isHexDigit c || c == ':'),
|
||||
THOnionHost <$> ((<>) <$> A.takeWhile (\c -> isAsciiLower c || isDigit c) <*> A.string ".onion"),
|
||||
THDomainName . B.unpack <$> (notOnion <$?> A.takeWhile1 (A.notInClass ":#,;/ \n\r\t"))
|
||||
]
|
||||
@@ -91,9 +87,6 @@ instance StrEncoding TransportHost where
|
||||
ipNum = validIP <$?> (A.decimal <* A.char '.')
|
||||
validIP :: Int -> Either String Word8
|
||||
validIP n = if 0 <= n && n <= 255 then Right $ fromIntegral n else Left "invalid IP address"
|
||||
ipv6StrP =
|
||||
A.char '[' *> A.takeWhile1 (/= ']') <* A.char ']'
|
||||
<|> A.takeWhile1 (\c -> isHexDigit c || c == ':')
|
||||
notOnion s = if ".onion" `B.isSuffixOf` s then Left "invalid onion host" else Right s
|
||||
|
||||
instance ToJSON TransportHost where
|
||||
@@ -125,8 +118,7 @@ data TransportClientConfig = TransportClientConfig
|
||||
tcpKeepAlive :: Maybe KeepAliveOpts,
|
||||
logTLSErrors :: Bool,
|
||||
clientCredentials :: Maybe (X.CertificateChain, T.PrivKey),
|
||||
alpn :: Maybe [ALPN],
|
||||
useSNI :: Bool
|
||||
alpn :: Maybe [ALPN]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -135,23 +127,23 @@ defaultTcpConnectTimeout :: Int
|
||||
defaultTcpConnectTimeout = 25_000_000
|
||||
|
||||
defaultTransportClientConfig :: TransportClientConfig
|
||||
defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing True
|
||||
defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing
|
||||
|
||||
clientTransportConfig :: TransportClientConfig -> TransportConfig
|
||||
clientTransportConfig TransportClientConfig {logTLSErrors} =
|
||||
TransportConfig {logTLSErrors, transportTimeout = Nothing}
|
||||
|
||||
-- | Connect to passed TCP host:port and pass handle to the client.
|
||||
runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
|
||||
runTransportClient = runTLSTransportClient defaultSupportedParams Nothing
|
||||
runTransportClient :: Transport c => TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
|
||||
runTransportClient = runTLSTransportClient supportedParameters Nothing
|
||||
|
||||
runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
|
||||
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn, useSNI} socksCreds host port keyHash client = do
|
||||
runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
|
||||
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do
|
||||
serverCert <- newEmptyTMVarIO
|
||||
let hostName = B.unpack $ strEncode host
|
||||
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn useSNI serverCert
|
||||
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert
|
||||
connectTCP = case socksProxy of
|
||||
Just proxy -> connectSocksClient proxy socksCreds (hostAddr host)
|
||||
Just proxy -> connectSocksClient proxy proxyUsername (hostAddr host)
|
||||
_ -> connectTCPClient hostName
|
||||
c <- do
|
||||
sock <- connectTCP port
|
||||
@@ -199,76 +191,45 @@ connectTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
|
||||
defaultSMPPort :: PortNumber
|
||||
defaultSMPPort = 5223
|
||||
|
||||
connectSocksClient :: SocksProxy -> Maybe SocksCredentials -> SocksHostAddress -> ServiceName -> IO Socket
|
||||
connectSocksClient (SocksProxy addr) socksCreds hostAddr _port = do
|
||||
connectSocksClient :: SocksProxy -> Maybe ByteString -> SocksHostAddress -> ServiceName -> IO Socket
|
||||
connectSocksClient (SocksProxy addr) proxyUsername hostAddr _port = do
|
||||
let port = if null _port then defaultSMPPort else fromMaybe defaultSMPPort $ readMaybe _port
|
||||
fst <$> case socksCreds of
|
||||
Just creds -> socksConnectAuth (defaultSocksConf addr) (SocksAddress hostAddr port) creds
|
||||
fst <$> case proxyUsername of
|
||||
Just username -> socksConnectAuth (defaultSocksConf addr) (SocksAddress hostAddr port) (SocksCredentials username "")
|
||||
_ -> socksConnect (defaultSocksConf addr) (SocksAddress hostAddr port)
|
||||
|
||||
defaultSocksHost :: (Word8, Word8, Word8, Word8)
|
||||
defaultSocksHost = (127, 0, 0, 1)
|
||||
|
||||
defaultSocksProxyWithAuth :: SocksProxyWithAuth
|
||||
defaultSocksProxyWithAuth = SocksProxyWithAuth SocksIsolateByAuth defaultSocksProxy
|
||||
defaultSocksHost :: HostAddress
|
||||
defaultSocksHost = tupleToHostAddress (127, 0, 0, 1)
|
||||
|
||||
defaultSocksProxy :: SocksProxy
|
||||
defaultSocksProxy = SocksProxy $ SockAddrInet 9050 $ tupleToHostAddress defaultSocksHost
|
||||
defaultSocksProxy = SocksProxy $ SockAddrInet 9050 defaultSocksHost
|
||||
|
||||
newtype SocksProxy = SocksProxy SockAddr
|
||||
deriving (Eq)
|
||||
|
||||
data SocksProxyWithAuth = SocksProxyWithAuth SocksAuth SocksProxy
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SocksAuth
|
||||
= SocksAuthUsername {username :: ByteString, password :: ByteString}
|
||||
| SocksAuthNull
|
||||
| SocksIsolateByAuth -- this is default
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Show SocksProxy where show (SocksProxy addr) = show addr
|
||||
|
||||
instance StrEncoding SocksProxy where
|
||||
strEncode = B.pack . show
|
||||
strP = do
|
||||
host <- fromMaybe (THIPv4 defaultSocksHost) <$> optional strP
|
||||
host <- maybe defaultSocksHost tupleToHostAddress <$> optional ipv4P
|
||||
port <- fromMaybe 9050 <$> optional (A.char ':' *> (fromInteger <$> A.decimal))
|
||||
SocksProxy <$> socksAddr port host
|
||||
pure . SocksProxy $ SockAddrInet port host
|
||||
where
|
||||
socksAddr port = \case
|
||||
THIPv4 addr -> pure $ SockAddrInet port $ tupleToHostAddress addr
|
||||
THIPv6 addr -> pure $ SockAddrInet6 port 0 addr 0
|
||||
_ -> fail "SOCKS5 host should be IPv4 or IPv6 address"
|
||||
ipv4P = (,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal
|
||||
ipNum = A.decimal <* A.char '.'
|
||||
|
||||
instance StrEncoding SocksProxyWithAuth where
|
||||
strEncode (SocksProxyWithAuth auth proxy) = strEncode auth <> strEncode proxy
|
||||
strP = SocksProxyWithAuth <$> strP <*> strP
|
||||
|
||||
instance ToJSON SocksProxyWithAuth where
|
||||
instance ToJSON SocksProxy where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
instance FromJSON SocksProxyWithAuth where
|
||||
parseJSON = strParseJSON "SocksProxyWithAuth"
|
||||
instance FromJSON SocksProxy where
|
||||
parseJSON = strParseJSON "SocksProxy"
|
||||
|
||||
instance StrEncoding SocksAuth where
|
||||
strEncode = \case
|
||||
SocksAuthUsername {username, password} -> username <> ":" <> password <> "@"
|
||||
SocksAuthNull -> "@"
|
||||
SocksIsolateByAuth -> ""
|
||||
strP = usernameP <|> (SocksAuthNull <$ A.char '@') <|> pure SocksIsolateByAuth
|
||||
where
|
||||
usernameP = do
|
||||
username <- A.takeTill (== ':') <* A.char ':'
|
||||
password <- A.takeTill (== '@') <* A.char '@'
|
||||
pure SocksAuthUsername {username, password}
|
||||
|
||||
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> Bool -> TMVar X.CertificateChain -> T.ClientParams
|
||||
mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ sni serverCerts =
|
||||
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> TMVar X.CertificateChain -> T.ClientParams
|
||||
mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ serverCerts =
|
||||
(T.defaultParamsClient host p)
|
||||
{ T.clientUseServerNameIndication = sni,
|
||||
T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
|
||||
{ T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
|
||||
T.clientHooks =
|
||||
def
|
||||
{ T.onServerCertificate = onServerCert,
|
||||
|
||||
@@ -32,8 +32,8 @@ import qualified Time.System as Hourglass
|
||||
-- leaf <- genCredentials (Just ca) (0, 1) "Entity" -- session-signing cert
|
||||
-- pure $ tlsCredentials (leaf :| [ca])
|
||||
-- @
|
||||
tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credential)
|
||||
tlsCredentials credentials = (C.KeyHash rootFP, (X509.CertificateChain certs, privateToTls $ snd leafKey))
|
||||
tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credentials)
|
||||
tlsCredentials credentials = (C.KeyHash rootFP, TLS.Credentials [(X509.CertificateChain certs, privateToTls $ snd leafKey)])
|
||||
where
|
||||
Fingerprint rootFP = getFingerprint root X509.HashSHA256
|
||||
leafKey = fst $ L.head credentials
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user