dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-03-31 22:46:27 +00:00
Code Issues Packages Projects Releases Wiki Activity

servers: fix server pages when source code is not specified, include commit SHA in printed version and in web page. (#1608)

Browse Source 
* smp server: fix server pages when source code is not specified

* servers: include git commit in version

* flexible alpn

* fix test

* fix ghc 8.10.7 build
This commit is contained in:
Evgeny
2025-08-23 19:59:00 +01:00
committed by GitHub
parent a2d35281b2
commit e48bedeaf2
20 changed files with 124 additions and 61 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
apps/smp-server/static/index.html
View File

@@ -223,11 +223,14 @@
<table id="public-info"> <table id="public-info">
<tr class="text-grey-black dark:text-white text-base"> <tr class="text-grey-black dark:text-white text-base">
<td>Server version:</td> <td>Server version:</td>
<td>${version}</td> <td>${version}<x-commit> / <a href="${commitSourceCode}/commit/${commit}" target="_blank">${shortCommit}</a></x-commit></td>
</tr> </tr>
<tr class="text-grey-black dark:text-white text-base"> <tr class="text-grey-black dark:text-white text-base">
<td>Source code:</td> <td>Source code:</td>
<td><a href="${sourceCode}" target="_blank">${sourceCode}</a></td> <td>
<x-sourceCode><a href="${sourceCode}" target="_blank">${sourceCode}</a></x-sourceCode>
<x-noSourceCode>add to smp-server.ini (required by <a href="https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE" target="_blank">AGPLv3</a>)</x-noSourceCode>
</td>
</tr> </tr>
<x-website> <x-website>
<tr class="text-grey-black dark:text-white text-base"> <tr class="text-grey-black dark:text-white text-base">

20
apps/smp-server/web/Static.hs
View File

@@ -12,6 +12,7 @@ import Data.Char (toUpper)
import Data.IORef (readIORef) import Data.IORef (readIORef)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.String (fromString) import Data.String (fromString)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Network.Socket (getPeerName) import Network.Socket (getPeerName)
import Network.Wai (Application, Request (..)) import Network.Wai (Application, Request (..))
@@ -22,8 +23,9 @@ import qualified Network.Wai.Handler.Warp.Internal as WI
import qualified Network.Wai.Handler.WarpTLS as WT import qualified Network.Wai.Handler.WarpTLS as WT
import Simplex.Messaging.Encoding.String (strEncode) import Simplex.Messaging.Encoding.String (strEncode)
import Simplex.Messaging.Server (AttachHTTP) import Simplex.Messaging.Server (AttachHTTP)
import Simplex.Messaging.Server.CLI (simplexmqCommit)
import Simplex.Messaging.Server.Information import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.Main (EmbeddedWebParams (..), WebHttpsParams (..)) import Simplex.Messaging.Server.Main (EmbeddedWebParams (..), WebHttpsParams (..), simplexmqSource)
import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport (simplexMQVersion)
import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Util (tshow) import Simplex.Messaging.Util (tshow)
@@ -117,7 +119,7 @@ generateSite si onionHost sitePath = do
serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString
serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs
where where
substs = substConfig <> maybe [] substInfo information <> [("onionHost", strEncode <$> onionHost)] substs = substConfig <> substInfo <> [("onionHost", strEncode <$> onionHost)]
substConfig = substConfig =
[ ( "persistence", [ ( "persistence",
Just $ case persistence config of Just $ case persistence config of
@@ -132,7 +134,7 @@ serverInformation ServerInformation {config, information} onionHost = render E.i
] ]
yesNo True = "Yes" yesNo True = "Yes"
yesNo False = "No" yesNo False = "No"
substInfo spi = substInfo =
concat concat
[ basic, [ basic,
maybe [("usageConditions", Nothing), ("usageAmendments", Nothing)] conds (usageConditions spi), maybe [("usageConditions", Nothing), ("usageAmendments", Nothing)] conds (usageConditions spi),
@@ -144,10 +146,16 @@ serverInformation ServerInformation {config, information} onionHost = render E.i
] ]
where where
basic = basic =
[ ("sourceCode", Just . encodeUtf8 $ sourceCode spi), [ ("sourceCode", if T.null sc then Nothing else Just (encodeUtf8 sc)),
("noSourceCode", if T.null sc then Just "none" else Nothing),
("version", Just $ B.pack simplexMQVersion), ("version", Just $ B.pack simplexMQVersion),
("commitSourceCode", Just $ encodeUtf8 $ maybe (T.pack simplexmqSource) sourceCode information),
("shortCommit", Just $ B.pack $ take 7 simplexmqCommit),
("commit", Just $ B.pack simplexmqCommit),
("website", encodeUtf8 <$> website spi) ("website", encodeUtf8 <$> website spi)
] ]
spi = fromMaybe (emptyServerInfo "") information
sc = sourceCode spi
conds ServerConditions {conditions, amendments} = conds ServerConditions {conditions, amendments} =
[ ("usageConditions", Just $ encodeUtf8 conditions), [ ("usageConditions", Just $ encodeUtf8 conditions),
("usageAmendments", encodeUtf8 <$> amendments) ("usageAmendments", encodeUtf8 <$> amendments)
@@ -229,8 +237,8 @@ section_ label content' src =
(inside, next') -> (inside, next') ->
let next = B.drop (B.length endMarker) next' let next = B.drop (B.length endMarker) next'
in case content' of in case content' of
Nothing -> before <> next -- collapse section Just content | not (B.null content) -> before <> item_ label content inside <> section_ label content' next
Just content -> before <> item_ label content inside <> section_ label content' next _ -> before <> next -- collapse section
where where
startMarker = "<x-" <> label <> ">" startMarker = "<x-" <> label <> ">"
endMarker = "</x-" <> label <> ">" endMarker = "</x-" <> label <> ">"

3
simplexmq.cabal
View File

@@ -234,6 +234,7 @@ library
Simplex.Messaging.Server.Env.STM Simplex.Messaging.Server.Env.STM
Simplex.Messaging.Server.Information Simplex.Messaging.Server.Information
Simplex.Messaging.Server.Main Simplex.Messaging.Server.Main
Simplex.Messaging.Server.Main.GitCommit
Simplex.Messaging.Server.Main.Init Simplex.Messaging.Server.Main.Init
Simplex.Messaging.Server.MsgStore Simplex.Messaging.Server.MsgStore
Simplex.Messaging.Server.MsgStore.Journal Simplex.Messaging.Server.MsgStore.Journal
@@ -354,10 +355,12 @@ library
if impl(ghc >= 9.6.2) if impl(ghc >= 9.6.2)
build-depends: build-depends:
bytestring ==0.11.* bytestring ==0.11.*
, template-haskell ==2.20.*
, text >=2.0.1 && <2.2 , text >=2.0.1 && <2.2
if impl(ghc < 9.6.2) if impl(ghc < 9.6.2)
build-depends: build-depends:
bytestring ==0.10.* bytestring ==0.10.*
, template-haskell ==2.16.*
, text >=1.2.3.0 && <1.3 , text >=1.2.3.0 && <1.3
executable ntf-server executable ntf-server

12
src/Simplex/FileTransfer/Client.hs
View File

@@ -31,6 +31,7 @@ import qualified Data.X509 as X
import qualified Data.X509.Validation as XV import qualified Data.X509.Validation as XV
import qualified Network.HTTP.Types as N import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Client as H import qualified Network.HTTP2.Client as H
import Network.Socket (HostName)
import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Chunks
import Simplex.FileTransfer.Protocol import Simplex.FileTransfer.Protocol
import Simplex.FileTransfer.Transport import Simplex.FileTransfer.Transport
@@ -45,6 +46,7 @@ import Simplex.Messaging.Client
transportClientConfig, transportClientConfig,
clientSocksCredentials, clientSocksCredentials,
unexpectedResponse, unexpectedResponse,
useWebPort,
) )
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC import qualified Simplex.Messaging.Crypto.Lazy as LC
@@ -104,12 +106,13 @@ defaultXFTPClientConfig =
clientALPN = Just alpnSupportedXFTPhandshakes clientALPN = Just alpnSupportedXFTPhandshakes
} }
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} proxySessTs disconnected = runExceptT $ do getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs disconnected = runExceptT $ do
let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
ProtocolServer _ host port keyHash = srv ProtocolServer _ host port keyHash = srv
useALPN = if useWebPort xftpNetworkConfig presetDomains srv then Just [httpALPN11] else clientALPN
useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False clientALPN let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False useALPN
http2Config = xftpHTTP2Config tcConfig config http2Config = xftpHTTP2Config tcConfig config
clientVar <- newTVarIO Nothing clientVar <- newTVarIO Nothing
let usePort = if null port then "443" else port let usePort = if null port then "443" else port
@@ -121,7 +124,8 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False} thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False}
logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
thParams@THandleParams {thVersion} <- case sessionALPN of thParams@THandleParams {thVersion} <- case sessionALPN of
Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0 Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
_ -> pure thParams0 _ -> pure thParams0
logDebug $ "Client negotiated protocol: " <> tshow thVersion logDebug $ "Client negotiated protocol: " <> tshow thVersion
let c = XFTPClient {http2Client, thParams, transportSession, config} let c = XFTPClient {http2Client, thParams, transportSession, config}

