diff --git a/apps/smp-server/static/index.html b/apps/smp-server/static/index.html index 68ac6d906..a66cd7988 100644 --- a/apps/smp-server/static/index.html +++ b/apps/smp-server/static/index.html @@ -223,11 +223,14 @@ - + - + diff --git a/apps/smp-server/web/Static.hs b/apps/smp-server/web/Static.hs index dc8f24ec9..cf6d5834b 100644 --- a/apps/smp-server/web/Static.hs +++ b/apps/smp-server/web/Static.hs @@ -12,6 +12,7 @@ import Data.Char (toUpper) import Data.IORef (readIORef) import Data.Maybe (fromMaybe) import Data.String (fromString) +import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Network.Socket (getPeerName) 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 Simplex.Messaging.Encoding.String (strEncode) import Simplex.Messaging.Server (AttachHTTP) +import Simplex.Messaging.Server.CLI (simplexmqCommit) 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.Client (TransportHost (..)) import Simplex.Messaging.Util (tshow) @@ -117,7 +119,7 @@ generateSite si onionHost sitePath = do serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs where - substs = substConfig <> maybe [] substInfo information <> [("onionHost", strEncode <$> onionHost)] + substs = substConfig <> substInfo <> [("onionHost", strEncode <$> onionHost)] substConfig = [ ( "persistence", Just $ case persistence config of @@ -132,7 +134,7 @@ serverInformation ServerInformation {config, information} onionHost = render E.i ] yesNo True = "Yes" yesNo False = "No" - substInfo spi = + substInfo = concat [ basic, maybe [("usageConditions", Nothing), ("usageAmendments", Nothing)] conds (usageConditions spi), @@ -144,10 +146,16 @@ serverInformation ServerInformation {config, information} onionHost = render E.i ] where 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), + ("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) ] + spi = fromMaybe (emptyServerInfo "") information + sc = sourceCode spi conds ServerConditions {conditions, amendments} = [ ("usageConditions", Just $ encodeUtf8 conditions), ("usageAmendments", encodeUtf8 <$> amendments) @@ -229,8 +237,8 @@ section_ label content' src = (inside, next') -> let next = B.drop (B.length endMarker) next' in case content' of - Nothing -> before <> next -- collapse section - Just content -> before <> item_ label content inside <> section_ label content' next + Just content | not (B.null content) -> before <> item_ label content inside <> section_ label content' next + _ -> before <> next -- collapse section where startMarker = " label <> ">" endMarker = " label <> ">" diff --git a/simplexmq.cabal b/simplexmq.cabal index 145c94516..1c75b162c 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -234,6 +234,7 @@ library Simplex.Messaging.Server.Env.STM Simplex.Messaging.Server.Information Simplex.Messaging.Server.Main + Simplex.Messaging.Server.Main.GitCommit Simplex.Messaging.Server.Main.Init Simplex.Messaging.Server.MsgStore Simplex.Messaging.Server.MsgStore.Journal @@ -354,10 +355,12 @@ library if impl(ghc >= 9.6.2) build-depends: bytestring ==0.11.* + , template-haskell ==2.20.* , text >=2.0.1 && <2.2 if impl(ghc < 9.6.2) build-depends: bytestring ==0.10.* + , template-haskell ==2.16.* , text >=1.2.3.0 && <1.3 executable ntf-server diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 5e4c84aa3..dac4cc1b3 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -31,6 +31,7 @@ import qualified Data.X509 as X import qualified Data.X509.Validation as XV import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Client as H +import Network.Socket (HostName) import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Protocol import Simplex.FileTransfer.Transport @@ -45,6 +46,7 @@ import Simplex.Messaging.Client transportClientConfig, clientSocksCredentials, unexpectedResponse, + useWebPort, ) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC @@ -104,12 +106,13 @@ defaultXFTPClientConfig = clientALPN = Just alpnSupportedXFTPhandshakes } -getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) -getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} proxySessTs disconnected = runExceptT $ do +getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) +getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs disconnected = runExceptT $ do let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession ProtocolServer _ host port keyHash = srv + useALPN = if useWebPort xftpNetworkConfig presetDomains srv then Just [httpALPN11] else clientALPN 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 clientVar <- newTVarIO Nothing 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} logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN 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 logDebug $ "Client negotiated protocol: " <> tshow thVersion let c = XFTPClient {http2Client, thParams, transportSession, config} diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs index d5733ac14..a7055479a 100644 --- a/src/Simplex/FileTransfer/Client/Agent.hs +++ b/src/Simplex/FileTransfer/Client/Agent.hs @@ -71,7 +71,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do connectClient = ExceptT $ first (XFTPClientAgentError srv) - <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) startedAt clientDisconnected + <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) [] startedAt clientDisconnected clientDisconnected :: XFTPClient -> IO () clientDisconnected _ = do diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 48e855f69..c169e69b0 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -133,7 +133,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse} flip runReaderT env $ case sessionALPN of Nothing -> processRequest req0 - Just "xftp/1" -> + Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 -> xftpServerHandshakeV1 chain signKey sessions req0 >>= \case Nothing -> pure () -- handshake response sent Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here) diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index fcac06cd4..944df1ca0 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -27,8 +27,8 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer) 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.HTTP2 (httpALPN) import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow) import System.Directory (createDirectoryIfMissing, doesFileExist) @@ -60,7 +60,7 @@ xftpServerCLI cfgPath logPath = do putStrLn "Deleted configuration and log files" where iniFile = combine cfgPath "file-server.ini" - serverVersion = "SimpleX XFTP server v" <> simplexMQVersion + serverVersion = "SimpleX XFTP server v" <> simplexmqVersionCommit defaultServerPort = "443" executableName = "file-server" storeLogFilePath = combine logPath "file-server-store.log" @@ -196,7 +196,7 @@ xftpServerCLI cfgPath logPath = do transportConfig = mkTransportServerConfig (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini) - (Just alpnSupportedXFTPhandshakes) + (Just $ alpnSupportedXFTPhandshakes <> httpALPN) False, responseDelay = 0 } diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 80a2cc020..b7746f1cb 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -14,6 +14,7 @@ module Simplex.FileTransfer.Transport blockedFilesXFTPVersion, xftpClientHandshakeStub, alpnSupportedXFTPhandshakes, + xftpALPNv1, XFTPClientHandshake (..), -- xftpClientHandshake, XFTPServerHandshake (..), @@ -105,7 +106,10 @@ xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> V xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer _serviceKeys = throwE TEVersion alpnSupportedXFTPhandshakes :: [ALPN] -alpnSupportedXFTPhandshakes = ["xftp/1"] +alpnSupportedXFTPhandshakes = [xftpALPNv1] + +xftpALPNv1 :: ALPN +xftpALPNv1 = "xftp/1" data XFTPServerHandshake = XFTPServerHandshake { xftpVersionRange :: VersionRangeXFTP, diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 745acbbac..39b3534c0 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -330,7 +330,7 @@ data AgentClient = AgentClient xftpServers :: TMap UserId (UserServers 'PXFTP), xftpClients :: TMap XFTPTransportSession XFTPClientVar, useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks - presetSMPDomains :: [HostName], + presetDomains :: [HostName], userNetworkInfo :: TVar UserNetworkInfo, userNetworkUpdated :: TVar (Maybe UTCTime), subscrConns :: TVar (Set ConnId), @@ -537,7 +537,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomai xftpServers, xftpClients, useNetworkConfig, - presetSMPDomains = presetDomains, + presetDomains, userNetworkInfo, userNetworkUpdated, subscrConns, @@ -686,7 +686,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT 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 `catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e where @@ -697,7 +697,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} nm tSess@(_, srv, env <- ask liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do 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} 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) 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 ts <- liftIO getCurrentTime atomically (getSessVar workerSeq tSess ntfClients ts) @@ -800,7 +800,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} nm g <- asks random ts <- readTVarIO proxySessTs 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 :: NtfClientVar -> NtfClient -> IO () @@ -810,7 +810,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} nm logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient -getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do +getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs, presetDomains} tSess@(_, srv, _) = do unlessM (readTVarIO active) $ throwE INACTIVE ts <- liftIO getCurrentTime atomically (getSessVar workerSeq tSess xftpClients ts) @@ -824,7 +824,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs} xftpNetworkConfig <- getNetworkConfig c ts <- readTVarIO proxySessTs liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $ - X.getXFTPClient tSess cfg {xftpNetworkConfig} ts $ + X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts $ clientDisconnected v clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () @@ -1227,7 +1227,7 @@ data ProtocolTestFailure = ProtocolTestFailure deriving (Eq, Show) 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 C.AuthAlg ra <- asks $ rcvAuthAlg . config C.AuthAlg sa <- asks $ sndAuthAlg . config @@ -1235,7 +1235,7 @@ runSMPServerTest c nm userId (ProtoServerWithAuth srv auth) = do liftIO $ do let tSess = (userId, srv, Nothing) 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 rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra 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 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 g <- asks random xftpNetworkConfig <- getNetworkConfig c @@ -1266,7 +1266,7 @@ runXFTPServerTest c nm userId (ProtoServerWithAuth srv auth) = do liftIO $ do let tSess = (userId, srv, Nothing) 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 (sndKey, spKey) <- 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 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 C.AuthAlg a <- asks $ rcvAuthAlg . config g <- asks random liftIO $ do let tSess = (userId, srv, Nothing) 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 (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g (dhKey, _) <- atomically $ C.generateKeyPair g diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index b14faffbf..afc19e8d6 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -38,6 +38,7 @@ module Simplex.Messaging.Client protocolClientServer', transportHost', transportSession', + useWebPort, -- * SMP protocol command functions createSMPQueue, @@ -160,6 +161,7 @@ import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, runTransportClient) +import Simplex.Messaging.Transport.HTTP2 (httpALPN11) import Simplex.Messaging.Transport.KeepAlive import Simplex.Messaging.Util import Simplex.Messaging.Version @@ -560,7 +562,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS `catch` \(e :: IOException) -> pure . Left $ PCEIOError e Left e -> pure $ Left e where - NetworkConfig {smpWebPortServers, tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig + NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig mkProtocolClient :: TransportHost -> UTCTime -> IO (PClient v err msg) mkProtocolClient transportHost ts = do 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 (port', ATransport t) useHost c = do 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 tId <- 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 = case port srv of "" -> case protocolTypeI @(ProtoType msg) of - SPSMP | smpWebPort -> ("443", transport @TLS) + SPSMP | web -> ("443", transport @TLS) _ -> defaultTransport cfg p -> (p, transport @TLS) - where - smpWebPort = case smpWebPortServers of - SWPAll -> True - SWPPreset -> case srv of - ProtocolServer {host = THDomainName h :| _} -> any (`isSuffixOf` h) presetDomains - _ -> False - SWPOff -> False + + useALPN :: Maybe [ALPN] + useALPN = if web then Just [httpALPN11] else clientALPN + + web = useWebPort networkConfig presetDomains srv 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 @@ -709,6 +709,14 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS Left e -> logError $ "SMP client error: " <> tshow e 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 = PCEUnexpectedResponse . B.pack . take 32 . show diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index f79ad12b7..de12c33f8 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -46,8 +46,9 @@ import Simplex.Messaging.Server.Main (strParse) import Simplex.Messaging.Server.Main.Init (iniDbOpts) import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) 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.HTTP2 (httpALPN) import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow) import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile) @@ -136,7 +137,7 @@ ntfServerCLI cfgPath logPath = (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure) Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure iniFile = combine cfgPath "ntf-server.ini" - serverVersion = "SMP notifications server v" <> simplexMQVersion + serverVersion = "SMP notifications server v" <> simplexmqVersionCommit defaultServerPort = "443" executableName = "ntf-server" storeLogFilePath = combine logPath "ntf-server-store.log" @@ -283,7 +284,7 @@ ntfServerCLI cfgPath logPath = transportConfig = mkTransportServerConfig (fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini) - (Just alpnSupportedNTFHandshakes) + (Just $ alpnSupportedNTFHandshakes <> httpALPN) False, startOptions } diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index a4686976d..9ca6856ee 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -203,15 +203,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt env <- ask liftIO $ case (httpCreds_, attachHTTP_) of (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 Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> labelMyThread "https client" >> attachHTTP s tlsContext _ -> runClient srvCert srvSignKey t h `runReaderT` env where 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 diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index cf95f171a..04db0231c 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -33,8 +34,9 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) 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.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.WebSockets (WS) import Simplex.Messaging.Util (eitherToMaybe, whenM) @@ -97,6 +99,12 @@ getCliCommand' cmdP version = where 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 = createServerX509_ True diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index c5292b4e5..f94cd9682 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -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.QueueStore.Postgres.Config 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.HTTP2 (httpALPN) import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig) import Simplex.Messaging.Util (eitherToMaybe, ifM) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) @@ -234,7 +235,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = (putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure) Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure iniFile = combine cfgPath "smp-server.ini" - serverVersion = "SMP server v" <> simplexMQVersion + serverVersion = "SMP server v" <> simplexmqVersionCommit executableName = "smp-server" storeLogFilePath = combine logPath "smp-server-store.log" storeMsgsFilePath = combine logPath "smp-server-messages.log" @@ -450,7 +451,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = transportConfig = mkTransportServerConfig (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 controlPort = eitherToMaybe $ T.unpack <$> lookupValue "TRANSPORT" "control_port" ini, smpAgentCfg = @@ -808,7 +809,7 @@ cliCommandP cfgPath logPath iniFile = sourceCode = T.pack <$> sourceCode, serverInfo = ServerPublicInfo - { sourceCode = T.pack simplexmqSource, + { sourceCode = T.pack $ fromMaybe simplexmqSource sourceCode, usageConditions = Nothing, operator = fst operator_, website, diff --git a/src/Simplex/Messaging/Server/Main/GitCommit.hs b/src/Simplex/Messaging/Server/Main/GitCommit.hs new file mode 100644 index 000000000..751231f2e --- /dev/null +++ b/src/Simplex/Messaging/Server/Main/GitCommit.hs @@ -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 + _ -> "" diff --git a/src/Simplex/Messaging/Transport/HTTP2.hs b/src/Simplex/Messaging/Transport/HTTP2.hs index ae0469c91..07327aa9e 100644 --- a/src/Simplex/Messaging/Transport/HTTP2.hs +++ b/src/Simplex/Messaging/Transport/HTTP2.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Simplex.Messaging.Transport.HTTP2 where @@ -15,7 +16,7 @@ import qualified Network.HTTP2.Server as HS import Network.Socket (SockAddr (..)) import qualified Network.TLS as T 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 qualified System.TimeManager as TI @@ -81,3 +82,9 @@ getHTTP2Body r n = do -- TODO check bodySize once it is set bodyPart = if B.length bodyHead == n then Just getPart else Nothing pure HTTP2Body {bodyHead, bodySize, bodyPart, bodyBuffer} + +httpALPN :: [ALPN] +httpALPN = ["h2", "http/1.1"] + +httpALPN11 :: ALPN +httpALPN11 = "http/1.1" diff --git a/tests/AgentTests/ServerChoice.hs b/tests/AgentTests/ServerChoice.hs index 2513f5f6d..a3d6337f2 100644 --- a/tests/AgentTests/ServerChoice.hs +++ b/tests/AgentTests/ServerChoice.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/tests/CLITests.hs b/tests/CLITests.hs index 5dff5ce00..c0c7c04d2 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -23,8 +23,9 @@ 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.Server.CLI (simplexmqVersionCommit) 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.HTTP2 (HTTP2Body (..)) import qualified Simplex.Messaging.Transport.HTTP2.Client as HC @@ -108,7 +109,7 @@ smpServerTest storeLog basicAuth = do doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True -- start 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` ["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"] @@ -216,7 +217,7 @@ ntfServerTest storeLog = do lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off" doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True 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` ["Serving NTF protocol on port 443 (TLS)..."] capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath) @@ -234,7 +235,7 @@ xftpServerTest storeLog = do lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443" doesFileExist (fileCfgPath <> "/ca.key") `shouldReturn` True 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` ["Listening on port 443..."] capture_ (withStdin "Y" . withArgs ["delete"] $ xftpServerCLI fileCfgPath fileLogPath) diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 0f7310073..bd62afa06 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -145,6 +145,6 @@ testXFTPClient = testXFTPClientWith testXFTPClientConfig testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a testXFTPClientWith cfg client = do ts <- getCurrentTime - getXFTPClient (1, testXFTPServer, Nothing) cfg ts (\_ -> pure ()) >>= \case + getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure ()) >>= \case Right c -> client c Left e -> error $ show e diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index fe271f401..c1d34177f 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -223,7 +223,7 @@ testInactiveClientExpiration :: Expectation testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do disconnected <- newEmptyTMVarIO 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 liftIO $ do threadDelay 100000
Server version:${version}${version} / ${shortCommit}
Source code:${sourceCode} + ${sourceCode} + add to smp-server.ini (required by AGPLv3) +