Compare commits

..
Author SHA1 Message Date
Evgeny Poberezkin 04e4a37d85 6.1.0.4 2024-10-02 09:51:29 +01:00
Evgeny Poberezkin 0ba3e69872 Revert "smp server: persist notifications to avoid losing them when ntf server is offline (#1336)"
This reverts commit 0739f7b702.
2024-10-02 09:49:43 +01:00
Evgeny 2ab0c2a7c6 smp server: fix notifiers lost when compacting store log (#1347) 2024-10-01 22:28:01 +01:00
spaced4ndy 243548631a ntf: repeat failed token deletions (#1346) 2024-10-01 16:30:14 +04:00
Evgeny Poberezkin da79d544cf 6.1.0.3 2024-09-30 18:27:14 +01:00
spaced4ndy e808825c95 ntf: fix endless worker loop (#1345) 2024-09-30 15:29:14 +01:00
Evgeny Poberezkin a9576935cf 6.1.0.2 2024-09-29 18:54:04 +01:00
spaced4ndyandEvgeny Poberezkin 9cf6c97137 ntf: batch ntf worker command processing (#1337)
* ntf: batch ntf worker command processing

* remove comment

* change batch size

* wip

* catch

* refactor

* refactor

* batch check

* refactor

* reschedule

* increase ntfSubCheckInterval

* first check interval

* check more statuses

* refactor, remove foldr'

* refactor 2

* refactor client

* refactor 3

* ntf server: improve support for batched commands (#1340)

* re-create ntf subscriptions on NTF AUTH errors

* name

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2024-09-29 18:50:38 +01:00
Evgeny 0739f7b702 smp server: persist notifications to avoid losing them when ntf server is offline (#1336)
* ntf server: types for storing notifications

* fix tests

* remove comments

* batch NMSGs test

* fix test

* thread to expire notifications

* persist notifications on restart

* optimize

* refactor

* remove reverse

* control port stats
2024-09-29 18:50:16 +01:00
Evgeny e12710fa55 smp server: show version on server page (#1341) 2024-09-29 18:46:38 +01:00
EvgenyandIC Rainbow 2a120dfe57 smp server: Allow serving HTTPS and transport on the same port (v2) (#1327)
* smp-server: Allow serving HTTPS and transport on the same port

* update rfc

* servers: refactor TLS credentials

* provide server credentials in SNI hook

* determine TLS server params dynamically, when starting the server

* remove alpn from TransportServerConfig to decide it dynamically where server is started

* diff

* combine HTTP and SMP on the shared port

* Update to SockAddr

* Fix params and web.https parser

* Switch fork urls

* WIP: add smpServerTestStatic test

* Update warp-tls repo

* shared connection tests

* cleanup

* Add protocol tests

* rename cert file, enable both ports and web by default

* terminate with message on missing credentials

* test cert file

* client option to use port 443 as default SMP port

* use SNI in non-SMP clients

* supported

* remove TODO

* advice

* fix test build

* Add RSA-4096 check for web creds, fix test

* Remove directory listing from static app

* message

* messages

* update log tests

---------

Co-authored-by: IC Rainbow <aenor.realm@gmail.com>
2024-09-28 23:15:17 +01:00
Evgeny 3c18c4b66a servers: refactor TLS credentials (#1326)
* servers: refactor TLS credentials

* provide server credentials in SNI hook

* determine TLS server params dynamically, when starting the server

* remove alpn from TransportServerConfig to decide it dynamically where server is started
2024-09-28 22:21:08 +01:00
Evgeny 21eee2b548 smp servers: separately account for subscribed clients, to disconnect those without subscriptions more effectively (and to be able to deliver notifications to subscribed ntf servers) (#1339) 2024-09-28 19:59:53 +01:00
52 changed files with 1414 additions and 542 deletions
+1 -1
View File
@@ -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 cfgPath logPath
withGlobalLogging logCfg $ smpServerCLI_ Static.generateSite Static.serveStaticFiles Static.attachStaticFiles cfgPath logPath
+4
View File
@@ -221,6 +221,10 @@
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>
+47 -6
View File
@@ -7,22 +7,29 @@ module Static where
import Control.Logger.Simple
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B
import Data.IORef (readIORef)
import Data.Maybe (fromMaybe)
import Data.String (fromString)
import Data.Text.Encoding (encodeUtf8)
import Network.Wai.Application.Static as S
import Network.Wai.Handler.Warp as W
import qualified Network.Wai.Handler.WarpTLS as W
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 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
@@ -31,9 +38,42 @@ 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)"
W.runTLS (W.tlsSettings cert key) (mkSettings port) (S.staticApp $ S.defaultFileServerSettings webStaticPath)
WT.runTLS (WT.tlsSettings cert key) (mkSettings port) app
where
mkSettings port = setPort port defaultSettings
app = staticFiles webStaticPath
mkSettings port = W.setPort port W.defaultSettings
-- | 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 settings $ \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 settings app
where
app = staticFiles path
settings = W.defaultSettings
-- 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)
staticFiles :: FilePath -> Application
staticFiles root = S.staticApp settings
where
settings = (S.defaultFileServerSettings root)
{ S.ssListing = Nothing
}
generateSite :: ServerInformation -> Maybe TransportHost -> FilePath -> IO ()
generateSite si onionHost sitePath = do
@@ -78,6 +118,7 @@ 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} =
+14
View File
@@ -28,3 +28,17 @@ 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
+17 -6
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 6.1.0.1
version: 6.1.0.4
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -123,9 +123,10 @@ executables:
dependencies:
- file-embed
- simplexmq
- wai
- wai-app-static
- warp
- warp-tls
- warp ==3.3.30 # the last one before http2-5.0
- warp-tls ==3.4.7 # extra internals exposed
ghc-options:
- -threaded
- -rtsopts
@@ -159,19 +160,29 @@ executables:
tests:
simplexmq-test:
source-dirs: tests
source-dirs:
- tests
- apps/smp-server/web
main: Test.hs
dependencies:
- simplexmq
- deepseq == 1.4.*
- file-embed
- generic-random == 1.5.*
- hspec == 2.11.*
- hspec-core == 2.11.*
- http-client
- http-client-tls
- HUnit == 1.6.*
- main-tester == 0.2.*
- QuickCheck == 2.14.*
- silently == 1.2.*
- main-tester == 0.2.*
- simplexmq
- timeit == 2.0.*
- unordered-containers
- wai
- wai-app-static
- warp
- warp-tls
ghc-options:
- -threaded
- -rtsopts
+163
View File
@@ -0,0 +1,163 @@
# 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.
+16 -3
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 6.1.0.1
version: 6.1.0.4
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -135,6 +135,7 @@ 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.TRcvQueues
Simplex.Messaging.Client
Simplex.Messaging.Client.Agent
@@ -419,9 +420,10 @@ executable smp-server
, transformers ==0.6.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
, wai
, wai-app-static
, warp
, warp-tls
, warp ==3.3.30
, warp-tls ==3.4.7
, websockets ==0.12.*
, yaml ==0.11.*
, zstd ==0.1.3.*
@@ -627,9 +629,12 @@ test-suite simplexmq-test
XFTPCLI
XFTPClient
XFTPServerTests
Static
Static.Embedded
Paths_simplexmq
hs-source-dirs:
tests
apps/smp-server/web
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
@@ -657,12 +662,15 @@ test-suite simplexmq-test
, deepseq ==1.4.*
, direct-sqlcipher ==2.3.*
, directory ==1.3.*
, file-embed
, filepath ==1.4.*
, generic-random ==1.5.*
, hashable ==1.4.*
, hourglass ==0.2.*
, hspec ==2.11.*
, hspec-core ==2.11.*
, http-client
, http-client-tls
, http-types ==0.12.*
, http2 >=4.2.2 && <4.3
, ini ==0.4.1
@@ -692,6 +700,11 @@ test-suite simplexmq-test
, transformers ==0.6.*
, unliftio ==0.2.*
, unliftio-core ==0.2.*
, unordered-containers
, wai
, wai-app-static
, warp
, warp-tls
, websockets ==0.12.*
, yaml ==0.11.*
, zstd ==0.1.3.*
+3 -3
View File
@@ -53,7 +53,7 @@ import Simplex.Messaging.Protocol
SenderId,
pattern NoEntity,
)
import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters)
import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.Client
@@ -104,7 +104,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
ProtocolServer _ host port keyHash = srv
useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
let tcConfig = (transportClientConfig xftpNetworkConfig useHost) {alpn = clientALPN}
let tcConfig = (transportClientConfig xftpNetworkConfig useHost True) {alpn = clientALPN}
http2Config = xftpHTTP2Config tcConfig config
clientVar <- newTVarIO Nothing
let usePort = if null port then "443" else port
@@ -173,7 +173,7 @@ xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfi
xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} =
defaultHTTP2ClientConfig
{ bodyHeadSize = xftpBlockSize,
suportedTLSParams = supportedParameters,
suportedTLSParams = defaultSupportedParams,
connTimeout = tcpConnectTimeout,
transportConfig
}
+9 -10
View File
@@ -60,12 +60,12 @@ import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemT
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..))
import Simplex.Messaging.Transport (ALPN, SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams)
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, tlsServerCredentials)
import Simplex.Messaging.Transport.Server (runLocalTCPServer)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Exit (exitFailure)
@@ -91,32 +91,31 @@ data XFTPTransportRequest = XFTPTransportRequest
runXFTPServer :: XFTPServerConfig -> IO ()
runXFTPServer cfg = do
started <- newEmptyTMVarIO
runXFTPServerBlocking started cfg
runXFTPServerBlocking started cfg $ Just supportedXFTPhandshakes
runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> Maybe [ALPN] -> IO ()
runXFTPServerBlocking started cfg alpn_ = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started alpn_)
data Handshake
= HandshakeSent C.PrivateKeyX25519
| HandshakeAccepted (THandleParams XFTPVersion 'TServer)
xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
xftpServer :: XFTPServerConfig -> TMVar Bool -> Maybe [ALPN] -> M ()
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started alpn_ = do
mapM_ (expireServerFiles Nothing) fileExpiration
restoreServerStats
raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
where
runServer :: M ()
runServer = do
serverParams <- asks tlsServerParams
let (chain, pk) = tlsServerCredentials serverParams
srvCreds@(chain, pk) <- asks tlsServerCreds
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 serverParams transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize defaultSupportedParams srvCreds alpn_ transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
reqBody <- getHTTP2Body r xftpBlockSize
let v = VersionXFTP 1
thServerVRange = versionToRange v
+7 -10
View File
@@ -29,7 +29,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (ALPN)
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential)
import Simplex.Messaging.Util (tshow)
import System.IO (IOMode (..))
import UnliftIO.STM
@@ -57,10 +57,7 @@ data XFTPServerConfig = XFTPServerConfig
fileTimeout :: Int,
-- | time after which inactive clients can be disconnected and check interval, seconds
inactiveClientExpiration :: Maybe ExpirationConfig,
-- CA certificate private key is not needed for initialization
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
xftpCredentials :: ServerCredentials,
-- | XFTP client-server protocol version range
xftpServerVRange :: VersionRangeXFTP,
-- stats config - see SMP server config
@@ -85,7 +82,7 @@ data XFTPEnv = XFTPEnv
storeLog :: Maybe (StoreLog 'WriteMode),
random :: TVar ChaChaDRG,
serverIdentity :: C.KeyHash,
tlsServerParams :: T.ServerParams,
tlsServerCreds :: T.Credential,
serverStats :: FileServerStats
}
@@ -103,7 +100,7 @@ supportedXFTPhandshakes :: [ALPN]
supportedXFTPhandshakes = ["xftp/1"]
newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, xftpCredentials} = do
random <- C.newRandom
store <- newFileStore
storeLog <- mapM (`readWriteFileStore` store) storeLogFile
@@ -112,10 +109,10 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
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!"
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
Fingerprint fp <- loadFingerprint caCertificateFile
tlsServerCreds <- loadServerCredential xftpCredentials
Fingerprint fp <- loadFingerprint xftpCredentials
serverStats <- newFileServerStats =<< getCurrentTime
pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
pure XFTPEnv {config, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
countUsedStorage :: M.Map k FileRec -> Int64
countUsedStorage = M.foldl' (\acc FileRec {fileInfo = FileInfo {size}} -> acc + fromIntegral size) 0
+9 -7
View File
@@ -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, supportedXFTPhandshakes)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration)
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 (TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (combine)
@@ -173,9 +173,12 @@ xftpServerCLI cfgPath logPath = do
{ ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini,
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
},
caCertificateFile = c caCrtFile,
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile,
xftpCredentials =
ServerCredentials
{ caCertificateFile = Just $ c caCrtFile,
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile
},
xftpServerVRange = supportedFileServerVRange,
logStatsInterval = logStats $> 86400, -- seconds
logStatsStartTime = 0, -- seconds from 00:00 UTC
@@ -183,8 +186,7 @@ xftpServerCLI cfgPath logPath = do
serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
alpn = Just supportedXFTPhandshakes
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
},
responseDelay = 0
}
+1
View File
@@ -54,6 +54,7 @@ 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
@@ -44,6 +44,7 @@ data FileStoreLogRecord
| AddRecipients SenderId (NonEmpty FileRecipient)
| DeleteFile SenderId
| AckFile RecipientId
deriving (Show)
instance StrEncoding FileStoreLogRecord where
strEncode = \case
+4 -21
View File
@@ -1906,12 +1906,8 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
-- possible improvement: get updated token status from the server, or maybe TCRON could return the current status
pure ntfTknStatus
| otherwise -> replaceToken tknId
(Just tknId, Just NTADelete) -> do
agentNtfDeleteToken c tknId tkn
withStore' c (`removeNtfToken` tkn)
ns <- asks ntfSupervisor
atomically $ nsRemoveNtfToken ns
pure NTExpired
-- deprecated
(Just _tknId, Just NTADelete) -> deleteToken c tkn $> NTExpired
_ -> pure ntfTknStatus
withStore' c $ \db -> updateNtfMode db tkn suppliedNtfMode
pure status
@@ -1985,7 +1981,7 @@ deleteNtfToken' c deviceToken =
withStore' c getSavedNtfToken >>= \case
Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do
when (deviceToken /= savedDeviceToken) $ logWarn "deleteNtfToken: different token"
deleteToken_ c tkn
deleteToken c tkn
deleteNtfSubs c NSCSmpDelete
_ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"
@@ -2020,20 +2016,6 @@ toggleConnectionNtfs' c connId enable = do
let cmd = if enable then NSCCreate else NSCSmpDelete
atomically $ sendNtfSubCommand ns (cmd, [connId])
deleteToken_ :: AgentClient -> NtfToken -> AM ()
deleteToken_ c@AgentClient {subQ} 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` \e -> notify (ERR e) -- TODO cleanup task
withStore' c $ \db -> removeNtfToken db tkn
atomically $ nsRemoveNtfToken ns
where
notify :: forall e. AEntityI e => AEvent e -> AM ()
notify cmd = atomically $ writeTBQueue subQ ("", "", AEvt (sAEntity @e) cmd)
withToken :: AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
ns <- asks ntfSupervisor
@@ -2164,6 +2146,7 @@ cleanupManager c@AgentClient {subQ} = do
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
+37 -5
View File
@@ -70,7 +70,9 @@ module Simplex.Messaging.Agent.Client
agentNtfDeleteToken,
agentNtfEnableCron,
agentNtfCreateSubscription,
agentNtfCreateSubscriptions,
agentNtfCheckSubscription,
agentNtfCheckSubscriptions,
agentNtfDeleteSubscription,
agentXFTPDownloadChunk,
agentXFTPNewChunk,
@@ -153,6 +155,7 @@ module Simplex.Messaging.Agent.Client
incXFTPServerStat',
incXFTPServerSizeStat,
incNtfServerStat,
incNtfServerStat',
AgentWorkersDetails (..),
getAgentWorkersDetails,
AgentWorkersSummary (..),
@@ -1718,8 +1721,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 -> NtfTokenId -> NtfToken -> AM ()
agentNtfDeleteToken c tknId NtfToken {ntfServer, ntfPrivKey} =
agentNtfDeleteToken :: AgentClient -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM ()
agentNtfDeleteToken c ntfServer ntfPrivKey tknId =
withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
agentNtfEnableCron :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM ()
@@ -1730,10 +1733,34 @@ 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)
agentNtfCheckSubscription :: AgentClient -> NtfSubscriptionId -> NtfToken -> AM NtfSubStatus
agentNtfCheckSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
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 =
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
@@ -1841,6 +1868,7 @@ withWork c doWork getWork action =
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
@@ -2058,9 +2086,13 @@ incXFTPServerStat_ = incServerStat (\AgentClient {xftpServersStats = s} -> s) ne
{-# INLINE incXFTPServerStat_ #-}
incNtfServerStat :: AgentClient -> UserId -> NtfServer -> (AgentNtfServerStats -> TVar Int) -> STM ()
incNtfServerStat c userId srv sel = incServerStat (\AgentClient {ntfServersStats = s} -> s) newAgentNtfServerStats c userId srv sel 1
incNtfServerStat c userId srv sel = incNtfServerStat' 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
+11 -8
View File
@@ -74,8 +74,7 @@ import Simplex.Messaging.Parsers (defaultJSON)
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, TLS, Transport (..))
import Simplex.Messaging.Transport.Client (defaultSMPPort)
import Simplex.Messaging.Transport (SMPVersion)
import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors')
import System.Mem.Weak (Weak)
import System.Random (StdGen, newStdGen)
@@ -151,6 +150,7 @@ data AgentConfig = AgentConfig
deleteErrorCount :: Int,
ntfCron :: Word16,
ntfBatchSize :: Int,
ntfSubFirstCheckInterval :: NominalDiffTime,
ntfSubCheckInterval :: NominalDiffTime,
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
@@ -195,8 +195,8 @@ defaultAgentConfig =
sndAuthAlg = C.AuthAlg C.SEd25519, -- TODO replace with X25519 when switching to v7
connIdBytes = 12,
tbqSize = 128,
smpCfg = defaultSMPClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
ntfCfg = defaultNTFClientConfig {defaultTransport = ("443", transport @TLS)},
smpCfg = defaultSMPClientConfig,
ntfCfg = defaultNTFClientConfig,
xftpCfg = defaultXFTPClientConfig,
reconnectInterval = defaultReconnectInterval,
messageRetryInterval = defaultMessageRetryInterval,
@@ -220,8 +220,9 @@ defaultAgentConfig =
xftpMaxRecipientsPerRequest = 200,
deleteErrorCount = 10,
ntfCron = 20, -- minutes
ntfBatchSize = 200,
ntfSubCheckInterval = nominalDay,
ntfBatchSize = 150,
ntfSubFirstCheckInterval = nominalDay,
ntfSubCheckInterval = 3 * nominalDay,
-- CA certificate private key is not needed for initialization
-- ! we do not generate these
caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
@@ -258,7 +259,8 @@ data NtfSupervisor = NtfSupervisor
{ ntfTkn :: TVar (Maybe NtfToken),
ntfSubQ :: TBQueue (NtfSupervisorCommand, NonEmpty ConnId),
ntfWorkers :: TMap NtfServer Worker,
ntfSMPWorkers :: TMap SMPServer Worker
ntfSMPWorkers :: TMap SMPServer Worker,
ntfTknDelWorkers :: TMap NtfServer Worker
}
data NtfSupervisorCommand = NSCCreate | NSCSmpDelete | NSCDeleteSub
@@ -270,7 +272,8 @@ newNtfSubSupervisor qSize = do
ntfSubQ <- newTBQueueIO qSize
ntfWorkers <- TM.emptyIO
ntfSMPWorkers <- TM.emptyIO
pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
ntfTknDelWorkers <- TM.emptyIO
pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers, ntfTknDelWorkers}
data XFTPAgent = XFTPAgent
{ -- if set, XFTP file paths will be considered as relative to this directory
+255 -121
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
@@ -14,6 +15,7 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
nsRemoveNtfToken,
sendNtfSubCommand,
instantNotifications,
deleteToken,
closeNtfSupervisor,
getNtfServer,
)
@@ -25,13 +27,14 @@ import Control.Monad.Reader
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (first)
import Data.Either (partitionEithers)
import Data.Foldable (foldr')
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
@@ -43,11 +46,11 @@ 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 (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
import Simplex.Messaging.Notifications.Protocol
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, unlessM)
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow)
import System.Random (randomR)
import UnliftIO
import UnliftIO.Concurrent (forkIO)
@@ -56,6 +59,9 @@ 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 $
@@ -63,6 +69,10 @@ runNtfSupervisor c = do
Left e -> notifyErr 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
logError $ "runNtfSupervisor error " <> tshow e
@@ -134,7 +144,7 @@ processNtfCmd c (cmd, connIds) = do
[SMPServer], -- continue work (SMP)
[NtfServer] -- continue work (Ntf)
)
partitionQueueSubActions = foldr' decideSubWork ([], [], [], [])
partitionQueueSubActions = foldr decideSubWork ([], [], [], [])
where
-- sub = Nothing, needs to be created
decideSubWork (rq, Nothing) (ns, rs, css, cns) = (rq : ns, rs, css, cns)
@@ -188,6 +198,11 @@ 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)
@@ -198,82 +213,167 @@ runNtfWorker c srv Worker {doWork} =
ExceptT $ agentOperationBracket c AONtfNetwork throwWhenInactive $ runExceptT runNtfOperation
where
runNtfOperation :: AM ()
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
lift . void $ getNtfSMPWorker True c 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 and NSARotate are deprecated, but their processing is kept for legacy db records
NSADelete ->
deleteNtfSub $ do
let sub' = sub {ntfSubId = Nothing, ntfSubStatus = NASOff}
withStore' c $ \db -> updateNtfSubscription db sub' (NSASMP NSASmpDelete) ts
lift . void $ getNtfSMPWorker True c smpServer
NSARotate ->
deleteNtfSub $ do
withStore' c $ \db -> deleteNtfSubscription db connId
ns <- asks ntfSupervisor
atomically $ writeTBQueue (ntfSubQ ns) (NSCCreate, [connId]) -- TODO [batch ntf] loop
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 ([], [], [], [])
where
-- deleteNtfSub is only used in NSADelete and NSARotate, so also deprecated
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
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
atomically $ incNtfServerStat c userId ntfServer ntfDeleted
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'
continue'
Left e
| temporaryOrHostError e -> pure $ Just sub -- don't continue, retry
| otherwise -> continue'
Nothing -> continue'
_ -> continue'
where
continue' = continue $> Nothing -- continue without retry
runNtfSMPWorker :: AgentClient -> SMPServer -> Worker -> AM ()
runNtfSMPWorker c srv Worker {doWork} = forever $ do
@@ -286,26 +386,14 @@ runNtfSMPWorker c srv Worker {doWork} = forever $ do
withWorkItems c doWork (\db -> getNextNtfSubSMPActions db srv ntfBatchSize) $ \nextSubs -> do
logInfo $ "runNtfSMPWorker - length nextSubs = " <> tshow (length nextSubs)
let (creates, deletes) = splitActions nextSubs
retrySubActions creates createNotifierKeys
retrySubActions deletes deleteNotifierKeys
retrySubActions c creates createNotifierKeys
retrySubActions c deletes deleteNotifierKeys
splitActions :: NonEmpty (NtfSubSMPAction, NtfSubscription) -> ([NtfSubscription], [NtfSubscription])
splitActions = foldr addAction ([], [])
where
addAction action (creates, deletes) = case action of
(NSASmpKey, sub) -> (sub : creates, deletes)
(NSASmpDelete, sub) -> (creates, sub : deletes)
retrySubActions :: [NtfSubscription] -> ([NtfSubscription] -> AM' [NtfSubscription]) -> AM ()
retrySubActions 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
addAction (cmd, sub) (creates, deletes) = case cmd of
NSASmpKey -> (sub : creates, deletes)
NSASmpDelete -> (creates, sub : deletes)
createNotifierKeys :: [NtfSubscription] -> AM' [NtfSubscription]
createNotifierKeys ntfSubs =
getNtfToken >>= \case
@@ -363,32 +451,37 @@ runNtfSMPWorker c srv Worker {doWork} = forever $ do
pure (sub, rq)
deleteSub :: DB.Connection -> RcvQueue -> IO ()
deleteSub db rq = deleteNtfSubscription db (qConnId rq)
-- (temporary errs, other errs, successes)
splitResults :: [(a, Either AgentErrorType r)] -> ([a], [(a, AgentErrorType)], [(a, r)])
splitResults = foldr' addRes ([], [], [])
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)
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
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
retryOnError :: AgentClient -> Text -> AM () -> (AgentErrorType -> AM ()) -> AgentErrorType -> AM ()
retryOnError c name loop done e = do
logError $ name <> " error: " <> tshow e
if temporaryOrHostError e
then retryNetworkLoop c loop
else done e
-- (temporary errs, other errs, successes)
splitResults :: [(a, Either AgentErrorType r)] -> ([a], [(a, AgentErrorType)], [(a, r)])
splitResults = foldr addRes ([], [], [])
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
@@ -442,10 +535,51 @@ 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)
+83 -12
View File
@@ -150,6 +150,13 @@ module Simplex.Messaging.Agent.Store.SQLite
updateNtfMode,
updateNtfToken,
removeNtfToken,
addNtfTokenToDelete,
deleteExpiredNtfTokensToDelete,
NtfTokenToDelete,
getNextNtfTokenToDelete,
markNtfTokenToDeleteFailed_, -- exported for tests
getPendingDelTknServers,
deleteNtfTokenToDelete,
-- Notification subscription persistence
NtfSupervisorSub,
getNtfSubscription,
@@ -160,7 +167,7 @@ module Simplex.Messaging.Agent.Store.SQLite
setNullNtfSubscriptionAction,
deleteNtfSubscription,
deleteNtfSubscription',
getNextNtfSubNTFAction,
getNextNtfSubNTFActions,
markNtfSubActionNtfFailed_, -- exported for tests
getNextNtfSubSMPActions,
markNtfSubActionSMPFailed_, -- exported for tests
@@ -1486,6 +1493,70 @@ 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)
@@ -1627,14 +1698,14 @@ deleteNtfSubscription' :: DB.Connection -> ConnId -> IO ()
deleteNtfSubscription' db connId = do
DB.execute db "DELETE FROM ntf_subscriptions WHERE conn_id = ?" (Only connId)
getNextNtfSubNTFAction :: DB.Connection -> NtfServer -> IO (Either StoreError (Maybe (NtfSubscription, NtfSubNTFAction, NtfActionTs)))
getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
getWorkItem "ntf NTF" getNtfConnId getNtfSubAction (markNtfSubActionNtfFailed_ db)
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)
where
getNtfConnId :: IO (Maybe ConnId)
getNtfConnId =
maybeFirstRow fromOnly $
DB.query
getNtfConnIds :: IO [ConnId]
getNtfConnIds =
map fromOnly
<$> DB.query
db
[sql|
SELECT conn_id
@@ -1642,10 +1713,10 @@ getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
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 1
LIMIT ?
|]
(ntfHost, ntfPort)
getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubscription, NtfSubNTFAction, NtfActionTs))
(ntfHost, ntfPort, ntfBatchSize)
getNtfSubAction :: ConnId -> IO (Either StoreError (NtfSubNTFAction, NtfSubscription, NtfActionTs))
getNtfSubAction connId = do
markUpdatedByWorker db connId
firstRow ntfSubAction err $
@@ -1665,7 +1736,7 @@ getNextNtfSubNTFAction db ntfServer@(NtfServer ntfHost ntfPort _) =
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 (ntfSubscription, action, actionTs)
in (action, ntfSubscription, actionTs)
markNtfSubActionNtfFailed_ :: DB.Connection -> ConnId -> IO ()
markNtfSubActionNtfFailed_ db connId =
@@ -74,6 +74,7 @@ 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.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Transport.Client (TransportHost)
@@ -116,7 +117,8 @@ 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)
("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)
]
-- | The list of migrations in ascending order by date
@@ -0,0 +1,27 @@
{-# 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;
|]
@@ -403,6 +403,16 @@ 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);
+25 -13
View File
@@ -63,11 +63,13 @@ module Simplex.Messaging.Client
forwardSMPTransmission,
getSMPQueueInfo,
sendProtocolCommand,
sendProtocolCommands,
-- * Supporting types and client configuration
ProtocolClientError (..),
SMPClientError,
ProxyClientError (..),
Response (..),
unexpectedResponse,
ProtocolClientConfig (..),
NetworkConfig (..),
@@ -141,7 +143,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 (..), defaultTcpConnectTimeout, runTransportClient)
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, 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)
@@ -281,6 +283,8 @@ 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)
@@ -352,6 +356,7 @@ defaultNetworkConfig =
sessionMode = TSMSession,
smpProxyMode = SPMNever,
smpProxyFallback = SPFAllow,
smpWebPort = False,
tcpConnectTimeout = defaultTcpConnectTimeout,
tcpTimeout = 15_000_000,
tcpTimeoutPerKb = 5_000,
@@ -362,9 +367,9 @@ defaultNetworkConfig =
logTLSErrors = False
}
transportClientConfig :: NetworkConfig -> TransportHost -> TransportClientConfig
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host =
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
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}
where
socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
useSocksProxy SMAlways = socksProxy'
@@ -400,24 +405,29 @@ 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
agreeSecret :: Bool,
-- | send SNI to server, False for SMP
useSNI :: Bool
}
-- | Default protocol client configuration.
defaultClientConfig :: Maybe [ALPN] -> VersionRange v -> ProtocolClientConfig v
defaultClientConfig clientALPN serverVRange =
defaultClientConfig :: Maybe [ALPN] -> Bool -> VersionRange v -> ProtocolClientConfig v
defaultClientConfig clientALPN useSNI serverVRange =
ProtocolClientConfig
{ qSize = 64,
defaultTransport = ("443", transport @TLS),
networkConfig = defaultNetworkConfig,
clientALPN,
serverVRange,
agreeSecret = False
agreeSecret = False,
useSNI
}
{-# INLINE defaultClientConfig #-}
defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
defaultSMPClientConfig = defaultClientConfig (Just supportedSMPHandshakes) supportedClientSMPRelayVRange
defaultSMPClientConfig =
(defaultClientConfig (Just supportedSMPHandshakes) False supportedClientSMPRelayVRange)
{defaultTransport = (show defaultSMPPort, transport @TLS)}
{-# INLINE defaultSMPClientConfig #-}
data Request err msg = Request
@@ -477,14 +487,14 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
-- 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} msgQ proxySessTs disconnected = do
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret, useSNI} msgQ proxySessTs 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 {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
NetworkConfig {smpWebPort, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
mkProtocolClient transportHost ts = do
connected <- newTVarIO False
@@ -515,7 +525,7 @@ 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) {alpn = clientALPN}
let tcConfig = (transportClientConfig networkConfig useHost useSNI) {alpn = clientALPN}
socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
tId <-
runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
@@ -528,7 +538,9 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
useTransport :: (ServiceName, ATransport)
useTransport = case port srv of
"" -> defaultTransport cfg
"" -> case protocolTypeI @(ProtoType msg) of
SPSMP | smpWebPort -> ("443", transport @TLS)
_ -> defaultTransport cfg
"80" -> ("80", transport @WS)
p -> (p, transport @TLS)
+1 -1
View File
@@ -76,7 +76,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
defaultSMPClientAgentConfig :: SMPClientAgentConfig
defaultSMPClientAgentConfig =
SMPClientAgentConfig
{ smpCfg = defaultSMPClientConfig {defaultTransport = ("5223", transport @TLS)},
{ smpCfg = defaultSMPClientConfig,
reconnectInterval =
RetryInterval
{ initialInterval = second,
+26 -1
View File
@@ -2,24 +2,31 @@
{-# 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 (..))
type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse
type NtfClientError = ProtocolClientError ErrorType
defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) supportedClientNTFVRange
defaultNTFClientConfig =
(defaultClientConfig (Just supportedNTFHandshakes) True supportedClientNTFVRange)
{defaultTransport = ("443", transport @TLS)}
{-# INLINE defaultNTFClientConfig #-}
ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
ntfRegisterToken c pKey newTkn =
@@ -51,12 +58,30 @@ ntfCreateSubscription c pKey newSub =
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
+26 -24
View File
@@ -19,6 +19,7 @@ import Control.Monad.Except
import Control.Monad.Reader
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (partitionEithers)
import Data.Functor (($>))
import Data.IORef
import Data.Int (Int64)
@@ -50,8 +51,8 @@ import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server
import Simplex.Messaging.Server.Stats
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..))
import Simplex.Messaging.Transport.Server (runTransportServer, tlsServerCredentials)
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer)
import Simplex.Messaging.Util
import System.Exit (exitFailure)
import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
@@ -80,12 +81,12 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
resubscribe s
raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports <> serverStatsThread_ cfg) `finally` stopServer
where
runServer :: (ServiceName, ATransport) -> M ()
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams
runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
runServer (tcpPort, ATransport t, _addHTTP) = do
srvCreds <- asks tlsServerCreds
serverSignKey <- either fail pure $ fromTLSCredentials srvCreds
env <- ask
liftIO $ runTransportServer started tcpPort serverParams tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds (Just supportedNTFHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
@@ -354,28 +355,29 @@ 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 <- 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)
ts <- L.toList <$> liftIO (tGet th)
atomically . (writeTVar rcvActiveAt $!) =<< liftIO getSystemTime
(errs, cmds) <- partitionEithers <$> mapM cmdAction ts
write sndQ errs
write rcvQ cmds
where
write q t = atomically $ writeTBQueue q t
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
send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO ()
send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
t <- atomically $ readTBQueue sndQ
void . liftIO $ tPut h [Right (Nothing, encodeTransmission params t)]
ts <- atomically $ readTBQueue sndQ
void . liftIO $ tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts
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
@@ -433,7 +435,7 @@ client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M ()
client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} =
forever $
atomically (readTBQueue rcvQ)
>>= processCommand
>>= mapM processCommand
>>= atomically . writeTBQueue sndQ
where
processCommand :: NtfRequest -> M (Transmission NtfResponse)
@@ -33,13 +33,13 @@ 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 (TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
data NtfServerConfig = NtfServerConfig
{ transports :: [(ServiceName, ATransport)],
{ transports :: [(ServiceName, ATransport, AddHTTP)],
subIdBytes :: Int,
regCodeBytes :: Int,
clientQSize :: Natural,
@@ -50,10 +50,7 @@ data NtfServerConfig = NtfServerConfig
subsBatchSize :: Int,
inactiveClientExpiration :: Maybe ExpirationConfig,
storeLogFile :: Maybe FilePath,
-- CA certificate private key is not needed for initialization
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
ntfCredentials :: ServerCredentials,
-- stats config - see SMP server config
logStatsInterval :: Maybe Int64,
logStatsStartTime :: Int64,
@@ -77,13 +74,13 @@ data NtfEnv = NtfEnv
store :: NtfStore,
storeLog :: Maybe (StoreLog 'WriteMode),
random :: TVar ChaChaDRG,
tlsServerParams :: T.ServerParams,
tlsServerCreds :: T.Credential,
serverIdentity :: C.KeyHash,
serverStats :: NtfServerStats
}
newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, ntfCredentials} = do
random <- C.newRandom
store <- newNtfStore
logInfo "restoring subscriptions..."
@@ -91,10 +88,10 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
logInfo "restored subscriptions"
subscriber <- newNtfSubscriber subQSize smpAgentCfg random
pushServer <- newNtfPushServer pushQSize apnsConfig
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
Fingerprint fp <- loadFingerprint caCertificateFile
tlsServerCreds <- loadServerCredential ntfCredentials
Fingerprint fp <- loadFingerprint ntfCredentials
serverStats <- newNtfServerStats =<< getCurrentTime
pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
data NtfSubscriber = NtfSubscriber
{ smpSubscribers :: TMap SMPServer SMPSubscriber,
@@ -158,8 +155,8 @@ data NtfRequest
| NtfReqPing CorrId NtfEntityId
data NtfServerClient = NtfServerClient
{ rcvQ :: TBQueue NtfRequest,
sndQ :: TBQueue (Transmission NtfResponse),
{ rcvQ :: TBQueue (NonEmpty NtfRequest),
sndQ :: TBQueue (NonEmpty (Transmission NtfResponse)),
ntfThParams :: THandleParams NTFVersion 'TServer,
connected :: TVar Bool,
rcvActiveAt :: TVar SystemTime,
@@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Messaging.Notifications.Server.Main where
@@ -22,13 +23,13 @@ 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 (supportedNTFHandshakes, supportedServerNTFVRange)
import Simplex.Messaging.Notifications.Transport (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 (TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Util (tshow)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (combine)
@@ -156,9 +157,12 @@ ntfServerCLI cfgPath logPath =
checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini
},
storeLogFile = enableStoreLog $> storeLogFilePath,
caCertificateFile = c caCrtFile,
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile,
ntfCredentials =
ServerCredentials
{ caCertificateFile = Just $ 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",
@@ -166,8 +170,7 @@ ntfServerCLI cfgPath logPath =
ntfServerVRange = supportedServerNTFVRange,
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
alpn = Just supportedNTFHandshakes
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
}
}
@@ -50,6 +50,7 @@ data NtfStoreLogRecord
| CreateSubscription NtfSubRec
| SubscriptionStatus NtfSubscriptionId NtfSubStatus
| DeleteSubscription NtfSubscriptionId
deriving (Show)
data NtfTknRec = NtfTknRec
{ ntfTknId :: NtfTokenId,
@@ -61,6 +62,7 @@ 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
@@ -81,6 +83,7 @@ data NtfSubRec = NtfSubRec
tokenId :: NtfTokenId,
subStatus :: NtfSubStatus
}
deriving (Show)
mkSubData :: NtfSubRec -> STM NtfSubData
mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
+110 -67
View File
@@ -34,6 +34,7 @@ module Simplex.Messaging.Server
verifyCmdAuthorization,
dummyVerifyCmd,
randomId,
AttachHTTP,
)
where
@@ -68,10 +69,12 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.Type.Equality
import Data.Typeable (cast)
import GHC.IORef (atomicSwapIORef)
import GHC.Stats (getRTSStats)
import GHC.TypeLits (KnownNat)
import Network.Socket (ServiceName, Socket, socketToHandle)
import qualified Network.TLS as TLS
import Numeric.Natural (Natural)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPTransmission, smpProxyError, temporaryClientError)
@@ -115,44 +118,56 @@ import GHC.Conc.Sync (threadLabel)
-- | Runs an SMP server using passed configuration.
--
-- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs
runSMPServer :: ServerConfig -> IO ()
runSMPServer cfg = do
runSMPServer :: ServerConfig -> Maybe AttachHTTP -> IO ()
runSMPServer cfg attachHTTP_ = do
started <- newEmptyTMVarIO
runSMPServerBlocking started cfg
runSMPServerBlocking started cfg attachHTTP_
-- | Runs an SMP server using passed configuration with signalling.
--
-- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
-- and when it is disconnected from the TCP socket once the server thread is killed (False).
runSMPServerBlocking :: TMVar Bool -> ServerConfig -> IO ()
runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started cfg)
runSMPServerBlocking :: TMVar Bool -> ServerConfig -> Maybe AttachHTTP -> IO ()
runSMPServerBlocking started cfg attachHTTP_ = newEnv cfg >>= runReaderT (smpServer started cfg attachHTTP_)
type M a = ReaderT Env IO a
type AttachHTTP = Socket -> TLS.Context -> IO ()
smpServer :: TMVar Bool -> ServerConfig -> M ()
smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
smpServer :: TMVar Bool -> ServerConfig -> Maybe AttachHTTP -> M ()
smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} attachHTTP_ = do
s <- asks server
pa <- asks proxyAgent
expired <- restoreServerMessages
restoreServerStats expired
raceAny_
( serverThread s "server subscribedQ" True subscribedQ subscribers pendingENDs subscriptions cancelSub
: serverThread s "server deletedQ" False deletedQ subscribers pendingDELDs subscriptions cancelSub
: serverThread s "server ntfSubscribedQ" True ntfSubscribedQ Env.notifiers pendingNtfENDs ntfSubscriptions (\_ -> pure ())
: serverThread s "server ntfDeletedQ" False ntfDeletedQ Env.notifiers pendingNtfDELDs ntfSubscriptions (\_ -> pure ())
( serverThread s "server subscribedQ" subscribedQ subscribers subClients pendingSubEvents subscriptions cancelSub
: serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubClients pendingNtfSubEvents ntfSubscriptions (\_ -> pure ())
: sendPendingEvtsThread s
: receiveFromProxyAgent pa
: map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
)
`finally` withLock' (savingLock s) "final" (saveServer False >> closeServer)
where
runServer :: (ServiceName, ATransport) -> M ()
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
runServer (tcpPort, ATransport t, addHTTP) = do
smpCreds <- asks tlsServerCreds
httpCreds_ <- asks httpServerCreds
ss <- asks sockets
serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams
serverSignKey <- either fail pure $ fromTLSCredentials smpCreds
env <- ask
liftIO $ runTransportServerState ss started tcpPort serverParams tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
liftIO $ case (httpCreds_, attachHTTP_) of
(Just httpCreds, Just attachHTTP) | addHTTP ->
runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS chooseCreds (Just combinedALPNs) tCfg $ \s h ->
case cast h of
Just TLS {tlsContext} | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext
_ -> runClient serverSignKey t h `runReaderT` env
where
chooseCreds = maybe smpCreds (\_host -> httpCreds)
combinedALPNs = supportedSMPHandshakes <> httpALPN
httpALPN :: [ALPN]
httpALPN = ["h2", "http/1.1"]
_ ->
runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
saveServer :: Bool -> M ()
@@ -165,14 +180,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
forall s.
Server ->
String ->
Subscribed ->
(Server -> TQueue (QueueId, ClientId)) ->
(Server -> TQueue (QueueId, ClientId, Subscribed)) ->
(Server -> TMap QueueId (TVar Client)) ->
(Server -> TVar (IM.IntMap (NonEmpty RecipientId))) ->
(Server -> TVar (IM.IntMap Client)) ->
(Server -> TVar (IM.IntMap (NonEmpty (QueueId, Subscribed)))) ->
(Client -> TMap QueueId s) ->
(s -> IO ()) ->
M ()
serverThread s label subscribed subQ subs pendingEvts clientSubs unsub = do
serverThread s label subQ subs subClnts pendingEvts clientSubs unsub = do
labelMyThread label
cls <- asks clients
liftIO . forever $
@@ -180,32 +195,40 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
$>>= endPreviousSubscriptions
>>= mapM_ unsub
where
updateSubscribers :: TVar (IM.IntMap (Maybe Client)) -> (QueueId, ClientId) -> STM (Maybe (QueueId, Client))
updateSubscribers cls (qId, clntId) =
updateSubscribers :: TVar (IM.IntMap (Maybe Client)) -> (QueueId, ClientId, Subscribed) -> STM (Maybe ((QueueId, Subscribed), Client))
updateSubscribers cls (qId, clntId, subscribed) =
-- Client lookup by ID is in the same STM transaction.
-- In case client disconnects during the transaction,
-- it will be re-evaluated, and the client won't be stored as subscribed.
(readTVar cls >>= updateSub (subs s) . IM.lookup clntId)
(readTVar cls >>= updateSub . IM.lookup clntId)
$>>= clientToBeNotified
where
updateSub ss = \case
ss = subs s
updateSub = \case
Just (Just clnt)
| subscribed ->
| subscribed -> do
modifyTVar' (subClnts s) $ IM.insert clntId clnt -- add client to server's subscribed cients
TM.lookup qId ss >>= -- insert subscribed and current client
maybe
(newTVar clnt >>= \cv -> TM.insert qId cv ss $> Nothing)
(\cv -> Just <$> swapTVar cv clnt)
| otherwise -> TM.lookupDelete qId ss >>= mapM readTVar
| otherwise -> do
removeWhenNoSubs clnt
TM.lookupDelete qId ss >>= mapM readTVar
-- This case catches Just Nothing - it cannot happen here.
-- Nothing is there only before client thread is started.
_ -> TM.lookup qId ss >>= mapM readTVar -- do not insert client if it is already disconnected, but send END to any other client
clientToBeNotified c'
| clntId == clientId c' = pure Nothing
| otherwise = (\yes -> if yes then Just (qId, c') else Nothing) <$> readTVar (connected c')
endPreviousSubscriptions :: (QueueId, Client) -> IO (Maybe s)
endPreviousSubscriptions (qId, c) = do
atomically $ modifyTVar' (pendingEvts s) $ IM.alter (Just . maybe [qId] (qId <|)) (clientId c)
atomically $ TM.lookupDelete qId (clientSubs c)
| otherwise = (\yes -> if yes then Just ((qId, subscribed), c') else Nothing) <$> readTVar (connected c')
endPreviousSubscriptions :: ((QueueId, Subscribed), Client) -> IO (Maybe s)
endPreviousSubscriptions (qEvt@(qId, _), c) = do
atomically $ modifyTVar' (pendingEvts s) $ IM.alter (Just . maybe [qEvt] (qEvt <|)) (clientId c)
atomically $ do
sub <- TM.lookupDelete qId (clientSubs c)
removeWhenNoSubs c $> sub
-- remove client from server's subscribed cients
removeWhenNoSubs c = whenM (null <$> readTVar (clientSubs c)) $ modifyTVar' (subClnts s) $ IM.delete (clientId c)
sendPendingEvtsThread :: Server -> M ()
sendPendingEvtsThread s = do
@@ -213,16 +236,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
cls <- asks clients
forever $ do
threadDelay endInt
sendPending cls END $ pendingENDs s
sendPending cls DELD $ pendingDELDs s
sendPending cls END $ pendingNtfENDs s
sendPending cls DELD $ pendingNtfDELDs s
sendPending cls $ pendingSubEvents s
sendPending cls $ pendingNtfSubEvents s
where
sendPending cls evt ref = do
sendPending cls ref = do
ends <- atomically $ swapTVar ref IM.empty
unless (null ends) $ forM_ (IM.assocs ends) $ \(cId, qIds) ->
mapM_ (queueEvts qIds evt) . join . IM.lookup cId =<< readTVarIO cls
queueEvts qIds evt c@Client {connected, sndQ = q} =
unless (null ends) $ forM_ (IM.assocs ends) $ \(cId, qEvts) ->
mapM_ (queueEvts qEvts) . join . IM.lookup cId =<< readTVarIO cls
queueEvts qEvts c@Client {connected, sndQ = q} =
whenM (readTVarIO connected) $ do
sent <- atomically $ ifM (isFullTBQueue q) (pure False) (writeTBQueue q ts $> True)
if sent
@@ -231,14 +252,15 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
forkClient c ("sendPendingEvtsThread.queueEvts") $
atomically (writeTBQueue q ts) >> updateEndStats
where
ts = L.map (CorrId "",,evt) qIds
updateEndStats = case evt of
END -> do
stats <- asks serverStats
let len = L.length qIds
liftIO $ atomicModifyIORef'_ (qSubEnd stats) (+ len)
liftIO $ atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs in the batch
_ -> pure ()
ts = L.map (\(qId, subscribed) -> (CorrId "", qId, evt subscribed)) qEvts
evt True = END
evt False = DELD
-- this accounts for both END and DELD events
updateEndStats = do
stats <- asks serverStats
let len = L.length qEvts
liftIO $ atomicModifyIORef'_ (qSubEnd stats) (+ len)
liftIO $ atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs or DELDs in the batch
receiveFromProxyAgent :: ProxyAgent -> M ()
receiveFromProxyAgent ProxyAgent {smpAgent = SMPClientAgent {agentQ}} =
@@ -253,16 +275,16 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
showServer' = decodeLatin1 . strEncode . host
expireMessagesThread_ :: ServerConfig -> [M ()]
expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessages msgExp]
expireMessagesThread_ ServerConfig {messageExpiration = Just msgExp} = [expireMessagesThread msgExp]
expireMessagesThread_ _ = []
expireMessages :: ExpirationConfig -> M ()
expireMessages expCfg = do
expireMessagesThread :: ExpirationConfig -> M ()
expireMessagesThread expCfg = do
ms <- asks msgStore
quota <- asks $ msgQueueQuota . config
let interval = checkInterval expCfg * 1000000
stats <- asks serverStats
labelMyThread "expireMessages"
labelMyThread "expireMessagesThread"
forever $ do
liftIO $ threadDelay' interval
old <- liftIO $ expireBeforeEpoch expCfg
@@ -564,7 +586,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
#else
hPutStrLn h "Threads: not available on GHC 8.10"
#endif
Env {clients, server = Server {subscribers, notifiers}} <- unliftIO u ask
Env {clients, server = Server {subscribers, notifiers, subClients, ntfSubClients}} <- unliftIO u ask
activeClients <- readTVarIO clients
hPutStrLn h $ "Clients: " <> show (IM.size activeClients)
when (r == CPRAdmin) $ do
@@ -581,6 +603,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
hPutStrLn h $ "Ntf subscribed clients queues (via clients, rcvQ, sndQ, msgQ): " <> show ntfClQs
putActiveClientsInfo "SMP" subscribers
putActiveClientsInfo "Ntf" notifiers
putSubscribedClients "SMP" subClients
putSubscribedClients "Ntf" ntfSubClients
where
putActiveClientsInfo :: String -> TMap QueueId (TVar Client) -> IO ()
putActiveClientsInfo protoName clients = do
@@ -591,6 +615,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
where
countSubClients :: M.Map QueueId (TVar Client) -> IO IS.IntSet
countSubClients = foldM (\ !s c -> (`IS.insert` s) . clientId <$> readTVarIO c) IS.empty
putSubscribedClients :: String -> TVar (IM.IntMap Client) -> IO ()
putSubscribedClients protoName subClnts = do
clnts <- readTVarIO subClnts
hPutStrLn h $ protoName <> " subscribed clients count:" <> show (IM.size clnts)
countClientSubs :: (Client -> TMap QueueId a) -> Maybe (M.Map QueueId a -> IO (Int, Int, Int, Int)) -> IM.IntMap (Maybe Client) -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
countClientSubs subSel countSubs_ = foldM addSubs (0, (0, 0, 0, 0), 0, (0, 0, 0))
where
@@ -680,11 +708,14 @@ runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessio
expCfg <- asks $ inactiveClientExpiration . config
th <- newMVar h -- put TH under a fair lock to interleave messages and command responses
labelMyThread . B.unpack $ "client $" <> encode sessionId
raceAny_ $ [liftIO $ send th c, liftIO $ sendMsg th c, client thParams c s, receive h c] <> disconnectThread_ c expCfg
disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport h (rcvActiveAt c) (sndActiveAt c) expCfg (noSubscriptions c)]
disconnectThread_ _ _ = []
noSubscriptions c = atomically $ (&&) <$> TM.null (ntfSubscriptions c) <*> (not . hasSubs <$> readTVar (subscriptions c))
hasSubs = any $ (\case ServerSub _ -> True; ProhibitSub -> False) . subThread
raceAny_ $ [liftIO $ send th c, liftIO $ sendMsg th c, client thParams c s, receive h c] <> disconnectThread_ c s expCfg
disconnectThread_ c s (Just expCfg) = [liftIO $ disconnectTransport h (rcvActiveAt c) (sndActiveAt c) expCfg (noSubscriptions c s)]
disconnectThread_ _ _ _ = []
noSubscriptions Client {clientId} s = do
hasSubs <- IM.member clientId <$> readTVarIO (subClients s)
if hasSubs
then pure False
else not . IM.member clientId <$> readTVarIO (ntfSubClients s)
clientDisconnected :: Client -> M ()
clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, connected, sessionId, endThreads} = do
@@ -695,10 +726,12 @@ clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, connecte
subs <- atomically $ swapTVar subscriptions M.empty
ntfSubs <- atomically $ swapTVar ntfSubscriptions M.empty
liftIO $ mapM_ cancelSub subs
Server {subscribers, notifiers} <- asks server
Server {subscribers, notifiers, subClients, ntfSubClients} <- asks server
liftIO $ updateSubscribers subs subscribers
liftIO $ updateSubscribers ntfSubs notifiers
asks clients >>= atomically . (`modifyTVar'` IM.delete clientId)
atomically $ modifyTVar' subClients $ IM.delete clientId
atomically $ modifyTVar' ntfSubClients $ IM.delete clientId
tIds <- atomically $ swapTVar endThreads IM.empty
liftIO $ mapM_ (mapM_ killThread <=< deRefWeak) tIds
where
@@ -787,7 +820,7 @@ send th c@Client {sndQ, msgQ, sessionId} = do
-- replace MSG response with OK, accumulating MSG in a separate list.
MSG {} -> ((CorrId "", entId, cmd) : msgs, (corrId, entId, OK))
_ -> (msgs, t)
sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO ()
sendMsg th c@Client {msgQ, sessionId} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " sendMsg"
@@ -899,7 +932,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do
mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId
client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M ()
client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, deletedQ, ntfSubscribedQ, ntfDeletedQ, subscribers, notifiers} = do
client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers, notifiers} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
forever $
atomically (readTBQueue rcvQ)
@@ -1093,7 +1126,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
Right nId_ -> do
withLog $ \s -> logAddNotifier s entId ntfCreds
incStat . ntfCreated =<< asks serverStats
forM_ nId_ $ \nId -> atomically $ writeTQueue ntfDeletedQ (nId, clientId)
forM_ nId_ $ \nId -> atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False)
pure $ NID notifierId rcvPublicDhKey
deleteQueueNotifier_ :: QueueStore -> M (Transmission BrokerMsg)
@@ -1102,7 +1135,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
liftIO (deleteQueueNotifier st entId) >>= \case
Right (Just nId) -> do
-- Possibly, the same should be done if the queue is suspended, but currently we do not use it
atomically $ writeTQueue ntfDeletedQ (nId, clientId)
atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False)
incStat . ntfDeleted =<< asks serverStats
pure ok
Right Nothing -> pure ok
@@ -1130,7 +1163,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
where
newSub :: M Sub
newSub = time "SUB newSub" . atomically $ do
writeTQueue subscribedQ (rId, clientId)
writeTQueue subscribedQ (rId, clientId, True)
sub <- newSubscription NoSub
TM.insert rId sub subscriptions
pure sub
@@ -1163,6 +1196,10 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
newSub = do
s <- newProhibitedSub
TM.insert entId s subscriptions
-- Here we don't account for this client as subscribed in the server
-- and don't notify other subscribed clients.
-- This is tracked as "subscription" in the client to prevent these
-- clients from being able to subscribe.
pure s
getMessage_ :: Sub -> Maybe MsgId -> M (Transmission BrokerMsg)
getMessage_ s delivered_ = do
@@ -1191,7 +1228,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
when (Just t /= updatedAt) $ do
withLog $ \s -> logUpdateQueueTime s rId t
st <- asks queueStore
liftIO $ updateQueueTime st rId t
liftIO $ updateQueueTime st rId t
subscribeNotifications :: M (Transmission BrokerMsg)
subscribeNotifications = do
@@ -1205,7 +1242,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
pure ok
where
newSub = do
writeTQueue ntfSubscribedQ (entId, clientId)
writeTQueue ntfSubscribedQ (entId, clientId, True)
TM.insert entId () ntfSubscriptions
acknowledgeMsg :: QueueRec -> MsgId -> M (Transmission BrokerMsg)
@@ -1486,9 +1523,15 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
liftIO (deleteQueue st entId $>>= \q -> delMsgQueue ms entId $> Right q) >>= \case
Right q -> do
-- Possibly, the same should be done if the queue is suspended, but currently we do not use it
atomically $ writeTQueue deletedQ (entId, clientId)
atomically $ do
writeTQueue subscribedQ (entId, clientId, False)
-- queue is usually deleted by the same client that is currently subscribed,
-- we delete subscription here, so the client with no subscriptions can be disconnected.
TM.delete entId subscriptions
forM_ (notifierId <$> notifier q) $ \nId ->
atomically $ writeTQueue ntfDeletedQ (nId, clientId)
-- queue is deleted by a different client from the one subscribed to notifications,
-- so we don't need to remove subscription from the current client.
atomically $ writeTQueue ntfSubscribedQ (nId, clientId, False)
updateDeletedStats q
pure ok
Left e -> pure $ err e
+14 -8
View File
@@ -6,6 +6,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
@@ -29,7 +30,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 (loadFingerprint)
import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (eitherToMaybe, whenM)
import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
@@ -139,7 +140,7 @@ createServerX509_ createCA cfgPath x509cfg = do
)
saveFingerprint = do
Fingerprint fp <- loadFingerprint $ c caCrtFile
Fingerprint fp <- loadFileFingerprint $ c caCrtFile
withFile (c fingerprintFile) WriteMode (`B.hPutStrLn` strEncode fp)
pure fp
@@ -268,14 +269,14 @@ settingIsOn section name ini
checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString
checkSavedFingerprint cfgPath x509cfg = do
savedFingerprint <- withFile (c fingerprintFile) ReadMode hGetLine
Fingerprint fp <- loadFingerprint (c caCrtFile)
Fingerprint fp <- loadFileFingerprint (c caCrtFile)
when (B.pack savedFingerprint /= strEncode fp) $
exitError "Stored fingerprint is invalid."
pure fp
where
c = combine cfgPath . ($ x509cfg)
iniTransports :: Ini -> [(String, ATransport)]
iniTransports :: Ini -> [(ServiceName, ATransport, AddHTTP)]
iniTransports ini =
let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
ws = strictIni "TRANSPORT" "websockets" ini
@@ -283,17 +284,22 @@ iniTransports ini =
| ws == "off" = []
| ws == "on" = ["80"]
| otherwise = ports ws \\ smpPorts
in map (,transport @TLS) smpPorts <> map (,transport @WS) wsPorts
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 ","
printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO ()
printServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
printServerConfig transports logFile = do
putStrLn $ case logFile of
Just f -> "Store log: " <> f
_ -> "Store log disabled."
forM_ transports $ \(p, ATransport t) ->
putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..."
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
deleteDirIfExists :: FilePath -> IO ()
deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
+49 -26
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -10,11 +11,13 @@ 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
@@ -22,6 +25,7 @@ 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
@@ -41,13 +45,15 @@ 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 (SocketState, TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams, newSocketState)
import Simplex.Messaging.Transport.Server
import System.Directory (doesFileExist)
import System.Exit (exitFailure)
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
data ServerConfig = ServerConfig
{ transports :: [(ServiceName, ATransport)],
{ transports :: [(ServiceName, ATransport, AddHTTP)],
smpHandshakeTimeout :: Int,
tbqSize :: Natural,
msgQueueQuota :: Int,
@@ -78,10 +84,8 @@ data ServerConfig = ServerConfig
serverStatsBackupFile :: Maybe FilePath,
-- | interval between sending pending END events to unsubscribed clients, seconds
pendingENDInterval :: Int,
-- | CA certificate private key is not needed for initialization
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
smpCredentials :: ServerCredentials,
httpCredentials :: Maybe ServerCredentials,
-- | SMP client-server protocol version range
smpServerVRange :: VersionRangeSMP,
-- | TCP transport config
@@ -125,7 +129,8 @@ data Env = Env
msgStore :: STMMsgStore,
random :: TVar ChaChaDRG,
storeLog :: Maybe (StoreLog 'WriteMode),
tlsServerParams :: T.ServerParams,
tlsServerCreds :: T.Credential,
httpServerCreds :: Maybe T.Credential,
serverStats :: ServerStats,
sockets :: SocketState,
clientSeq :: TVar ClientId,
@@ -136,16 +141,14 @@ data Env = Env
type Subscribed = Bool
data Server = Server
{ subscribedQ :: TQueue (RecipientId, ClientId),
deletedQ :: TQueue (RecipientId, ClientId),
{ subscribedQ :: TQueue (RecipientId, ClientId, Subscribed),
subscribers :: TMap RecipientId (TVar Client),
ntfSubscribedQ :: TQueue (NotifierId, ClientId),
ntfDeletedQ :: TQueue (NotifierId, ClientId),
ntfSubscribedQ :: TQueue (NotifierId, ClientId, Subscribed),
notifiers :: TMap NotifierId (TVar Client),
pendingENDs :: TVar (IntMap (NonEmpty RecipientId)),
pendingDELDs :: TVar (IntMap (NonEmpty RecipientId)),
pendingNtfENDs :: TVar (IntMap (NonEmpty NotifierId)),
pendingNtfDELDs :: TVar (IntMap (NonEmpty NotifierId)),
subClients :: TVar (IntMap Client), -- clients with SMP subscriptions
ntfSubClients :: TVar (IntMap Client), -- clients with Ntf subscriptions
pendingSubEvents :: TVar (IntMap (NonEmpty (RecipientId, Subscribed))),
pendingNtfSubEvents :: TVar (IntMap (NonEmpty (NotifierId, Subscribed))),
savingLock :: Lock
}
@@ -185,17 +188,15 @@ data Sub = Sub
newServer :: IO Server
newServer = do
subscribedQ <- newTQueueIO
deletedQ <- newTQueueIO
subscribers <- TM.emptyIO
ntfSubscribedQ <- newTQueueIO
ntfDeletedQ <- newTQueueIO
notifiers <- TM.emptyIO
pendingENDs <- newTVarIO IM.empty
pendingDELDs <- newTVarIO IM.empty
pendingNtfENDs <- newTVarIO IM.empty
pendingNtfDELDs <- newTVarIO IM.empty
subClients <- newTVarIO IM.empty
ntfSubClients <- newTVarIO IM.empty
pendingSubEvents <- newTVarIO IM.empty
pendingNtfSubEvents <- newTVarIO IM.empty
savingLock <- atomically createLock
return Server {subscribedQ, deletedQ, subscribers, ntfSubscribedQ, ntfDeletedQ, notifiers, pendingENDs, pendingDELDs, pendingNtfENDs, pendingNtfDELDs, savingLock}
return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, subClients, ntfSubClients, pendingSubEvents, pendingNtfSubEvents, savingLock}
newClient :: ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client
newClient clientId qSize thVersion sessionId createdAt = do
@@ -224,7 +225,7 @@ newProhibitedSub = do
return Sub {subThread = ProhibitSub, delivered}
newEnv :: ServerConfig -> IO Env
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg, transportConfig, information, messageExpiration} = do
newEnv config@ServerConfig {smpCredentials, httpCredentials, storeLogFile, smpAgentCfg, information, messageExpiration} = do
server <- newServer
queueStore <- newQueueStore
msgStore <- newMsgStore
@@ -233,16 +234,38 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
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
tlsServerCreds <- getCredentials "SMP" smpCredentials
httpServerCreds <- mapM (getCredentials "HTTPS") httpCredentials
mapM_ checkHTTPSCredentials httpServerCreds
Fingerprint fp <- loadFingerprint smpCredentials
let serverIdentity = KeyHash fp
serverStats <- newServerStats =<< getCurrentTime
sockets <- newSocketState
clientSeq <- newTVarIO 0
clients <- newTVarIO mempty
proxyAgent <- newSMPProxyAgent smpAgentCfg random
pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent}
pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerCreds, httpServerCreds, 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
+54 -36
View File
@@ -8,6 +8,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Messaging.Server.Main where
@@ -35,14 +36,14 @@ 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 (runSMPServer)
import Simplex.Messaging.Server (AttachHTTP, runSMPServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration, defaultProxyClientConcurrency)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange)
import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedServerSMPRelayVRange)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
import Simplex.Messaging.Version (mkVersionRange)
import System.Directory (createDirectoryIfMissing, doesFileExist)
@@ -51,10 +52,16 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
import Text.Read (readMaybe)
smpServerCLI :: FilePath -> FilePath -> IO ()
smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ())
smpServerCLI = smpServerCLI_ (\_ _ _ -> pure ()) (\_ -> pure ()) (\_ -> error "attachStaticFiles not available")
smpServerCLI_ :: (ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) -> (EmbeddedWebParams -> IO ()) -> FilePath -> FilePath -> IO ()
smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
smpServerCLI_ ::
(ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) ->
(EmbeddedWebParams -> IO ()) ->
(FilePath -> (AttachHTTP -> IO ()) -> IO ()) ->
FilePath ->
FilePath ->
IO ()
smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
Init opts ->
doesFileExist iniFile >>= \case
@@ -76,10 +83,10 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
where
iniFile = combine cfgPath "smp-server.ini"
serverVersion = "SMP server v" <> simplexMQVersion
defaultServerPort = "5223"
defaultServerPorts = "5223,443"
executableName = "smp-server"
storeLogFilePath = combine logPath "smp-server-store.log"
httpsCertFile = combine cfgPath "web.cert"
httpsCertFile = combine cfgPath "web.crt"
httpsKeyFile = combine cfgPath "web.key"
defaultStaticPath = combine logPath "www"
initializeServer opts@InitOptions {ip, fqdn, sourceCode = src', webStaticPath = sp', disableWeb = noWeb', scripted}
@@ -95,7 +102,6 @@ smpServerCLI_ generateSite serveStaticFiles 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,
@@ -104,7 +110,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
password,
sourceCode = (T.pack <$> sourceCode') <|> src',
webStaticPath = if null staticPath' then sp' else Just staticPath',
disableWeb = not enableWeb
disableWeb = noWeb'
}
where
serverPassword =
@@ -171,7 +177,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
\# 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 defaultServerPort <> "\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\
\websockets: off\n\
@@ -204,19 +210,21 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
<> "# 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"
<> ((if disableWeb then "# " else "") <> "http: 8000\n\n")
<> (webDisabled <> "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")
\# 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 ""
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, transports, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
cfg@ServerConfig {information, 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
@@ -246,23 +254,37 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
newQueuesAllowed = allowNewQueues cfg,
basicAuthEnabled = isJust newQueueBasicAuth
}
runWebServer ini ServerInformation {config, information}
runSMPServer cfg
case webStaticPath' of
Just path | sharedHTTP -> do
runWebServer path Nothing ServerInformation {config, information}
attachStaticFiles path $ \attachHTTP -> runSMPServer cfg $ Just attachHTTP
Just path -> do
runWebServer path webHttpsParams' ServerInformation {config, information}
runSMPServer cfg Nothing
Nothing -> do
logWarn "No server static path set"
runSMPServer cfg Nothing
where
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
logStats = settingIsOn "STORE_LOG" "log_stats" ini
c = combine cfgPath . ($ defaultX509Config)
transports = iniTransports ini
sharedHTTP = any (\(_, _, addHTTP) -> addHTTP) transports
serverConfig =
ServerConfig
{ transports = iniTransports ini,
{ transports,
smpHandshakeTimeout = 120000000,
tbqSize = 128,
msgQueueQuota = 128,
queueIdBytes = 24,
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
caCertificateFile = c caCrtFile,
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile,
smpCredentials =
ServerCredentials
{ caCertificateFile = Just $ c caCrtFile,
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile
},
httpCredentials = (\WebHttpsParams {key, cert} -> ServerCredentials {caCertificateFile = Nothing, privateKeyFile = key, certificateFile = cert}) <$> webHttpsParams',
storeLogFile = enableStoreLog $> storeLogFilePath,
storeMsgsFile =
let messagesPath = combine logPath "smp-server-messages.log"
@@ -295,8 +317,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
smpServerVRange = supportedServerSMPRelayVRange,
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
alpn = Just supportedSMPHandshakes
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
},
controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
smpAgentCfg =
@@ -322,26 +343,23 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
}
textToOwnServers :: Text -> [ByteString]
textToOwnServers = map encodeUtf8 . T.words
runWebServer ini si =
case eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini of
Nothing -> logWarn "No server static path set"
Just webStaticPath -> do
runWebServer webStaticPath webHttpsParams si = 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
data EmbeddedWebParams = EmbeddedWebParams
{ webStaticPath :: FilePath,
+3 -1
View File
@@ -55,6 +55,7 @@ data StoreLogRecord
| DeleteQueue QueueId
| DeleteNotifier QueueId
| UpdateTime QueueId RoundedSystemTime
deriving (Show)
data SLRTag
= CreateQueue_
@@ -74,10 +75,11 @@ instance StrEncoding QueueRec where
"sid=" <> strEncode senderId,
"sk=" <> strEncode senderKey
]
<> if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
<> sndSecureStr
<> 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
+29 -6
View File
@@ -65,7 +65,8 @@ module Simplex.Messaging.Transport
ALPN,
connectTLS,
closeTLS,
supportedParameters,
defaultSupportedParams,
defaultSupportedParamsHTTPS,
withTlsUnique,
-- * SMP transport
@@ -100,6 +101,7 @@ import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Default (def)
import Data.Functor (($>))
import Data.Typeable (Typeable)
import Data.Version (showVersion)
import Data.Word (Word16)
import qualified Data.X509 as X
@@ -214,7 +216,7 @@ data TransportConfig = TransportConfig
transportTimeout :: Maybe Int
}
class Transport c where
class Typeable c => Transport c where
transport :: ATransport
transport = ATransport (TProxy @c)
@@ -312,8 +314,8 @@ closeTLS ctx =
`E.finally` T.contextClose ctx
`catchAll_` pure ()
supportedParameters :: T.Supported
supportedParameters =
defaultSupportedParams :: T.Supported
defaultSupportedParams =
def
{ T.supportedVersions = [T.TLS13, T.TLS12],
T.supportedCiphers =
@@ -321,8 +323,29 @@ supportedParameters =
TE.cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 -- for TLS12
],
T.supportedHashSignatures = [(T.HashIntrinsic, T.SignatureEd448), (T.HashIntrinsic, T.SignatureEd25519)],
T.supportedSecureRenegotiation = False,
T.supportedGroups = [T.X448, T.X25519]
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)
]
}
instance Transport TLS where
+11 -9
View File
@@ -125,7 +125,8 @@ data TransportClientConfig = TransportClientConfig
tcpKeepAlive :: Maybe KeepAliveOpts,
logTLSErrors :: Bool,
clientCredentials :: Maybe (X.CertificateChain, T.PrivKey),
alpn :: Maybe [ALPN]
alpn :: Maybe [ALPN],
useSNI :: Bool
}
deriving (Eq, Show)
@@ -134,7 +135,7 @@ defaultTcpConnectTimeout :: Int
defaultTcpConnectTimeout = 25_000_000
defaultTransportClientConfig :: TransportClientConfig
defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing
defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing True
clientTransportConfig :: TransportClientConfig -> TransportConfig
clientTransportConfig TransportClientConfig {logTLSErrors} =
@@ -142,13 +143,13 @@ clientTransportConfig TransportClientConfig {logTLSErrors} =
-- | 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 supportedParameters Nothing
runTransportClient = runTLSTransportClient defaultSupportedParams 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} socksCreds host port keyHash client = do
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn, useSNI} socksCreds host port keyHash client = do
serverCert <- newEmptyTMVarIO
let hostName = B.unpack $ strEncode host
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn useSNI serverCert
connectTCP = case socksProxy of
Just proxy -> connectSocksClient proxy socksCreds (hostAddr host)
_ -> connectTCPClient hostName
@@ -238,7 +239,7 @@ instance StrEncoding SocksProxy 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"
_ -> fail "SOCKS5 host should be IPv4 or IPv6 address"
instance StrEncoding SocksProxyWithAuth where
strEncode (SocksProxyWithAuth auth proxy) = strEncode auth <> strEncode proxy
@@ -263,10 +264,11 @@ instance StrEncoding SocksAuth where
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] -> TMVar X.CertificateChain -> T.ClientParams
mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ serverCerts =
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 =
(T.defaultParamsClient host p)
{ T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
{ T.clientUseServerNameIndication = sni,
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.Credentials)
tlsCredentials credentials = (C.KeyHash rootFP, TLS.Credentials [(X509.CertificateChain certs, privateToTls $ snd leafKey)])
tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credential)
tlsCredentials credentials = (C.KeyHash rootFP, (X509.CertificateChain certs, privateToTls $ snd leafKey))
where
Fingerprint rootFP = getFingerprint root X509.HashSHA256
leafKey = fst $ L.head credentials
@@ -78,7 +78,8 @@ defaultHTTP2ClientConfig =
tcpKeepAlive = Nothing,
logTLSErrors = True,
clientCredentials = Nothing,
alpn = Nothing
alpn = Nothing,
useSNI = True
},
bufferSize = defaultHTTP2BufferSize,
bodyHeadSize = 16384,
@@ -15,7 +15,7 @@ import Numeric.Natural (Natural)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (ALPN, SessionId, TLS, closeConnection, tlsALPN, tlsUniq)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadSupportedTLSServerParams, runTransportServer)
import Simplex.Messaging.Transport.Server (ServerCredentials, TransportServerConfig (..), loadServerCredential, runTransportServer)
import Simplex.Messaging.Util (threadDelay')
import UnliftIO (finally)
import UnliftIO.Concurrent (forkIO, killThread)
@@ -28,9 +28,7 @@ data HTTP2ServerConfig = HTTP2ServerConfig
bufferSize :: BufferSize,
bodyHeadSize :: Int,
serverSupported :: T.Supported,
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
https2Credentials :: ServerCredentials,
transportConfig :: TransportServerConfig
}
deriving (Show)
@@ -49,13 +47,13 @@ data HTTP2Server = HTTP2Server
}
-- This server is for testing only, it processes all requests in a single queue.
getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
getHTTP2Server :: HTTP2ServerConfig -> Maybe [ALPN] -> IO HTTP2Server
getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, https2Credentials, transportConfig} alpn_ = do
srvCreds <- loadServerCredential https2Credentials
started <- newEmptyTMVarIO
reqQ <- newTBQueueIO qSize
action <- async $
runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do
runHTTP2Server started http2Port bufferSize serverSupported srvCreds alpn_ transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do
reqBody <- getHTTP2Body r bodyHeadSize
atomically $ writeTBQueue reqQ HTTP2Request {sessionId, sessionALPN, request = r, reqBody, sendResponse}
void . atomically $ takeTMVar started
@@ -64,10 +62,10 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
closeHTTP2Server :: HTTP2Server -> IO ()
closeHTTP2Server = uninterruptibleCancel . action
runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO ()
runHTTP2Server started port bufferSize serverParams transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO ()
runHTTP2Server started port bufferSize srvSupported srvCreds alpn_ transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
where
setup = runTransportServer started port serverParams transportConfig
setup = runTransportServer started port srvSupported srvCreds alpn_ transportConfig
runHTTP2ServerWith :: BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
runHTTP2ServerWith = runHTTP2ServerWith_ Nothing (\_sessId -> pure ())
+67 -49
View File
@@ -6,8 +6,11 @@
module Simplex.Messaging.Transport.Server
( TransportServerConfig (..),
ServerCredentials (..),
AddHTTP,
defaultTransportServerConfig,
runTransportServerState,
runTransportServerState_,
SocketState,
newSocketState,
runTransportServer,
@@ -15,11 +18,12 @@ module Simplex.Messaging.Transport.Server
runLocalTCPServer,
runTCPServerSocket,
startTCPServer,
loadSupportedTLSServerParams,
loadTLSServerParams,
loadServerCredential,
supportedTLSServerParams,
supportedTLSServerParams_,
loadFingerprint,
loadFileFingerprint,
smpServerHandshake,
tlsServerCredentials,
)
where
@@ -31,7 +35,7 @@ import Data.Default (def)
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import Data.List (find)
import Data.Maybe (fromJust, fromMaybe)
import Data.Maybe (fromJust, fromMaybe, maybeToList)
import qualified Data.X509 as X
import Data.X509.Validation (Fingerprint (..))
import qualified Data.X509.Validation as XV
@@ -52,18 +56,25 @@ import UnliftIO.STM
data TransportServerConfig = TransportServerConfig
{ logTLSErrors :: Bool,
tlsSetupTimeout :: Int,
transportTimeout :: Int,
alpn :: Maybe [ALPN]
transportTimeout :: Int
}
deriving (Eq, Show)
data ServerCredentials = ServerCredentials
{ caCertificateFile :: Maybe FilePath, -- CA certificate private key is not needed for initialization
privateKeyFile :: FilePath,
certificateFile :: FilePath
}
deriving (Show)
type AddHTTP = Bool
defaultTransportServerConfig :: TransportServerConfig
defaultTransportServerConfig =
TransportServerConfig
{ logTLSErrors = True,
tlsSetupTimeout = 60000000,
transportTimeout = 40000000,
alpn = Nothing
transportTimeout = 40000000
}
serverTransportConfig :: TransportServerConfig -> TransportConfig
@@ -74,37 +85,41 @@ serverTransportConfig TransportServerConfig {logTLSErrors} =
-- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
--
-- All accepted connections are passed to the passed function.
runTransportServer :: forall c. Transport c => TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> IO ()) -> IO ()
runTransportServer started port params cfg server = do
runTransportServer :: forall c. Transport c => TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c -> IO ()) -> IO ()
runTransportServer started port srvSupported srvCreds alpn_ cfg server = do
ss <- newSocketState
runTransportServerState ss started port params cfg server
runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server
runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> IO ()) -> IO ()
runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c))
runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c -> IO ()) -> IO ()
runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server = runTransportServerState_ ss started port srvSupported (const srvCreds) alpn_ cfg (const server)
runTransportServerState_ :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> c -> IO ()) -> IO ()
runTransportServerState_ ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c))
-- | Run a transport server with provided connection setup and handler.
runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
runTransportServerSocket started getSocket threadLabel serverParams cfg server = do
runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.Credential -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
runTransportServerSocket started getSocket threadLabel srvCreds srvParams cfg server = do
ss <- newSocketState
runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server
runTransportServerSocketState_ ss started getSocket threadLabel (const srvCreds) srvParams cfg (const server)
runTransportServerSocketState :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> a -> IO ()) -> IO ()
runTransportServerSocketState ss started getSocket threadLabel srvSupported srvCreds alpn_ =
runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams
where
srvParams = supportedTLSServerParams_ srvSupported srvCreds alpn_
-- | Run a transport server with provided connection setup and handler.
runTransportServerSocketState :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server = do
runTransportServerSocketState_ :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> (Maybe HostName -> (X.CertificateChain, X.PrivKey)) -> T.ServerParams -> TransportServerConfig -> (Socket -> a -> IO ()) -> IO ()
runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams cfg server = do
labelMyThread $ "transport server for " <> threadLabel
runTCPServerSocket ss started getSocket $ \conn ->
E.bracket (setup conn >>= maybe (fail "tls setup timeout") pure) closeConnection server
E.bracket (setup conn >>= maybe (fail "tls setup timeout") pure) closeConnection (server conn)
where
tCfg = serverTransportConfig cfg
setup conn = timeout (tlsSetupTimeout cfg) $ do
labelMyThread $ threadLabel <> "/setup"
tls <- connectTLS Nothing tCfg serverParams conn
getServerConnection tCfg (fst $ tlsServerCredentials serverParams) tls
tlsServerCredentials :: T.ServerParams -> (X.CertificateChain, X.PrivKey)
tlsServerCredentials serverParams = case T.sharedCredentials $ T.serverShared serverParams of
T.Credentials [creds] -> creds
_ -> error "server has more than one key"
tls <- connectTLS Nothing tCfg srvParams conn
getServerConnection tCfg (fst $ srvCreds Nothing) tls
-- | Run TCP server without TLS
runLocalTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
@@ -176,30 +191,33 @@ startTCPServer started host port = withSocketsDo $ resolve >>= open >>= setStart
pure sock
setStarted sock = atomically (tryPutTMVar started True) >> pure sock
loadTLSServerParams :: FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams
loadTLSServerParams = loadSupportedTLSServerParams supportedParameters
loadServerCredential :: ServerCredentials -> IO T.Credential
loadServerCredential ServerCredentials {caCertificateFile, certificateFile, privateKeyFile} =
T.credentialLoadX509Chain certificateFile (maybeToList caCertificateFile) privateKeyFile >>= \case
Right credential -> pure credential
Left _ -> putStrLn "invalid credential" >> exitFailure
loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams
loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile alpn_ = do
tlsServerParams <- fromCredential <$> loadServerCredential
pure tlsServerParams {T.serverHooks = maybe def alpnHooks alpn_}
where
loadServerCredential :: IO T.Credential
loadServerCredential =
T.credentialLoadX509Chain certificateFile [caCertificateFile] privateKeyFile >>= \case
Right credential -> pure credential
Left _ -> putStrLn "invalid credential" >> exitFailure
fromCredential :: T.Credential -> T.ServerParams
fromCredential credential =
def
{ T.serverWantClientCert = False,
T.serverShared = def {T.sharedCredentials = T.Credentials [credential]},
T.serverHooks = def,
T.serverSupported = serverSupported
}
alpnHooks supported = def {T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported)}
supportedTLSServerParams :: T.Credential -> Maybe [ALPN] -> T.ServerParams
supportedTLSServerParams = supportedTLSServerParams_ defaultSupportedParams . const
loadFingerprint :: FilePath -> IO Fingerprint
loadFingerprint certificateFile = do
supportedTLSServerParams_ :: T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> T.ServerParams
supportedTLSServerParams_ serverSupported creds alpn_ =
def
{ T.serverWantClientCert = False,
T.serverHooks =
def
{ T.onServerNameIndication = \host_ -> pure $ T.Credentials [creds host_],
T.onALPNClientSuggest = (\alpn -> pure . fromMaybe "" . find (`elem` alpn)) <$> alpn_
},
T.serverSupported = serverSupported
}
loadFingerprint :: ServerCredentials -> IO Fingerprint
loadFingerprint ServerCredentials {caCertificateFile} = case caCertificateFile of
Just certificateFile -> loadFileFingerprint certificateFile
Nothing -> error "CA file must be used in protocol credentials"
loadFileFingerprint :: FilePath -> IO Fingerprint
loadFileFingerprint certificateFile = do
(cert : _) <- SX.readSignedObject certificateFile
pure $ XV.getFingerprint (cert :: X.SignedExact X.Certificate) X.HashSHA256
+2 -5
View File
@@ -190,7 +190,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
}
pure $ signInvitation (snd sessKeys) idPrivKey inv
genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials
genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credential
genTLSCredentials drg caKey caCert = do
let caCreds = (C.signatureKeyPair caKey, caCert)
leaf <- genCredentials drg (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert
@@ -282,10 +282,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
pure RCCClient_ {confirmSession, endSession}
runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO ()
runClient RCCClient_ {confirmSession, endSession} r = do
clientCredentials <-
liftIO (genTLSCredentials drg caKey caCert) >>= \case
TLS.Credentials (creds : _) -> pure $ Just creds
_ -> throwE $ RCEInternal "genTLSCredentials must generate credentials"
clientCredentials <- liftIO $ Just <$> genTLSCredentials drg caKey caCert
let clientConfig = defaultTransportClientConfig {clientCredentials}
ExceptT . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls@TLS {tlsBuffer, tlsContext} -> runExceptT $ do
-- pump socket to detect connection problems
+5 -5
View File
@@ -23,7 +23,7 @@ import Network.Info (IPv4 (..), NetworkInterface (..), getNetworkInterfaces)
import qualified Network.Socket as N
import qualified Network.TLS as TLS
import qualified Network.UDP as UDP
import Simplex.Messaging.Transport (supportedParameters)
import Simplex.Messaging.Transport (defaultSupportedParams)
import qualified Simplex.Messaging.Transport as Transport
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
@@ -68,7 +68,7 @@ preferAddress RCCtrlAddress {address, interface} addrs =
matchAddr RCCtrlAddress {address = a} = a == address
matchIface RCCtrlAddress {interface = i} = i == interface
startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> IO (Async ())
startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credential -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> IO (Async ())
startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ do
started <- newEmptyTMVarIO
bracketOnError (startTCPServer started Nothing $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket ->
@@ -81,14 +81,14 @@ startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ d
port <- N.socketPort socket
logInfo $ "System-assigned port: " <> tshow port
setPort $ Just port
runTransportServerSocket started (pure socket) "RCP TLS" serverParams defaultTransportServerConfig server
runTransportServerSocket started (pure socket) "RCP TLS" credentials serverParams defaultTransportServerConfig server
setPort = void . atomically . tryPutTMVar startedOnPort
serverParams =
def
{ TLS.serverWantClientCert = True,
TLS.serverShared = def {TLS.sharedCredentials = credentials},
TLS.serverShared = def {TLS.sharedCredentials = TLS.Credentials [credentials]},
TLS.serverHooks = hooks,
TLS.serverSupported = supportedParameters
TLS.serverSupported = defaultSupportedParams
}
withSender :: (UDP.UDPSocket -> IO a) -> IO a
+1 -1
View File
@@ -2869,7 +2869,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do
getClient clientId (clntAuth, clntVersion) db =
let servers = initAgentServers {smp = userServers' [ProtoServerWithAuth testSMPServer clntAuth]}
alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing
smpCfg = defaultClientConfig alpn_ $ V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion
smpCfg = defaultClientConfig alpn_ False $ V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion
sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519
in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db
+1 -1
View File
@@ -178,7 +178,7 @@ runNtfTestCfg :: HasCallStack => ATransport -> AgentMsgId -> ServerConfig -> Ntf
runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do
withSmpServerConfigOn t smpCfg testPort $ \_ ->
withAPNSMockServer $ \apns ->
withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ ->
withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t, False)]} $ \_ ->
withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId
threadDelay 100000
+6
View File
@@ -141,6 +141,7 @@ storeTests = do
it "should getNextDeletedSndChunkReplica" testGetNextDeletedSndChunkReplica
it "should markNtfSubActionNtfFailed_" testMarkNtfSubActionNtfFailed
it "should markNtfSubActionSMPFailed_" testMarkNtfSubActionSMPFailed
it "should markNtfTokenToDeleteFailed_" testMarkNtfTokenToDeleteFailed
describe "open/close store" $ do
it "should close and re-open" testCloseReopenStore
it "should close and re-open encrypted store" testCloseReopenEncryptedStore
@@ -838,3 +839,8 @@ testMarkNtfSubActionSMPFailed :: SQLiteStore -> Expectation
testMarkNtfSubActionSMPFailed st = do
withTransaction st $ \db -> do
markNtfSubActionSMPFailed_ db "abc"
testMarkNtfTokenToDeleteFailed :: SQLiteStore -> Expectation
testMarkNtfTokenToDeleteFailed st = do
withTransaction st $ \db -> do
markNtfTokenToDeleteFailed_ db 1
+94 -6
View File
@@ -3,15 +3,31 @@
module CLITests where
import Data.Ini (lookupValue, readIniFile)
import AgentTests.FunctionalAPITests (runRight_)
import Control.Logger.Simple
import Control.Monad
import qualified Crypto.PubKey.RSA as RSA
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import Data.Ini (Ini (..), lookupValue, readIniFile, writeIniFile)
import Data.List (isPrefixOf)
import qualified Data.Text as T
import qualified Data.X509 as X
import qualified Data.X509.File as XF
import Data.X509.Validation (Fingerprint (..))
import qualified Network.HTTP.Client as H1
import qualified Network.HTTP2.Client as H2
import Simplex.FileTransfer.Server.Main (xftpServerCLI)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Server.Main
import Simplex.Messaging.Server.Main
import Simplex.Messaging.Transport (simplexMQVersion)
import Simplex.Messaging.Server.Main (smpServerCLI, smpServerCLI_)
import Simplex.Messaging.Transport (TLS (..), defaultSupportedParams, defaultSupportedParamsHTTPS, simplexMQVersion, supportedClientSMPRelayVRange)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTLSTransportClient, smpClientHandshake)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
import Simplex.Messaging.Transport.Server (loadFileFingerprint)
import Simplex.Messaging.Util (catchAll_)
import qualified Static
import System.Directory (doesFileExist)
import System.Environment (withArgs)
import System.FilePath ((</>))
@@ -19,6 +35,10 @@ import System.IO.Silently (capture_)
import System.Timeout (timeout)
import Test.Hspec
import Test.Main (withStdin)
import UnliftIO (catchAny)
import UnliftIO.Async (async, cancel)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (bracket)
cfgPath :: FilePath
cfgPath = "tests/tmp/cli/etc/opt/simplex"
@@ -26,6 +46,9 @@ cfgPath = "tests/tmp/cli/etc/opt/simplex"
logPath :: FilePath
logPath = "tests/tmp/cli/etc/var/simplex"
webPath :: FilePath
webPath = "tests/tmp/cli/var/www"
ntfCfgPath :: FilePath
ntfCfgPath = "tests/tmp/cli/etc/opt/simplex-notifications"
@@ -46,6 +69,7 @@ cliTests = do
it "with store log, random password (default)" $ smpServerTest True True
it "no store log, no password" $ smpServerTest False False
it "with store log, no password" $ smpServerTest True False
it "static files" smpServerTestStatic
describe "Ntf server CLI" $ do
it "should initialize, start and delete the server (no store log)" $ ntfServerTest False
it "should initialize, start and delete the server (with store log)" $ ntfServerTest True
@@ -61,7 +85,7 @@ smpServerTest storeLog basicAuth = do
Right ini <- readIniFile $ cfgPath <> "/smp-server.ini"
lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
lookupValue "TRANSPORT" "port" ini `shouldBe` Right "5223"
lookupValue "TRANSPORT" "port" ini `shouldBe` Right "5223,443"
lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
lookupValue "AUTH" "new_queues" ini `shouldBe` Right "on"
lookupValue "INACTIVE_CLIENTS" "disconnect" ini `shouldBe` Right "off"
@@ -70,7 +94,7 @@ smpServerTest storeLog basicAuth = do
r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
r `shouldContain` ["SMP server v" <> simplexMQVersion]
r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."])
r `shouldContain` ["Listening on port 5223 (TLS)..."]
r `shouldContain` ["Serving SMP protocol on port 5223 (TLS)...", "Serving SMP protocol on port 443 (TLS)...", "Serving static site on port 443 (TLS)..."]
r `shouldContain` ["not expiring inactive clients"]
r `shouldContain` (if basicAuth then ["creating new queues requires password"] else ["creating new queues allowed"])
-- cert
@@ -94,6 +118,70 @@ smpServerTest storeLog basicAuth = do
>>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
smpServerTestStatic :: HasCallStack => IO ()
smpServerTestStatic = do
let iniFile = cfgPath <> "/smp-server.ini"
capture_ (withArgs ["init", "-y", "--no-password", "--web-path", webPath] $ smpServerCLI cfgPath logPath)
>>= (`shouldSatisfy` (("Server initialized, please provide additional server information in " <> iniFile) `isPrefixOf`))
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True
Right ini <- readIniFile iniFile
lookupValue "WEB" "static_path" ini `shouldBe` Right (T.pack webPath)
let transport = [("host", "localhost"), ("port", "5223"), ("log_tls_errors", "off"), ("websockets", "off")]
web = [("http", "8000"), ("https", "5223"), ("cert", "tests/fixtures/web.crt"), ("key", "tests/fixtures/web.key"), ("static_path", T.pack webPath)]
ini' = ini {iniSections = HM.insert "TRANSPORT" transport $ HM.insert "WEB" web (iniSections ini)}
writeIniFile iniFile ini'
Right ini_ <- readIniFile iniFile
lookupValue "WEB" "https" ini_ `shouldBe` Right "5223"
let smpServerCLI' = smpServerCLI_ Static.generateSite Static.serveStaticFiles Static.attachStaticFiles
let server = capture_ (withArgs ["start"] $ smpServerCLI' cfgPath logPath `catchAny` print)
bracket (async server) cancel $ \_t -> do
threadDelay 1000000
html <- BL.readFile $ webPath <> "/index.html"
-- "external" CA signing HTTP credentials
Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/ca.crt"
let caHTTP = C.KeyHash fpHTTP
manager <- H1.newManager H1.defaultManagerSettings
H1.responseBody <$> H1.httpLbs "http://127.0.0.1:8000" manager `shouldReturn` html
logDebug "Plain HTTP works"
threadDelay 2000000
let cfgHttp = defaultTransportClientConfig {alpn = Just ["h2"], useSNI = True}
runTLSTransportClient defaultSupportedParamsHTTPS Nothing cfgHttp Nothing "localhost" "5223" (Just caHTTP) $ \tls -> do
tlsALPN tls `shouldBe` Just "h2"
case getCerts tls of
X.Certificate {X.certPubKey = X.PubKeyRSA rsa} : _ca -> RSA.public_size rsa `shouldBe` 512
leaf : _ -> error $ "Unexpected leaf cert: " <> show leaf
[] -> error "Empty chain"
let h2cfg = HC.defaultHTTP2ClientConfig {HC.bodyHeadSize = 1024 * 1024}
h2 <- either (error . show) pure =<< HC.attachHTTP2Client h2cfg "localhost" "5223" mempty 65536 tls
let req = H2.requestNoBody "GET" "/" []
HC.HTTP2Response {HC.respBody = HTTP2Body {bodyHead = shsBody}} <- either (error . show) pure =<< HC.sendRequest h2 req (Just 1000000)
BL.fromStrict shsBody `shouldBe` html
logDebug "Combined HTTPS works"
-- "local" CA signing SMP credentials
Fingerprint fpSMP <- loadFileFingerprint (cfgPath <> "/ca.crt")
let caSMP = C.KeyHash fpSMP
let cfgSmp = defaultTransportClientConfig {alpn = Just ["smp/1"], useSNI = False}
runTLSTransportClient defaultSupportedParams Nothing cfgSmp Nothing "localhost" "5223" (Just caSMP) $ \tls -> do
tlsALPN tls `shouldBe` Just "smp/1"
case getCerts tls of
X.Certificate {X.certPubKey = X.PubKeyEd25519 _k} : _ca -> print _ca -- pure ()
leaf : _ -> error $ "Unexpected leaf cert: " <> show leaf
[] -> error "Empty chain"
runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange
logDebug "Combined SMP works"
where
getCerts :: TLS -> [X.Certificate]
getCerts tls =
let X.CertificateChain cc = tlsServerCerts tls
in map (X.signedObject . X.getSigned) cc
ntfServerTest :: Bool -> IO ()
ntfServerTest storeLog = do
capture_ (withArgs (["init"] <> ["-l" | storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath)
@@ -107,7 +195,7 @@ ntfServerTest storeLog = do
r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ()))
r `shouldContain` ["SMP notifications server v" <> simplexMQVersion]
r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."])
r `shouldContain` ["Listening on port 443 (TLS)..."]
r `shouldContain` ["Serving SMP protocol on port 443 (TLS)..."]
capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath)
>>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
+1 -1
View File
@@ -90,7 +90,7 @@ testSocksMode = do
where
transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode}
transportSocksCfg cfg host =
let TransportClientConfig {socksProxy} = transportClientConfig cfg host
let TransportClientConfig {socksProxy} = transportClientConfig cfg host True
in socksProxy
testSocksProxyEncoding :: Spec
+16 -12
View File
@@ -45,7 +45,6 @@ import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
import Simplex.Messaging.Transport.HTTP2.Server
import Simplex.Messaging.Transport.Server
import qualified Simplex.Messaging.Transport.Server as Server
import Test.Hspec
import UnliftIO.Async
import UnliftIO.Concurrent
@@ -96,17 +95,19 @@ ntfServerCfg =
subsBatchSize = 900,
inactiveClientExpiration = Just defaultInactiveClientExpiration,
storeLogFile = Nothing,
-- CA certificate private key is not needed for initialization
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
ntfCredentials =
ServerCredentials
{ caCertificateFile = Just "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
},
-- stats config
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/ntf-server-stats.daily.log",
serverStatsBackupFile = Nothing,
ntfServerVRange = supportedServerNTFVRange,
transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes}
transportConfig = defaultTransportServerConfig
}
ntfServerCfgVPrev :: NtfServerConfig
@@ -121,10 +122,10 @@ ntfServerCfgVPrev =
serverVRange' = serverVRange smpCfg'
withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]}
withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t, False)]}
withNtfServerThreadOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
withNtfServerThreadOn t port' = withNtfServerCfg ntfServerCfg {transports = [(port', t)]}
withNtfServerThreadOn t port' = withNtfServerCfg ntfServerCfg {transports = [(port', t, False)]}
withNtfServerCfg :: HasCallStack => NtfServerConfig -> (ThreadId -> IO a) -> IO a
withNtfServerCfg cfg@NtfServerConfig {transports} =
@@ -185,9 +186,12 @@ apnsMockServerConfig =
bufferSize = 16384,
bodyHeadSize = 16384,
serverSupported = http2TLSParams,
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
https2Credentials =
ServerCredentials
{ caCertificateFile = Just "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
},
transportConfig = defaultTransportServerConfig
}
@@ -219,7 +223,7 @@ deriving instance ToJSON APNSErrorResponse
getAPNSMockServer :: HTTP2ServerConfig -> IO APNSMockServer
getAPNSMockServer config@HTTP2ServerConfig {qSize} = do
http2Server <- getHTTP2Server config
http2Server <- getHTTP2Server config Nothing
apnsQ <- newTBQueueIO qSize
action <- async $ runAPNSMockServer apnsQ http2Server
pure APNSMockServer {action, apnsQ, http2Server}
+9 -6
View File
@@ -27,7 +27,6 @@ import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import qualified Simplex.Messaging.Transport.Client as Client
import Simplex.Messaging.Transport.Server
import qualified Simplex.Messaging.Transport.Server as Server
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import System.Environment (lookupEnv)
@@ -116,11 +115,15 @@ cfg =
serverStatsLogFile = "tests/smp-server-stats.daily.log",
serverStatsBackupFile = Nothing,
pendingENDInterval = 500000,
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
smpCredentials =
ServerCredentials
{ caCertificateFile = Just "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
},
httpCredentials = Nothing,
smpServerVRange = supportedServerSMPRelayVRange,
transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedSMPHandshakes},
transportConfig = defaultTransportServerConfig,
controlPort = Nothing,
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds
allowSMPProxy = False,
@@ -164,7 +167,7 @@ withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just tes
withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerConfigOn t cfg' port' =
serverBracket
(\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]})
(\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing)
(threadDelay 10000)
withSmpServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
+7 -6
View File
@@ -24,7 +24,7 @@ import SMPClient (xit'')
import Simplex.FileTransfer.Client (XFTPClientConfig (..))
import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription)
import Simplex.FileTransfer.Protocol (FileParty (..))
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), supportedXFTPhandshakes)
import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
@@ -37,6 +37,7 @@ import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Protocol (BasicAuth, ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
import Simplex.Messaging.Transport (ALPN)
import Simplex.Messaging.Util (tshow)
import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
import System.FilePath ((</>))
@@ -257,11 +258,11 @@ testXFTPAgentSendReceiveMatrix = do
where
oldClient = agentCfg {xftpCfg = (xftpCfg agentCfg) {clientALPN = Nothing}}
newClient = agentCfg
oldServer = testXFTPServerConfig_ Nothing
newServer = testXFTPServerConfig
run :: HasCallStack => XFTPServerConfig -> AgentConfig -> AgentConfig -> IO ()
run server sender receiver =
withXFTPServerCfg server $ \_t -> do
oldServer = Nothing
newServer = Just supportedXFTPhandshakes
run :: HasCallStack => Maybe [ALPN] -> AgentConfig -> AgentConfig -> IO ()
run alpn sender receiver =
withXFTPServerCfgALPN testXFTPServerConfig alpn $ \_t -> do
filePath <- createRandomFile_ (kb 319 :: Integer) "testfile"
rfd <- withAgent 1 sender initAgentServers testDB $ \sndr -> do
(sfId, _, rfd1, _) <- runRight $ testSendCF' sndr (CF.plain filePath) (kb 320)
+13 -10
View File
@@ -53,9 +53,12 @@ withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -
withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerCfg cfg =
withXFTPServerCfg cfg = withXFTPServerCfgALPN cfg $ Just supportedXFTPhandshakes
withXFTPServerCfgALPN :: HasCallStack => XFTPServerConfig -> Maybe [ALPN] -> (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerCfgALPN cfg alpn_ =
serverBracket
(`runXFTPServerBlocking` cfg)
(\started -> runXFTPServerBlocking started cfg alpn_)
(threadDelay 10000)
withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
@@ -98,10 +101,7 @@ testXFTPStatsBackupFile :: FilePath
testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log"
testXFTPServerConfig :: XFTPServerConfig
testXFTPServerConfig = testXFTPServerConfig_ (Just supportedXFTPhandshakes)
testXFTPServerConfig_ :: Maybe [ALPN] -> XFTPServerConfig
testXFTPServerConfig_ alpn =
testXFTPServerConfig =
XFTPServerConfig
{ xftpPort = xftpTestPort,
controlPort = Nothing,
@@ -117,15 +117,18 @@ testXFTPServerConfig_ alpn =
fileExpiration = Just defaultFileExpiration,
fileTimeout = 10000000,
inactiveClientExpiration = Just defaultInactiveClientExpiration,
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
xftpCredentials =
ServerCredentials
{ caCertificateFile = Just "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
},
xftpServerVRange = supportedFileServerVRange,
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
serverStatsBackupFile = Nothing,
transportConfig = defaultTransportServerConfig {alpn},
transportConfig = defaultTransportServerConfig,
responseDelay = 0
}
+34
View File
@@ -0,0 +1,34 @@
-----BEGIN CERTIFICATE-----
MIIDnTCCAx2gAwIBAgIUFhZZsKj9uBgGnUrr+Cf3XFf7t6IwBQYDK2VxMCoxFjAU
BgNVBAMMDVNNUCBzZXJ2ZXIgQ0ExEDAOBgNVBAoMB1NpbXBsZVgwIBcNMjQwOTI2
MTIyNTEyWhgPNDc2MjA4MjMxMjI1MTJaMBQxEjAQBgNVBAMMCWxvY2FsaG9zdDCC
AiIwDQYJKoZIhvcNAQEBBQADggIPADCCAgoCggIBALB59b8oyxP5YtXI1kemBzJU
Pt0xLN/Tmzdul283DhbNCJV+eUn4fNz+PjiRS/F2vZLb3WXInPi3bc57hw2Yu94o
7MXH5DTWkaubNq0bV0Koi17zZBSCOOq+MbPN7bUT1sOwOHadLh3IWTfkz9EufowD
ivpymNKWbeAHMXlXsBJnHfHuM05MWlP87PTHd3D7YQmmgbISgEGG4GchWBqnnCxx
gOOa09f/n+gWJFbN3hkbVZKMEpT5gu9WWsgv9BDhJzcBSw13MMz0sByxYKzhwQBJ
ikFz+16AttZ0ccoDaWwajZzK8+yfFv9T3b8kWmioHi2dw2vBgSove78liUqYCsOU
Bt5MNk3P037KgSJPdp6azsF3bMKmPssEhT9vHMPgSkiBfmBlJ7dTTRd9dh/cLKIO
AMzu4O+pEodIOJDXTARBE6VX1qoEZQuft5+ljVy4i9ySpmHnkxLocF40rKV1G0c5
LnVNTtr5GokC9sfIXZPZw0EEpk3eAseNWccwuyRfHQfL6yjcDig2IdLvLVcm9JyA
2P5QpP15EoA3Ow9uX8HmBbSFe1F35rqcNwY0lhDXEboSA/X4xDLnu4aVhNPiUnRq
NXqVlgz5ybRAUHd8fDBwK8fT5VhvuEnCja7+8hVc33gK56vu+28ZMkN2Y4z0GNQd
iamPUZJlUcCJzNI2cz27AgMBAAGjbzBtMAkGA1UdEwQCMAAwCwYDVR0PBAQDAgPI
MBMGA1UdJQQMMAoGCCsGAQUFBwMBMB0GA1UdDgQWBBSWiPT6Nl13/CTjaHCkHp17
GWoyvzAfBgNVHSMEGDAWgBQcUJvR7mm26yxMQfCsWgbnwMmJVDAFBgMrZXEDcwDC
DTbvSA61ydoRA8mTHFW1EYL+xfQjo0aH56N1Aqn47DzLGQZjP/fxoW929+Jwoiz0
UgUtUAeFjgA9wfvDv7mMm/K4wqyiZzFuWVZdQV6AUwBJK0hN5qlXpvJzMKLrj3Ap
dRELAgLJvC2e/xVc3dXSFwA=
-----END CERTIFICATE-----
-----BEGIN CERTIFICATE-----
MIIBtjCCATagAwIBAgIUe2PryrWo0xXX9vcA3WfbCzcdmgAwBQYDK2VxMCoxFjAU
BgNVBAMMDVNNUCBzZXJ2ZXIgQ0ExEDAOBgNVBAoMB1NpbXBsZVgwIBcNMjIwMTEx
MTExNjM5WhgPNDc1OTEyMDgxMTE2MzlaMCoxFjAUBgNVBAMMDVNNUCBzZXJ2ZXIg
Q0ExEDAOBgNVBAoMB1NpbXBsZVgwQzAFBgMrZXEDOgCAcvFwVicR+RLZpiEWPFNR
XYTbf+mFcX1NHIyPQDugFwOCgqJAW1fsjYgFhtQJSMH/lc1N7clfm4CjUzBRMB0G
A1UdDgQWBBQcUJvR7mm26yxMQfCsWgbnwMmJVDAfBgNVHSMEGDAWgBQcUJvR7mm2
6yxMQfCsWgbnwMmJVDAPBgNVHRMBAf8EBTADAQH/MAUGAytlcQNzAAAP/hMPNxyW
fyJi+iJViodU+C/aklnvHtjh5P3AbiVCSUfY6+PEdvkC8Ov0pBAYpYi5ukSNNVXl
ABVRlipB+vOcLQStNyaZ7kXzQ2IO/0btmIidh+G6SP8I4aytYIYYcV5pEUZpG1L1
57g8P29SDv81AA==
-----END CERTIFICATE-----
+52
View File
@@ -0,0 +1,52 @@
-----BEGIN PRIVATE KEY-----
MIIJQwIBADANBgkqhkiG9w0BAQEFAASCCS0wggkpAgEAAoICAQCwefW/KMsT+WLV
yNZHpgcyVD7dMSzf05s3bpdvNw4WzQiVfnlJ+Hzc/j44kUvxdr2S291lyJz4t23O
e4cNmLveKOzFx+Q01pGrmzatG1dCqIte82QUgjjqvjGzze21E9bDsDh2nS4dyFk3
5M/RLn6MA4r6cpjSlm3gBzF5V7ASZx3x7jNOTFpT/Oz0x3dw+2EJpoGyEoBBhuBn
IVgap5wscYDjmtPX/5/oFiRWzd4ZG1WSjBKU+YLvVlrIL/QQ4Sc3AUsNdzDM9LAc
sWCs4cEASYpBc/tegLbWdHHKA2lsGo2cyvPsnxb/U92/JFpoqB4tncNrwYEqL3u/
JYlKmArDlAbeTDZNz9N+yoEiT3aems7Bd2zCpj7LBIU/bxzD4EpIgX5gZSe3U00X
fXYf3CyiDgDM7uDvqRKHSDiQ10wEQROlV9aqBGULn7efpY1cuIvckqZh55MS6HBe
NKyldRtHOS51TU7a+RqJAvbHyF2T2cNBBKZN3gLHjVnHMLskXx0Hy+so3A4oNiHS
7y1XJvScgNj+UKT9eRKANzsPbl/B5gW0hXtRd+a6nDcGNJYQ1xG6EgP1+MQy57uG
lYTT4lJ0ajV6lZYM+cm0QFB3fHwwcCvH0+VYb7hJwo2u/vIVXN94Cuer7vtvGTJD
dmOM9BjUHYmpj1GSZVHAiczSNnM9uwIDAQABAoICAAIOOHg0nO85RMTNItpjgeYY
P0HGvIAk63rX4dqss9lhbQBie9B4HPzIjjEfMv13qj5VBtimllYNTXrEuSUzeCi6
E7vyTpo+qv/YEHtUadb/2tzfe1BxjdyX0vfz+CtXbAeefH1O6mGrI/Uuo3Xmpc9p
jJSmpg/DBl53Amm6xWLk6rq7dcNiWrfZS0T9xYFQmx7RlZwmct/ZqR56Zrw942ff
Hkts9psniyeiHBr2cnpRrEJry69T0q6JIeP+5doWewCqzPl+9rMyKiT6RV3uJKpu
Z7ZavthNl6Xj+FTDHdcGJ0v5Bg/llQ8Qb6f/FsLImM6IgBwlj4AXXMiP1SboolEo
TDgt4DE0sd7o5ZU+5gjI2E9l1JLk68Rh64YIY1pr7CDURkWYwGyR3Bs9mG3RVKZr
ANl08YeqtTH8LnqASJyKq6+xthDSCRbEP6uFM/Y5jjjbCWXELtaWqRYo1esHjPU2
OfVI8tE13+ewLhjCUvarf9TA4Edkut7celuNgPsm58+cA5FSQiuuGrR6RoeOCYEd
a9knZQriLebcHT8ifh1SfbuElhSMiSTUReEXzOEjs9+/kZ8BEQWWmspGVq/RiOoj
jtPrDE11wqRjjK2SjLwFQ0NlHo+sUGxH7IJMVOHONcaFde87KTggjFr2HJgOtkYe
zii/I6bVCH6IxKZ3jBqlAoIBAQD085iZEgp1uoXqnlNgL49qy8a2Zev5B3mQjS61
1+LYurIKm2TnWFdUyrqOyY9EQ5mj7LbtntcIseW5gNPqHF9F8UQ3NfU1uXiKpBGF
dLi/NGPPOoeep4GOOo7+TFluwPQILB7UPoLrU+cNcNt6V5FMKkRaANb/nxxPdWWS
UPpCU2zoRNoeGEvXU3yPlhMJcCWYc6wP6YXClqrUsUmcX0x1MPY54ad18jxjR1P9
msemV98tqI9/utjuL0sOIZKlfR225Bj3RQ6u1dPqwPaWVcXH+I4za/SYnJ8Ivrz4
hokIHUPHbC1C/+wfVQhLU5Z9fT061IHKwmVX1NRC0aYdxm0tAoIBAQC4b7IiEcRW
BgmBRM4/BgKCHoqZwEojZozYTBzsEQinRY5spfEow+ONUFYubnr4rDOHVTUMHStm
GEvRfZyGMU7Xp0BkbVyMrrUCGhOLtIL7qLsN1ZryUGuZzFO0u7Q8lvYRKiuHtq1v
QVqFzOVut+Wa0e//RCStrGlex6ZXpGrHf6EISc2jeDeLTcVcQkLY6pQoMtMFkjJi
7l671AUA5ISqCiJv9DbL2XItZGw1N9zXXy4tLJGr4gOyX0+JE9FFyTUaC5Yeu8FO
0qxop1hW/ekEYISMJtEvigphAhv5hShEUp5+ZqNcnUxj5FejFDfBi6sHT9vmcNwA
RoYkzuvtpzeHAoIBACp0mitVvChhltpubKcMN0BcZ2mvyrGUARbz0XfFHlVQLpG2
E0whvKk+pg0flExRpyyJV79hu4WPR/DaCmDWYBEAW0Fygbi5F9J3022dKHRDgVUm
oOD3yXW8YpJi61FN8j4EX6eL2ictmKt0tyXCTbW00boD0T/m9QI0p9EvZeDfEs5D
OMbkkSiWGM3ORihpnqqIyfbME9oBQUSyIb8PqXHadaLcoKjJvnu6ni0jiZ0kN9Nz
FsQdv4GxAsJFQWSbhe3wJP+eoYfeGefjYBn4bdpWE1eIS5Gz+8CJRrmQn+mfIONM
tZ+aOfPISjK8HyZK8bTjpkddYDFT+yJFshQRE1UCggEBAJC7rllIAf/Tqv/TY9pX
N/6uQuvW1xcisaJHUGb8EwNY9SRTsITh/B74DTlQn5WnZKRt/DvuZBExPcY+wWcZ
KJrY+BIXNAp+SzNEDVSTqjoctfVsS7Sd4WKG0qVAq3bkrGLZ6eENPNrSuVvIZ79T
9o1g8+ooqnPTmbi0Cdg7AURe5pqfeA0xGL1roVX99YFNzEgjYi+8A2hZUOQqxGZn
7aeWXmHmjl233P68EKJOnTIx0gXHNOVibq46Vyrl71LJS6+NqheiFVdqwbs6n3tc
s9AogbuN9phMxkpMInHTyb6b6x6cItRZ6Al3tkIWao6qsOMDCziyFiLtNPWLn98W
Wt8CggEBAPNpzv2HT1BkDOvWzPxKtKZg9dDRoPi12N2jVLoGqnrHf8r3+oqOYcHs
zsi1QgXsGoTHFGJZZ9Op5FSlcffTKiIb9IJESfkSjp7njSvYeiKyTkYzlb/N42qy
qgIph91xrT35NEMJQIvHX0wEFaJZ2BDdVRXgUo6cwhBJp5JjwQTwZ3msqCVC6wBk
iJGL46LAE7/6YalcwlvBxMudW+NrZ8TRnzEOBMzgHf5K8e6sGfhllspCG0HmzyBX
euEfBjGykCmlNTs55/p/4aXBY8ydJQK7o8aBlEgL3EYqoDTyq8kSar6O35rnXpP8
mPykG5ZK8mWK1XSXXze7YGNUW1TjtmY=
-----END PRIVATE KEY-----