2
src/Simplex/FileTransfer/Client/Agent.hs
View File

@@ -71,7 +71,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
connectClient = connectClient =
ExceptT $ ExceptT $
first (XFTPClientAgentError srv) first (XFTPClientAgentError srv)
<$> getXFTPClient (1, srv, Nothing) (xftpConfig config) startedAt clientDisconnected <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) [] startedAt clientDisconnected
clientDisconnected :: XFTPClient -> IO () clientDisconnected :: XFTPClient -> IO ()
clientDisconnected _ = do clientDisconnected _ = do

2
src/Simplex/FileTransfer/Server.hs
View File

@@ -133,7 +133,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse} req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
flip runReaderT env $ case sessionALPN of flip runReaderT env $ case sessionALPN of
Nothing -> processRequest req0 Nothing -> processRequest req0
Just "xftp/1" -> Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 ->
xftpServerHandshakeV1 chain signKey sessions req0 >>= \case xftpServerHandshakeV1 chain signKey sessions req0 >>= \case
Nothing -> pure () -- handshake response sent Nothing -> pure () -- handshake response sent
Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here) Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here)

6
src/Simplex/FileTransfer/Server/Main.hs
View File

@@ -27,8 +27,8 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer) import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (simplexMQVersion)
import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow)
import System.Directory (createDirectoryIfMissing, doesFileExist) import System.Directory (createDirectoryIfMissing, doesFileExist)
@@ -60,7 +60,7 @@ xftpServerCLI cfgPath logPath = do
putStrLn "Deleted configuration and log files" putStrLn "Deleted configuration and log files"
where where
iniFile = combine cfgPath "file-server.ini" iniFile = combine cfgPath "file-server.ini"
serverVersion = "SimpleX XFTP server v" <> simplexMQVersion serverVersion = "SimpleX XFTP server v" <> simplexmqVersionCommit
defaultServerPort = "443" defaultServerPort = "443"
executableName = "file-server" executableName = "file-server"
storeLogFilePath = combine logPath "file-server-store.log" storeLogFilePath = combine logPath "file-server-store.log"
@@ -196,7 +196,7 @@ xftpServerCLI cfgPath logPath = do
transportConfig = transportConfig =
mkTransportServerConfig mkTransportServerConfig
(fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini) (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
(Just alpnSupportedXFTPhandshakes) (Just $ alpnSupportedXFTPhandshakes <> httpALPN)
False, False,
responseDelay = 0 responseDelay = 0
} }

