mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-01 18:08:36 +00:00
Compare commits
13
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
04e4a37d85 | ||
|
|
0ba3e69872 | ||
|
|
2ab0c2a7c6 | ||
|
|
243548631a | ||
|
|
da79d544cf | ||
|
|
e808825c95 | ||
|
|
a9576935cf | ||
|
|
9cf6c97137 | ||
|
|
0739f7b702 | ||
|
|
e12710fa55 | ||
|
|
2a120dfe57 | ||
|
|
3c18c4b66a | ||
|
|
21eee2b548 |
@@ -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
|
||||
|
||||
@@ -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>
|
||||
|
||||
@@ -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} =
|
||||
|
||||
@@ -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
@@ -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
|
||||
|
||||
@@ -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
@@ -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.*
|
||||
|
||||
@@ -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
|
||||
}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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);
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -76,7 +76,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
|
||||
defaultSMPClientAgentConfig :: SMPClientAgentConfig
|
||||
defaultSMPClientAgentConfig =
|
||||
SMPClientAgentConfig
|
||||
{ smpCfg = defaultSMPClientConfig {defaultTransport = ("5223", transport @TLS)},
|
||||
{ smpCfg = defaultSMPClientConfig,
|
||||
reconnectInterval =
|
||||
RetryInterval
|
||||
{ initialInterval = second,
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 ())
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
@@ -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
|
||||
|
||||
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
|
||||
}
|
||||
|
||||
|
||||
Vendored
+34
@@ -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-----
|
||||
Vendored
+52
@@ -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-----
|
||||
Reference in New Issue
Block a user