6
src/Simplex/FileTransfer/Transport.hs
View File

@@ -14,6 +14,7 @@ module Simplex.FileTransfer.Transport
blockedFilesXFTPVersion, blockedFilesXFTPVersion,
xftpClientHandshakeStub, xftpClientHandshakeStub,
alpnSupportedXFTPhandshakes, alpnSupportedXFTPhandshakes,
xftpALPNv1,
XFTPClientHandshake (..), XFTPClientHandshake (..),
-- xftpClientHandshake, -- xftpClientHandshake,
XFTPServerHandshake (..), XFTPServerHandshake (..),
@@ -105,7 +106,10 @@ xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> V
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer _serviceKeys = throwE TEVersion xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer _serviceKeys = throwE TEVersion
alpnSupportedXFTPhandshakes :: [ALPN] alpnSupportedXFTPhandshakes :: [ALPN]
alpnSupportedXFTPhandshakes = ["xftp/1"] alpnSupportedXFTPhandshakes = [xftpALPNv1]
xftpALPNv1 :: ALPN
xftpALPNv1 = "xftp/1"
data XFTPServerHandshake = XFTPServerHandshake data XFTPServerHandshake = XFTPServerHandshake
{ xftpVersionRange :: VersionRangeXFTP, { xftpVersionRange :: VersionRangeXFTP,

28
src/Simplex/Messaging/Agent/Client.hs
View File

@@ -330,7 +330,7 @@ data AgentClient = AgentClient
xftpServers :: TMap UserId (UserServers 'PXFTP), xftpServers :: TMap UserId (UserServers 'PXFTP),
xftpClients :: TMap XFTPTransportSession XFTPClientVar, xftpClients :: TMap XFTPTransportSession XFTPClientVar,
useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks
presetSMPDomains :: [HostName], presetDomains :: [HostName],
userNetworkInfo :: TVar UserNetworkInfo, userNetworkInfo :: TVar UserNetworkInfo,
userNetworkUpdated :: TVar (Maybe UTCTime), userNetworkUpdated :: TVar (Maybe UTCTime),
subscrConns :: TVar (Set ConnId), subscrConns :: TVar (Set ConnId),
@@ -537,7 +537,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomai
xftpServers, xftpServers,
xftpClients, xftpClients,
useNetworkConfig, useNetworkConfig,
presetSMPDomains = presetDomains, presetDomains,
userNetworkInfo, userNetworkInfo,
userNetworkUpdated, userNetworkUpdated,
subscrConns, subscrConns,
@@ -686,7 +686,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
smpConnectClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient smpConnectClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} nm tSess@(_, srv, _) prs v = smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs, presetDomains} nm tSess@(_, srv, _) prs v =
newProtocolClient c tSess smpClients connectClient v newProtocolClient c tSess smpClients connectClient v
`catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e `catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e
where where
@@ -697,7 +697,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} nm tSess@(_, srv,
env <- ask env <- ask
liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
ts <- readTVarIO proxySessTs ts <- readTVarIO proxySessTs
smp <- ExceptT $ getProtocolClient g nm tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs smp <- ExceptT $ getProtocolClient g nm tSess cfg presetDomains (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs} pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO () smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
@@ -786,7 +786,7 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd) notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
getNtfServerClient :: AgentClient -> NetworkRequestMode -> NtfTransportSession -> AM NtfClient getNtfServerClient :: AgentClient -> NetworkRequestMode -> NtfTransportSession -> AM NtfClient
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} nm tSess@(_, srv, _) = do getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs, presetDomains} nm tSess@(_, srv, _) = do
unlessM (readTVarIO active) $ throwE INACTIVE unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess ntfClients ts) atomically (getSessVar workerSeq tSess ntfClients ts)
@@ -800,7 +800,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} nm
g <- asks random g <- asks random
ts <- readTVarIO proxySessTs ts <- readTVarIO proxySessTs
liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $ liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $
getProtocolClient g nm tSess cfg [] Nothing ts $ getProtocolClient g nm tSess cfg presetDomains Nothing ts $
clientDisconnected v clientDisconnected v
clientDisconnected :: NtfClientVar -> NtfClient -> IO () clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
@@ -810,7 +810,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} nm
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs, presetDomains} tSess@(_, srv, _) = do
unlessM (readTVarIO active) $ throwE INACTIVE unlessM (readTVarIO active) $ throwE INACTIVE
ts <- liftIO getCurrentTime ts <- liftIO getCurrentTime
atomically (getSessVar workerSeq tSess xftpClients ts) atomically (getSessVar workerSeq tSess xftpClients ts)
@@ -824,7 +824,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs}
xftpNetworkConfig <- getNetworkConfig c xftpNetworkConfig <- getNetworkConfig c
ts <- readTVarIO proxySessTs ts <- readTVarIO proxySessTs
liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $ liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $
X.getXFTPClient tSess cfg {xftpNetworkConfig} ts $ X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts $
clientDisconnected v clientDisconnected v
clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
@@ -1227,7 +1227,7 @@ data ProtocolTestFailure = ProtocolTestFailure
deriving (Eq, Show) deriving (Eq, Show)
runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure) runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runSMPServerTest c nm userId (ProtoServerWithAuth srv auth) = do runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth srv auth) = do
cfg <- getClientConfig c smpCfg cfg <- getClientConfig c smpCfg
C.AuthAlg ra <- asks $ rcvAuthAlg . config C.AuthAlg ra <- asks $ rcvAuthAlg . config
C.AuthAlg sa <- asks $ sndAuthAlg . config C.AuthAlg sa <- asks $ sndAuthAlg . config
@@ -1235,7 +1235,7 @@ runSMPServerTest c nm userId (ProtoServerWithAuth srv auth) = do
liftIO $ do liftIO $ do
let tSess = (userId, srv, Nothing) let tSess = (userId, srv, Nothing)
ts <- readTVarIO $ proxySessTs c ts <- readTVarIO $ proxySessTs c
getProtocolClient g nm tSess cfg (presetSMPDomains c) Nothing ts (\_ -> pure ()) >>= \case getProtocolClient g nm tSess cfg presetDomains Nothing ts (\_ -> pure ()) >>= \case
Right smp -> do Right smp -> do
rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g
(sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
@@ -1256,7 +1256,7 @@ runSMPServerTest c nm userId (ProtoServerWithAuth srv auth) = do
testErr step = ProtocolTestFailure step . protocolClientError SMP addr testErr step = ProtocolTestFailure step . protocolClientError SMP addr
runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure) runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runXFTPServerTest c nm userId (ProtoServerWithAuth srv auth) = do runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth srv auth) = do
cfg <- asks $ xftpCfg . config cfg <- asks $ xftpCfg . config
g <- asks random g <- asks random
xftpNetworkConfig <- getNetworkConfig c xftpNetworkConfig <- getNetworkConfig c
@@ -1266,7 +1266,7 @@ runXFTPServerTest c nm userId (ProtoServerWithAuth srv auth) = do
liftIO $ do liftIO $ do
let tSess = (userId, srv, Nothing) let tSess = (userId, srv, Nothing)
ts <- readTVarIO $ proxySessTs c ts <- readTVarIO $ proxySessTs c
X.getXFTPClient tSess cfg {xftpNetworkConfig} ts (\_ -> pure ()) >>= \case X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (\_ -> pure ()) >>= \case
Right xftp -> withTestChunk filePath $ do Right xftp -> withTestChunk filePath $ do
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -1304,14 +1304,14 @@ runXFTPServerTest c nm userId (ProtoServerWithAuth srv auth) = do
createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom
runNTFServerTest :: AgentClient -> NetworkRequestMode -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure) runNTFServerTest :: AgentClient -> NetworkRequestMode -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure)
runNTFServerTest c nm userId (ProtoServerWithAuth srv _) = do runNTFServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth srv _) = do
cfg <- getClientConfig c ntfCfg cfg <- getClientConfig c ntfCfg
C.AuthAlg a <- asks $ rcvAuthAlg . config C.AuthAlg a <- asks $ rcvAuthAlg . config
g <- asks random g <- asks random
liftIO $ do liftIO $ do
let tSess = (userId, srv, Nothing) let tSess = (userId, srv, Nothing)
ts <- readTVarIO $ proxySessTs c ts <- readTVarIO $ proxySessTs c
getProtocolClient g nm tSess cfg [] Nothing ts (\_ -> pure ()) >>= \case getProtocolClient g nm tSess cfg presetDomains Nothing ts (\_ -> pure ()) >>= \case
Right ntf -> do Right ntf -> do
(nKey, npKey) <- atomically $ C.generateAuthKeyPair a g (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
(dhKey, _) <- atomically $ C.generateKeyPair g (dhKey, _) <- atomically $ C.generateKeyPair g

28
src/Simplex/Messaging/Client.hs
View File

@@ -38,6 +38,7 @@ module Simplex.Messaging.Client
protocolClientServer', protocolClientServer',
transportHost', transportHost',
transportSession', transportSession',
useWebPort,
-- * SMP protocol command functions -- * SMP protocol command functions
createSMPQueue, createSMPQueue,
@@ -160,6 +161,7 @@ import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, runTransportClient) import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, runTransportClient)
import Simplex.Messaging.Transport.HTTP2 (httpALPN11)
import Simplex.Messaging.Transport.KeepAlive import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Util import Simplex.Messaging.Util
import Simplex.Messaging.Version import Simplex.Messaging.Version
@@ -560,7 +562,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
Left e -> pure $ Left e Left e -> pure $ Left e
where where
NetworkConfig {smpWebPortServers, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg) mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg)
mkProtocolClient transportHost ts = do mkProtocolClient transportHost ts = do
connected <- newTVarIO False connected <- newTVarIO False
@@ -591,7 +593,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
runClient (port', ATransport t) useHost c = do runClient (port', ATransport t) useHost c = do
cVar <- newEmptyTMVarIO cVar <- newEmptyTMVarIO
let tcConfig = (transportClientConfig networkConfig nm useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials} let tcConfig = (transportClientConfig networkConfig nm useHost useSNI useALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
tId <- tId <-
runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar) runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
@@ -605,16 +607,14 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
useTransport :: (ServiceName, ATransport 'TClient) useTransport :: (ServiceName, ATransport 'TClient)
useTransport = case port srv of useTransport = case port srv of
"" -> case protocolTypeI @(ProtoType msg) of "" -> case protocolTypeI @(ProtoType msg) of
SPSMP | smpWebPort -> ("443", transport @TLS) SPSMP | web -> ("443", transport @TLS)
_ -> defaultTransport cfg _ -> defaultTransport cfg
p -> (p, transport @TLS) p -> (p, transport @TLS)
where
smpWebPort = case smpWebPortServers of useALPN :: Maybe [ALPN]
SWPAll -> True useALPN = if web then Just [httpALPN11] else clientALPN
SWPPreset -> case srv of
ProtocolServer {host = THDomainName h :| _} -> any (`isSuffixOf` h) presetDomains web = useWebPort networkConfig presetDomains srv
_ -> False
SWPOff -> False
client :: forall c. Transport c => TProxy c 'TClient -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c 'TClient -> IO () client :: forall c. Transport c => TProxy c 'TClient -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c 'TClient -> IO ()
client _ c cVar h = do client _ c cVar h = do
@@ -709,6 +709,14 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
Left e -> logError $ "SMP client error: " <> tshow e Left e -> logError $ "SMP client error: " <> tshow e
Right _ -> logWarn "SMP client unprocessed event" Right _ -> logWarn "SMP client unprocessed event"
useWebPort :: NetworkConfig -> [HostName] -> ProtocolServer p -> Bool
useWebPort cfg presetDomains srv = case smpWebPortServers cfg of
SWPAll -> True
SWPPreset -> case srv of
ProtocolServer {host = THDomainName h :| _} -> any (`isSuffixOf` h) presetDomains
_ -> False
SWPOff -> False
unexpectedResponse :: Show r => r -> ProtocolClientError err unexpectedResponse :: Show r => r -> ProtocolClientError err
unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show

7
src/Simplex/Messaging/Notifications/Server/Main.hs
View File

@@ -46,8 +46,9 @@ import Simplex.Messaging.Server.Main (strParse)
import Simplex.Messaging.Server.Main.Init (iniDbOpts) import Simplex.Messaging.Server.Main.Init (iniDbOpts)
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
import Simplex.Messaging.Server.StoreLog (closeStoreLog) import Simplex.Messaging.Server.StoreLog (closeStoreLog)
import Simplex.Messaging.Transport (ASrvTransport, simplexMQVersion) import Simplex.Messaging.Transport (ASrvTransport)
import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), mkTransportServerConfig)
import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow) import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow)
import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile) import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)
@@ -136,7 +137,7 @@ ntfServerCLI cfgPath logPath =
(putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure) (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
iniFile = combine cfgPath "ntf-server.ini" iniFile = combine cfgPath "ntf-server.ini"
serverVersion = "SMP notifications server v" <> simplexMQVersion serverVersion = "SMP notifications server v" <> simplexmqVersionCommit
defaultServerPort = "443" defaultServerPort = "443"
executableName = "ntf-server" executableName = "ntf-server"
storeLogFilePath = combine logPath "ntf-server-store.log" storeLogFilePath = combine logPath "ntf-server-store.log"
@@ -283,7 +284,7 @@ ntfServerCLI cfgPath logPath =
transportConfig = transportConfig =
mkTransportServerConfig mkTransportServerConfig
(fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini) (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
(Just alpnSupportedNTFHandshakes) (Just $ alpnSupportedNTFHandshakes <> httpALPN)
False, False,
startOptions startOptions
} }

5
src/Simplex/Messaging/Server.hs
View File

@@ -203,15 +203,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
env <- ask env <- ask
liftIO $ case (httpCreds_, attachHTTP_) of liftIO $ case (httpCreds_, attachHTTP_) of
(Just httpCreds, Just attachHTTP) | addHTTP -> (Just httpCreds, Just attachHTTP) | addHTTP ->
runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg {serverALPN = Just combinedALPNs} $ \s (sniUsed, h) -> runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg $ \s (sniUsed, h) ->
case cast h of case cast h of
Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> labelMyThread "https client" >> attachHTTP s tlsContext Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> labelMyThread "https client" >> attachHTTP s tlsContext
_ -> runClient srvCert srvSignKey t h `runReaderT` env _ -> runClient srvCert srvSignKey t h `runReaderT` env
where where
combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds} combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds}
combinedALPNs = alpnSupportedSMPHandshakes <> httpALPN
httpALPN :: [ALPN]
httpALPN = ["h2", "http/1.1"]
_ -> _ ->
runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env

10
src/Simplex/Messaging/Server/CLI.hs
View File

@@ -7,6 +7,7 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
@@ -33,8 +34,9 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), StorePaths (..)) import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), StorePaths (..))
import Simplex.Messaging.Server.Main.GitCommit
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..), simplexMQVersion)
import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint) import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
import Simplex.Messaging.Transport.WebSockets (WS) import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (eitherToMaybe, whenM) import Simplex.Messaging.Util (eitherToMaybe, whenM)
@@ -97,6 +99,12 @@ getCliCommand' cmdP version =
where where
versionOption = infoOption version (long "version" <> short 'v' <> help "Show version") versionOption = infoOption version (long "version" <> short 'v' <> help "Show version")
simplexmqVersionCommit :: String
simplexmqVersionCommit = simplexMQVersion <> " / " <> take 7 simplexmqCommit
simplexmqCommit :: String
simplexmqCommit = $(gitCommit)
createServerX509 :: FilePath -> X509Config -> IO ByteString createServerX509 :: FilePath -> X509Config -> IO ByteString
createServerX509 = createServerX509_ True createServerX509 = createServerX509_ True

9
src/Simplex/Messaging/Server/Main.hs
View File

@@ -56,8 +56,9 @@ import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCf
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore) import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
import Simplex.Messaging.Server.QueueStore.Postgres.Config import Simplex.Messaging.Server.QueueStore.Postgres.Config
import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore) import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
import Simplex.Messaging.Transport (simplexMQVersion, supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy) import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
import Simplex.Messaging.Util (eitherToMaybe, ifM) import Simplex.Messaging.Util (eitherToMaybe, ifM)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
@@ -234,7 +235,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
(putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure) (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
iniFile = combine cfgPath "smp-server.ini" iniFile = combine cfgPath "smp-server.ini"
serverVersion = "SMP server v" <> simplexMQVersion serverVersion = "SMP server v" <> simplexmqVersionCommit
executableName = "smp-server" executableName = "smp-server"
storeLogFilePath = combine logPath "smp-server-store.log" storeLogFilePath = combine logPath "smp-server-store.log"
storeMsgsFilePath = combine logPath "smp-server-messages.log" storeMsgsFilePath = combine logPath "smp-server-messages.log"
@@ -450,7 +451,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
transportConfig = transportConfig =
mkTransportServerConfig mkTransportServerConfig
(fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini) (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini)
(Just alpnSupportedSMPHandshakes) (Just $ alpnSupportedSMPHandshakes <> httpALPN)
(fromMaybe True $ iniOnOff "TRANSPORT" "accept_service_credentials" ini), -- TODO [certs] remove this option (fromMaybe True $ iniOnOff "TRANSPORT" "accept_service_credentials" ini), -- TODO [certs] remove this option
controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini, controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini,
smpAgentCfg = smpAgentCfg =
@@ -808,7 +809,7 @@ cliCommandP cfgPath logPath iniFile =
sourceCode = T.pack <$> sourceCode, sourceCode = T.pack <$> sourceCode,
serverInfo = serverInfo =
ServerPublicInfo ServerPublicInfo
{ sourceCode = T.pack simplexmqSource, { sourceCode = T.pack $ fromMaybe simplexmqSource sourceCode,
usageConditions = Nothing, usageConditions = Nothing,
operator = fst operator_, operator = fst operator_,
website, website,

17
src/Simplex/Messaging/Server/Main/GitCommit.hs Normal file
View File

@@ -0,0 +1,17 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Messaging.Server.Main.GitCommit where
import Language.Haskell.TH
import System.Process
import Control.Exception
import System.Exit
gitCommit :: Q Exp
gitCommit = stringE . commit =<< runIO (try $ readProcessWithExitCode "git" ["rev-parse", "HEAD"] "")
where
commit :: Either SomeException (ExitCode, String, String) -> String
commit = \case
Right (ExitSuccess, out, _) -> take 40 out
_ -> ""

9
src/Simplex/Messaging/Transport/HTTP2.hs
View File

@@ -1,4 +1,5 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Transport.HTTP2 where module Simplex.Messaging.Transport.HTTP2 where
@@ -15,7 +16,7 @@ import qualified Network.HTTP2.Server as HS
import Network.Socket (SockAddr (..)) import Network.Socket (SockAddr (..))
import qualified Network.TLS as T import qualified Network.TLS as T
import qualified Network.TLS.Extra as TE import qualified Network.TLS.Extra as TE
import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut)) import Simplex.Messaging.Transport (ALPN, TLS, Transport (cGet, cPut))
import Simplex.Messaging.Transport.Buffer import Simplex.Messaging.Transport.Buffer
import qualified System.TimeManager as TI import qualified System.TimeManager as TI
@@ -81,3 +82,9 @@ getHTTP2Body r n = do
-- TODO check bodySize once it is set -- TODO check bodySize once it is set
bodyPart = if B.length bodyHead == n then Just getPart else Nothing bodyPart = if B.length bodyHead == n then Just getPart else Nothing
pure HTTP2Body {bodyHead, bodySize, bodyPart, bodyBuffer} pure HTTP2Body {bodyHead, bodySize, bodyPart, bodyBuffer}
httpALPN :: [ALPN]
httpALPN = ["h2", "http/1.1"]
httpALPN11 :: ALPN
httpALPN11 = "http/1.1"

1
tests/AgentTests/ServerChoice.hs
View File

@@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}

9
tests/CLITests.hs
View File

@@ -23,8 +23,9 @@ import qualified Network.HTTP.Client as H1
import qualified Network.HTTP2.Client as H2 import qualified Network.HTTP2.Client as H2
import Simplex.FileTransfer.Server.Main (xftpServerCLI) import Simplex.FileTransfer.Server.Main (xftpServerCLI)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Server.CLI (simplexmqVersionCommit)
import Simplex.Messaging.Server.Main (smpServerCLI, smpServerCLI_) import Simplex.Messaging.Server.Main (smpServerCLI, smpServerCLI_)
import Simplex.Messaging.Transport (TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS, simplexMQVersion, supportedClientSMPRelayVRange) import Simplex.Messaging.Transport (TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS, supportedClientSMPRelayVRange)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTLSTransportClient, smpClientHandshake) import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTLSTransportClient, smpClientHandshake)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..)) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
import qualified Simplex.Messaging.Transport.HTTP2.Client as HC import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
@@ -108,7 +109,7 @@ smpServerTest storeLog basicAuth = do
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True
-- start -- start
r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ())) r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
r `shouldContain` ["SMP server v" <> simplexMQVersion] r `shouldContain` ["SMP server v" <> simplexmqVersionCommit]
r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."]) r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."])
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` ["Serving SMP protocol on port 5223 (TLS)...", "Serving SMP protocol on port 443 (TLS)...", "Serving static site on port 443 (TLS)..."]
r `shouldContain` ["expiring clients inactive for 21600 seconds every 3600 seconds"] r `shouldContain` ["expiring clients inactive for 21600 seconds every 3600 seconds"]
@@ -216,7 +217,7 @@ ntfServerTest storeLog = do
lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off" lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True
r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ())) r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ()))
r `shouldContain` ["SMP notifications server v" <> simplexMQVersion] r `shouldContain` ["SMP notifications server v" <> simplexmqVersionCommit]
r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."]) r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."])
r `shouldContain` ["Serving NTF protocol on port 443 (TLS)..."] r `shouldContain` ["Serving NTF protocol on port 443 (TLS)..."]
capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath) capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath)
@@ -234,7 +235,7 @@ xftpServerTest storeLog = do
lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443" lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443"
doesFileExist (fileCfgPath <> "/ca.key") `shouldReturn` True doesFileExist (fileCfgPath <> "/ca.key") `shouldReturn` True
r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` xftpServerCLI fileCfgPath fileLogPath) `catchAll_` pure (Just ())) r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` xftpServerCLI fileCfgPath fileLogPath) `catchAll_` pure (Just ()))
r `shouldContain` ["SimpleX XFTP server v" <> simplexMQVersion] r `shouldContain` ["SimpleX XFTP server v" <> simplexmqVersionCommit]
r `shouldContain` (if storeLog then ["Store log: " <> fileLogPath <> "/file-server-store.log"] else ["Store log disabled."]) r `shouldContain` (if storeLog then ["Store log: " <> fileLogPath <> "/file-server-store.log"] else ["Store log disabled."])
r `shouldContain` ["Listening on port 443..."] r `shouldContain` ["Listening on port 443..."]
capture_ (withStdin "Y" . withArgs ["delete"] $ xftpServerCLI fileCfgPath fileLogPath) capture_ (withStdin "Y" . withArgs ["delete"] $ xftpServerCLI fileCfgPath fileLogPath)

2
tests/XFTPClient.hs
View File

@@ -145,6 +145,6 @@ testXFTPClient = testXFTPClientWith testXFTPClientConfig
testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClientWith cfg client = do testXFTPClientWith cfg client = do
ts <- getCurrentTime ts <- getCurrentTime
getXFTPClient (1, testXFTPServer, Nothing) cfg ts (\_ -> pure ()) >>= \case getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure ()) >>= \case
Right c -> client c Right c -> client c
Left e -> error $ show e Left e -> error $ show e

2
tests/XFTPServerTests.hs
View File

@@ -223,7 +223,7 @@ testInactiveClientExpiration :: Expectation
testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do
disconnected <- newEmptyTMVarIO disconnected <- newEmptyTMVarIO
ts <- liftIO getCurrentTime ts <- liftIO getCurrentTime
c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig ts (\_ -> atomically $ putTMVar disconnected ()) c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig [] ts (\_ -> atomically $ putTMVar disconnected ())
pingXFTP c pingXFTP c
liftIO $ do liftIO $ do
threadDelay 100000 threadDelay 100000