Merge branch 'master' into rcv-services

This commit is contained in:
Evgeny @ SimpleX Chat
2026-03-09 10:23:01 +00:00
51 changed files with 481 additions and 205 deletions
+4 -3
View File
@@ -2,8 +2,9 @@ module Main where
import Control.Logger.Simple
import Simplex.Messaging.Server.CLI (getEnvPath)
import Simplex.Messaging.Server.Main
import qualified Static
import Simplex.Messaging.Server.Main (smpServerCLI_)
import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticFiles)
import SMPWeb (smpGenerateSite)
defaultCfgPath :: FilePath
defaultCfgPath = "/etc/opt/simplex"
@@ -18,4 +19,4 @@ main :: IO ()
main = do
cfgPath <- getEnvPath "SMP_SERVER_CFG_PATH" defaultCfgPath
logPath <- getEnvPath "SMP_SERVER_LOG_PATH" defaultLogPath
withGlobalLogging logCfg $ smpServerCLI_ Static.generateSite Static.serveStaticFiles Static.attachStaticFiles cfgPath logPath
withGlobalLogging logCfg $ smpServerCLI_ smpGenerateSite serveStaticFiles attachStaticFiles cfgPath logPath
+43
View File
@@ -0,0 +1,43 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module SMPWeb
( smpGenerateSite,
serverInformation,
) where
import Data.ByteString (ByteString)
import Data.String (fromString)
import Simplex.Messaging.Encoding.String (strEncode)
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.Main (simplexmqSource)
import qualified Simplex.Messaging.Server.Web as Web
import Simplex.Messaging.Server.Web (render, serverInfoSubsts, timedTTLText)
import Simplex.Messaging.Server.Web.Embedded as E
import Simplex.Messaging.Transport.Client (TransportHost (..))
smpGenerateSite :: ServerInformation -> Maybe TransportHost -> FilePath -> IO ()
smpGenerateSite si onionHost path =
Web.generateSite (serverInformation si onionHost) smpLinkPages path
smpLinkPages :: [String]
smpLinkPages = ["contact", "invitation", "a", "c", "g", "r", "i"]
serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString
serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs
where
substs = [("smpConfig", Just "y"), ("xftpConfig", Nothing)] <> substConfig <> serverInfoSubsts simplexmqSource information <> [("onionHost", strEncode <$> onionHost), ("iniFileName", Just "smp-server.ini")]
substConfig =
[ ( "persistence",
Just $ case persistence config of
SPMMemoryOnly -> "In-memory only"
SPMQueues -> "Queues"
SPMMessages -> "Queues and messages"
),
("messageExpiration", Just $ maybe "Never" (fromString . timedTTLText) $ messageExpiration config),
("statsEnabled", Just . yesNo $ statsEnabled config),
("newQueuesAllowed", Just . yesNo $ newQueuesAllowed config),
("basicAuthEnabled", Just . yesNo $ basicAuthEnabled config)
]
yesNo True = "Yes"
yesNo False = "No"
-1
View File
@@ -1 +0,0 @@
../link.html
-1
View File
@@ -1 +0,0 @@
../link.html
@@ -1 +0,0 @@
../link.html
-1
View File
@@ -1 +0,0 @@
../link.html
@@ -1 +0,0 @@
../link.html
-18
View File
@@ -1,18 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Static.Embedded where
import Data.FileEmbed (embedDir, embedFile)
import Data.ByteString (ByteString)
indexHtml :: ByteString
indexHtml = $(embedFile "apps/smp-server/static/index.html")
linkHtml :: ByteString
linkHtml = $(embedFile "apps/smp-server/static/link.html")
mediaContent :: [(FilePath, ByteString)]
mediaContent = $(embedDir "apps/smp-server/static/media/")
wellKnown :: [(FilePath, ByteString)]
wellKnown = $(embedDir "apps/smp-server/static/.well-known/")
+4 -2
View File
@@ -1,8 +1,10 @@
module Main where
import Control.Logger.Simple
import Simplex.FileTransfer.Server.Main (xftpServerCLI_)
import Simplex.Messaging.Server.CLI (getEnvPath)
import Simplex.FileTransfer.Server.Main
import Simplex.Messaging.Server.Web (serveStaticFiles)
import XFTPWeb (xftpGenerateSite)
defaultCfgPath :: FilePath
defaultCfgPath = "/etc/opt/simplex-xftp"
@@ -18,4 +20,4 @@ main = do
setLogLevel LogDebug -- change to LogError in production
cfgPath <- getEnvPath "XFTP_SERVER_CFG_PATH" defaultCfgPath
logPath <- getEnvPath "XFTP_SERVER_LOG_PATH" defaultLogPath
withGlobalLogging logCfg $ xftpServerCLI cfgPath logPath
withGlobalLogging logCfg $ xftpServerCLI_ xftpGenerateSite serveStaticFiles cfgPath logPath
+37
View File
@@ -0,0 +1,37 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module XFTPWeb
( xftpGenerateSite,
xftpServerInformation,
) where
import Data.ByteString (ByteString)
import Data.Maybe (isJust)
import Data.String (fromString)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
import Simplex.Messaging.Encoding.String (strEncode)
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
import Simplex.Messaging.Server.Information (ServerPublicInfo)
import Simplex.Messaging.Server.Main (simplexmqSource)
import qualified Simplex.Messaging.Server.Web as Web
import Simplex.Messaging.Server.Web (render, serverInfoSubsts, timedTTLText)
import Simplex.Messaging.Server.Web.Embedded as E
import Simplex.Messaging.Transport.Client (TransportHost (..))
xftpGenerateSite :: XFTPServerConfig -> Maybe ServerPublicInfo -> Maybe TransportHost -> FilePath -> IO ()
xftpGenerateSite cfg info onionHost path =
Web.generateSite (xftpServerInformation cfg info onionHost) [] path
xftpServerInformation :: XFTPServerConfig -> Maybe ServerPublicInfo -> Maybe TransportHost -> ByteString
xftpServerInformation XFTPServerConfig {fileExpiration, logStatsInterval, allowNewFiles, newFileBasicAuth} information onionHost = render E.indexHtml substs
where
substs = [("smpConfig", Nothing), ("xftpConfig", Just "y")] <> substConfig <> serverInfoSubsts simplexmqSource information <> [("onionHost", strEncode <$> onionHost), ("iniFileName", Just "file-server.ini")]
substConfig =
[ ("fileExpiration", Just $ maybe "Never" (fromString . timedTTLText . ttl) fileExpiration),
("statsEnabled", Just . yesNo $ isJust logStatsInterval),
("newUploadsAllowed", Just . yesNo $ allowNewFiles),
("basicAuthEnabled", Just . yesNo $ isJust newFileBasicAuth)
]
yesNo True = "Yes"
yesNo False = "No"
+1 -1
View File
@@ -131,7 +131,7 @@ A subset of standard specifications will be designated as Core IP under the Cons
This is a legally binding commitment. Once Licensed IP is included in Core IP, the company that owns the code cannot unilaterally change it — even though they own the code, the Consortium Agreement requires a Governing Decision for any change to Core IP. This protects the fundamental properties of the network (privacy, security, decentralization) from unilateral modification by any single party.
The designation of specific specifications as Core IP is itself a Governing Decision requiring unanimous approval. The transition will happen incrementally as protocols stabilize — the governance ratchet ensures that each designation is irreversible.
The designation of specific specifications as Core IP is itself a Governing Decision that requires Consortium vote. The transition will happen incrementally as protocols stabilize — the governance ratchet ensures that each designation is irreversible.
The exact mechanism for distinguishing core from standard within the RFC and protocol folder structure is TBD — it will be decided as the first protocols are designated as Core IP.
+42 -47
View File
@@ -24,33 +24,33 @@ extra-source-files:
CHANGELOG.md
cbits/sha512.h
cbits/sntrup761.h
apps/smp-server/static/index.html
apps/smp-server/static/link.html
apps/smp-server/static/media/apk_icon.png
apps/smp-server/static/media/apple_store.svg
apps/smp-server/static/media/contact.js
apps/smp-server/static/media/contact_page_mobile.png
apps/smp-server/static/media/f_droid.svg
apps/smp-server/static/media/favicon.ico
apps/smp-server/static/media/GilroyBold.woff2
apps/smp-server/static/media/GilroyLight.woff2
apps/smp-server/static/media/GilroyMedium.woff2
apps/smp-server/static/media/GilroyRegular.woff2
apps/smp-server/static/media/GilroyRegularItalic.woff2
apps/smp-server/static/media/google_play.svg
apps/smp-server/static/media/logo-dark.png
apps/smp-server/static/media/logo-light.png
apps/smp-server/static/media/logo-symbol-dark.svg
apps/smp-server/static/media/logo-symbol-light.svg
apps/smp-server/static/media/moon.svg
apps/smp-server/static/media/qrcode.js
apps/smp-server/static/media/script.js
apps/smp-server/static/media/style.css
apps/smp-server/static/media/sun.svg
apps/smp-server/static/media/swiper-bundle.min.css
apps/smp-server/static/media/swiper-bundle.min.js
apps/smp-server/static/media/tailwind.css
apps/smp-server/static/media/testflight.png
src/Simplex/Messaging/Server/Web/index.html
src/Simplex/Messaging/Server/Web/link.html
src/Simplex/Messaging/Server/Web/media/apk_icon.png
src/Simplex/Messaging/Server/Web/media/apple_store.svg
src/Simplex/Messaging/Server/Web/media/contact.js
src/Simplex/Messaging/Server/Web/media/contact_page_mobile.png
src/Simplex/Messaging/Server/Web/media/f_droid.svg
src/Simplex/Messaging/Server/Web/media/favicon.ico
src/Simplex/Messaging/Server/Web/media/GilroyBold.woff2
src/Simplex/Messaging/Server/Web/media/GilroyLight.woff2
src/Simplex/Messaging/Server/Web/media/GilroyMedium.woff2
src/Simplex/Messaging/Server/Web/media/GilroyRegular.woff2
src/Simplex/Messaging/Server/Web/media/GilroyRegularItalic.woff2
src/Simplex/Messaging/Server/Web/media/google_play.svg
src/Simplex/Messaging/Server/Web/media/logo-dark.png
src/Simplex/Messaging/Server/Web/media/logo-light.png
src/Simplex/Messaging/Server/Web/media/logo-symbol-dark.svg
src/Simplex/Messaging/Server/Web/media/logo-symbol-light.svg
src/Simplex/Messaging/Server/Web/media/moon.svg
src/Simplex/Messaging/Server/Web/media/qrcode.js
src/Simplex/Messaging/Server/Web/media/script.js
src/Simplex/Messaging/Server/Web/media/style.css
src/Simplex/Messaging/Server/Web/media/sun.svg
src/Simplex/Messaging/Server/Web/media/swiper-bundle.min.css
src/Simplex/Messaging/Server/Web/media/swiper-bundle.min.js
src/Simplex/Messaging/Server/Web/media/tailwind.css
src/Simplex/Messaging/Server/Web/media/testflight.png
flag swift
description: Enable swift JSON format
@@ -248,6 +248,8 @@ library
Simplex.Messaging.Server.Main
Simplex.Messaging.Server.Main.GitCommit
Simplex.Messaging.Server.Main.Init
Simplex.Messaging.Server.Web
Simplex.Messaging.Server.Web.Embedded
Simplex.Messaging.Server.MsgStore
Simplex.Messaging.Server.MsgStore.Journal
Simplex.Messaging.Server.MsgStore.Journal.SharedLock
@@ -343,11 +345,16 @@ library
if !flag(client_library)
build-depends:
case-insensitive ==1.2.*
, file-embed >=0.0.10 && <0.1
, hashable ==1.4.*
, ini ==0.4.1
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, temporary ==1.3.*
, wai >=3.2 && <3.3
, wai-app-static >=3.1 && <3.2
, warp ==3.3.30
, warp-tls ==3.4.7
, websockets ==0.12.*
, zlib >=0.6 && <0.8
if flag(client_postgres) || flag(server_postgres)
@@ -404,30 +411,19 @@ executable smp-server
cpp-options: -DdbServerPostgres
main-is: Main.hs
other-modules:
Static
Static.Embedded
SMPWeb
Paths_simplexmq
hs-source-dirs:
apps/smp-server
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-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
base
, bytestring
, directory
, file-embed
, filepath
, network
, simple-logger
, simplexmq
, text
, unliftio
, wai
, wai-app-static
, warp ==3.3.30
, warp-tls ==3.4.7
default-language: Haskell2010
executable xftp
@@ -451,6 +447,7 @@ executable xftp-server
buildable: False
main-is: Main.hs
other-modules:
XFTPWeb
Paths_simplexmq
hs-source-dirs:
apps/xftp-server
@@ -459,6 +456,7 @@ executable xftp-server
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
base
, bytestring
, simple-logger
, simplexmq
default-language: Haskell2010
@@ -500,9 +498,10 @@ test-suite simplexmq-test
XFTPCLI
XFTPClient
XFTPServerTests
WebTests
XFTPWebTests
Static
Static.Embedded
SMPWeb
XFTPWeb
Paths_simplexmq
if flag(client_postgres)
other-modules:
@@ -521,7 +520,8 @@ test-suite simplexmq-test
PostgresSchemaDump
hs-source-dirs:
tests
apps/smp-server/web
apps/smp-server
apps/xftp-server
default-extensions:
StrictData
-- add -fhpc to ghc-options to run tests with coverage
@@ -539,7 +539,6 @@ test-suite simplexmq-test
, crypton-x509-store
, crypton-x509-validation
, directory
, file-embed
, filepath
, generic-random ==1.5.*
, hashable
@@ -569,10 +568,6 @@ test-suite simplexmq-test
, unliftio
, unliftio-core
, unordered-containers
, wai
, wai-app-static
, warp
, warp-tls
, yaml
default-language: Haskell2010
if flag(server_postgres)
+7 -5
View File
@@ -73,6 +73,7 @@ import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
import Simplex.Messaging.Transport.HTTP2.Server (runHTTP2Server)
import Simplex.Messaging.Transport.Server (SNICredentialUsed, TransportServerConfig (..), runLocalTCPServer)
import Simplex.Messaging.Server.Web (serveStaticPageH2)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Environment (lookupEnv)
@@ -84,7 +85,7 @@ import System.Random (getStdRandom, randomR)
#endif
import UnliftIO
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Directory (doesFileExist, removeFile, renameFile)
import UnliftIO.Directory (canonicalizePath, doesFileExist, removeFile, renameFile)
import qualified UnliftIO.Exception as E
type M a = ReaderT XFTPEnv IO a
@@ -147,11 +148,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
sessions <- liftIO TM.emptyIO
let cleanup sessionId = atomically $ TM.delete sessionId sessions
srvParams = if isJust httpCreds_ then defaultSupportedParamsHTTPS else defaultSupportedParams
webCanonicalRoot_ <- liftIO $ mapM canonicalizePath (webStaticPath cfg)
liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize srvParams srvCreds httpCreds_ transportConfig inactiveClientExpiration cleanup $ \sniUsed sessionId sessionALPN r sendResponse -> do
let addCORS' = sniUsed && addCORSHeaders transportConfig
if addCORS' && H.requestMethod r == Just "OPTIONS"
then sendResponse $ H.responseNoBody N.ok200 corsPreflightHeaders
else do
case H.requestMethod r of
Just "OPTIONS" | addCORS' -> sendResponse $ H.responseNoBody N.ok200 corsPreflightHeaders
Just "GET" | sniUsed -> forM_ webCanonicalRoot_ $ \root -> serveStaticPageH2 root r sendResponse
_ -> do
reqBody <- getHTTP2Body r xftpBlockSize
let v = VersionXFTP 1
thServerVRange = versionToRange v
@@ -377,7 +380,6 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
CPHelp -> hPutStrLn h "commands: stats-rts, delete, help, quit"
CPQuit -> pure ()
CPSkip -> pure ()
_ -> hPutStrLn h "unsupported command"
where
withUserRole action =
readTVarIO role >>= \case
+2 -1
View File
@@ -77,7 +77,8 @@ data XFTPServerConfig = XFTPServerConfig
prometheusInterval :: Maybe Int,
prometheusMetricsFile :: FilePath,
transportConfig :: TransportServerConfig,
responseDelay :: Int
responseDelay :: Int,
webStaticPath :: Maybe FilePath
}
defaultInactiveClientExpiration :: ExpirationConfig
+81 -9
View File
@@ -5,16 +5,22 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.FileTransfer.Server.Main
( xftpServerCLI,
xftpServerCLI_,
) where
import Control.Monad (when)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.Ini (lookupValue, readIniFile)
import Data.Int (Int64)
import Data.List (find)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isJust)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Network.Socket (HostName)
@@ -29,6 +35,9 @@ 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.Server.Information (ServerPublicInfo (..))
import Simplex.Messaging.Server.Main (serverPublicInfo, printSourceCode)
import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..))
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), mkTransportServerConfig)
@@ -39,7 +48,15 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
import Text.Read (readMaybe)
xftpServerCLI :: FilePath -> FilePath -> IO ()
xftpServerCLI cfgPath logPath = do
xftpServerCLI = xftpServerCLI_ (\_ _ _ _ -> pure ()) (\_ -> pure ())
xftpServerCLI_ ::
(XFTPServerConfig -> Maybe ServerPublicInfo -> Maybe TransportHost -> FilePath -> IO ()) ->
(EmbeddedWebParams -> IO ()) ->
FilePath ->
FilePath ->
IO ()
xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
Init opts ->
doesFileExist iniFile >>= \case
@@ -66,7 +83,8 @@ xftpServerCLI cfgPath logPath = do
defaultServerPort = "443"
executableName = "file-server"
storeLogFilePath = combine logPath "file-server-store.log"
initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota} = do
defaultStaticPath = combine logPath "www"
initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota, webStaticPath = webStaticPath_} = do
clearDirIfExists cfgPath
clearDirIfExists logPath
createDirectoryIfMissing True cfgPath
@@ -81,7 +99,27 @@ xftpServerCLI cfgPath logPath = do
printServiceInfo serverVersion srv
where
iniFileContent host =
"[STORE_LOG]\n\
"[INFORMATION]\n\
\# AGPLv3 license requires that you make any source code modifications\n\
\# available to the end users of the server.\n\
\# LICENSE: https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE\n\
\# Include correct source code URI in case the server source code is modified in any way.\n\
\# source_code: https://github.com/simplex-chat/simplexmq\n\
\\n\
\# Declaring all below information is optional, any of these fields can be omitted.\n\
\# server_country: ISO-3166 2-letter code\n\
\# operator: entity (organization or person name)\n\
\# operator_country: ISO-3166 2-letter code\n\
\# website:\n\
\# admin_simplex: SimpleX address\n\
\# admin_email:\n\
\# complaints_simplex: SimpleX address\n\
\# complaints_email:\n\
\# hosting: entity (organization or person name)\n\
\# hosting_country: ISO-3166 2-letter code\n\
\# hosting_type: virtual\n\
\\n\
\[STORE_LOG]\n\
\# The server uses STM memory for persistence,\n\
\# that will be lost on restart (e.g., as with redis).\n\
\# This option enables saving memory to append only log,\n\
@@ -128,8 +166,13 @@ xftpServerCLI cfgPath logPath = do
<> ("# check_interval: " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
<> "\n\
\[WEB]\n\
\# cert: /etc/opt/simplex-xftp/web.crt\n\
\# key: /etc/opt/simplex-xftp/web.key\n"
\# Set path to generate static mini-site for server information\n"
<> ("static_path: " <> T.pack (fromMaybe defaultStaticPath webStaticPath_) <> "\n\n")
<> "# Run an embedded HTTP server on this port.\n\
\# http: 8000\n\n\
\# TLS credentials for HTTPS web server on the same port as XFTP.\n\
\# cert: " <> T.pack (cfgPath `combine` "web.crt") <> "\n\
\# key: " <> T.pack (cfgPath `combine` "web.key") <> "\n"
runServer ini = do
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
@@ -138,9 +181,22 @@ xftpServerCLI cfgPath logPath = do
port = T.unpack $ strictIni "TRANSPORT" "port" ini
srv = ProtoServerWithAuth (XFTPServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
printServiceInfo serverVersion srv
let information = serverPublicInfo ini
printSourceCode (sourceCode <$> information)
printXFTPConfig serverConfig
case webStaticPath' of
Just path -> do
let onionHost =
either (const Nothing) (find isOnion) $
strDecode @(L.NonEmpty TransportHost) . encodeUtf8 =<< lookupValue "TRANSPORT" "host" ini
webHttpPort = eitherToMaybe (lookupValue "WEB" "http" ini) >>= readMaybe . T.unpack
generateSite serverConfig information onionHost path
when (isJust webHttpPort || isJust webHttpsParams') $
serveStaticFiles EmbeddedWebParams {webStaticPath = path, webHttpPort, webHttpsParams = webHttpsParams'}
Nothing -> pure ()
runXFTPServer serverConfig
where
isOnion = \case THOnionHost _ -> True; _ -> False
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
logStats = settingIsOn "STORE_LOG" "log_stats" ini
c = combine cfgPath . ($ defaultX509Config)
@@ -172,6 +228,14 @@ xftpServerCLI cfgPath logPath = do
privateKeyFile = key
}
webHttpsParams' = do
httpsPort <- eitherToMaybe (lookupValue "WEB" "https" ini) >>= readMaybe . T.unpack
cert <- eitherToMaybe $ T.unpack <$> lookupValue "WEB" "cert" ini
key <- eitherToMaybe $ T.unpack <$> lookupValue "WEB" "key" ini
pure WebHttpsParams {port = httpsPort, cert, key}
webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
serverConfig =
XFTPServerConfig
{ xftpPort = T.unpack $ strictIni "TRANSPORT" "port" ini,
@@ -209,7 +273,7 @@ xftpServerCLI cfgPath logPath = do
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "file-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
prometheusInterval = eitherToMaybe (lookupValue "STORE_LOG" "prometheus_interval" ini) >>= readMaybe . T.unpack,
prometheusMetricsFile = combine logPath "xftp-server-metrics.txt",
transportConfig =
let cfg =
@@ -218,7 +282,8 @@ xftpServerCLI cfgPath logPath = do
(Just $ alpnSupportedXFTPhandshakes <> httpALPN)
False
in cfg {addCORSHeaders = isJust httpCredentials_},
responseDelay = 0
responseDelay = 0,
webStaticPath = webStaticPath'
}
data CliCommand
@@ -233,7 +298,8 @@ data InitOptions = InitOptions
ip :: HostName,
fqdn :: Maybe HostName,
filesPath :: FilePath,
fileSizeQuota :: FileSize Int64
fileSizeQuota :: FileSize Int64,
webStaticPath :: Maybe FilePath
}
deriving (Show)
@@ -302,4 +368,10 @@ cliCommandP cfgPath logPath iniFile =
<> help "File storage quota (e.g. 100gb)"
<> metavar "QUOTA"
)
pure InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota}
webStaticPath <-
(optional . strOption)
( long "web-path"
<> help "Directory to store generated static site with server information"
<> metavar "PATH"
)
pure InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota, webStaticPath}
+8 -20
View File
@@ -73,6 +73,7 @@ import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.Main.Init
import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..))
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore)
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
import Simplex.Messaging.Server.QueueStore.Postgres.Config
@@ -572,7 +573,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
prometheusInterval = eitherToMaybe (lookupValue "STORE_LOG" "prometheus_interval" ini) >>= readMaybe . T.unpack,
prometheusMetricsFile = combine logPath "smp-server-metrics.txt",
pendingENDInterval = 15000000, -- 15 seconds
ntfDeliveryInterval = 1500000, -- 1.5 second
@@ -613,18 +614,17 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
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
webHttpPort = eitherToMaybe (lookupValue "WEB" "http" ini) >>= readMaybe . T.unpack
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}
webHttpsParams' = do
port <- eitherToMaybe (lookupValue "WEB" "https" ini) >>= readMaybe . T.unpack
cert <- eitherToMaybe $ T.unpack <$> lookupValue "WEB" "cert" ini
key <- eitherToMaybe $ T.unpack <$> lookupValue "WEB" "key" ini
pure WebHttpsParams {port, cert, key}
webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini
checkMsgStoreMode :: Ini -> AStoreType -> IO ()
@@ -748,18 +748,6 @@ newJournalMsgStore logPath qsCfg =
storeMsgsJournalDir' :: FilePath -> FilePath
storeMsgsJournalDir' logPath = combine logPath "messages"
data EmbeddedWebParams = EmbeddedWebParams
{ webStaticPath :: FilePath,
webHttpPort :: Maybe Int,
webHttpsParams :: Maybe WebHttpsParams
}
data WebHttpsParams = WebHttpsParams
{ port :: Int,
cert :: FilePath,
key :: FilePath
}
getServerSourceCode :: IO (Maybe String)
getServerSourceCode =
getLine >>= \case
@@ -1,19 +1,35 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
module Static where
module Simplex.Messaging.Server.Web
( EmbeddedWebParams (..),
WebHttpsParams (..),
serveStaticFiles,
attachStaticFiles,
serveStaticPageH2,
generateSite,
serverInfoSubsts,
render,
section_,
item_,
timedTTLText,
) where
import Control.Logger.Simple
import Control.Monad
import Data.ByteString (ByteString)
import Data.ByteString.Builder (byteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (toUpper)
import Data.IORef (readIORef)
import Data.List (isPrefixOf, isSuffixOf)
import Data.Maybe (fromMaybe)
import Data.String (fromString)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Server as H
import Network.Socket (getPeerName)
import Network.Wai (Application, Request (..))
import Network.Wai.Application.Static (StaticSettings (..))
@@ -25,17 +41,27 @@ 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 (..), simplexmqSource)
import Simplex.Messaging.Server.Web.Embedded as E
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 Simplex.Messaging.Util (ifM, tshow)
import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist)
import System.FilePath
import UnliftIO.Concurrent (forkFinally)
import UnliftIO.Exception (bracket, finally)
import qualified WaiAppStatic.Types as WAT
data EmbeddedWebParams = EmbeddedWebParams
{ webStaticPath :: FilePath,
webHttpPort :: Maybe Int,
webHttpsParams :: Maybe WebHttpsParams
}
data WebHttpsParams = WebHttpsParams
{ port :: Int,
cert :: FilePath,
key :: FilePath
}
serveStaticFiles :: EmbeddedWebParams -> IO ()
serveStaticFiles EmbeddedWebParams {webStaticPath, webHttpPort, webHttpsParams} = do
forM_ webHttpPort $ \port -> flip forkFinally (\e -> logError $ "HTTP server crashed: " <> tshow e) $ do
@@ -92,21 +118,15 @@ staticFiles root = S.staticApp settings . changeWellKnownPath
_ -> req
pfxLen = B.length "/.well-known/"
generateSite :: ServerInformation -> Maybe TransportHost -> FilePath -> IO ()
generateSite si onionHost sitePath = do
generateSite :: ByteString -> [String] -> FilePath -> IO ()
generateSite indexContent linkPages sitePath = do
createDirectoryIfMissing True sitePath
B.writeFile (sitePath </> "index.html") $ serverInformation si onionHost
B.writeFile (sitePath </> "index.html") indexContent
copyDir "media" E.mediaContent
-- `.well-known` path is re-written in changeWellKnownPath,
-- staticApp does not allow hidden folders.
copyDir "well-known" E.wellKnown
createLinkPage "contact"
createLinkPage "invitation"
createLinkPage "a"
createLinkPage "c"
createLinkPage "g"
createLinkPage "r"
createLinkPage "i"
forM_ linkPages createLinkPage
logInfo $ "Generated static site contents at " <> tshow sitePath
where
copyDir dir content = do
@@ -116,78 +136,104 @@ generateSite si onionHost sitePath = do
createDirectoryIfMissing True $ sitePath </> path
B.writeFile (sitePath </> path </> "index.html") E.linkHtml
serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString
serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs
-- | Serve static files via HTTP/2 directly (without WAI).
-- Path traversal protection: resolved path must stay under canonicalRoot.
-- canonicalRoot must be pre-computed via 'canonicalizePath'.
serveStaticPageH2 :: FilePath -> H.Request -> (H.Response -> IO ()) -> IO Bool
serveStaticPageH2 canonicalRoot req sendResponse = do
let rawPath = fromMaybe "/" $ H.requestPath req
path = rewriteWellKnownH2 rawPath
relPath = B.unpack $ B.dropWhile (== '/') path
requestedPath
| null relPath || relPath == "/" = canonicalRoot </> "index.html"
| otherwise = canonicalRoot </> relPath
indexPath = requestedPath </> "index.html"
ifM
(doesFileExist requestedPath)
(serveSafe requestedPath)
(ifM (doesFileExist indexPath) (serveSafe indexPath) (pure False))
where
substs = substConfig <> substInfo <> [("onionHost", strEncode <$> onionHost)]
substConfig =
[ ( "persistence",
Just $ case persistence config of
SPMMemoryOnly -> "In-memory only"
SPMQueues -> "Queues"
SPMMessages -> "Queues and messages"
),
("messageExpiration", Just $ maybe "Never" (fromString . timedTTLText) $ messageExpiration config),
("statsEnabled", Just . yesNo $ statsEnabled config),
("newQueuesAllowed", Just . yesNo $ newQueuesAllowed config),
("basicAuthEnabled", Just . yesNo $ basicAuthEnabled config)
serveSafe filePath = do
canonicalFile <- canonicalizePath filePath
if (canonicalRoot <> "/") `isPrefixOf` canonicalFile || canonicalRoot == canonicalFile
then do
content <- B.readFile canonicalFile
sendResponse $ H.responseBuilder N.ok200 [("Content-Type", staticMimeType canonicalFile)] (byteString content)
pure True
else pure False -- path traversal attempt
rewriteWellKnownH2 p
| "/.well-known/" `B.isPrefixOf` p = "/well-known/" <> B.drop (B.length "/.well-known/") p
| otherwise = p
staticMimeType fp
| ".html" `isSuffixOf` fp = "text/html"
| ".css" `isSuffixOf` fp = "text/css"
| ".js" `isSuffixOf` fp = "application/javascript"
| ".svg" `isSuffixOf` fp = "image/svg+xml"
| ".png" `isSuffixOf` fp = "image/png"
| ".ico" `isSuffixOf` fp = "image/x-icon"
| ".json" `isSuffixOf` fp = "application/json"
| "apple-app-site-association" `isSuffixOf` fp = "application/json"
| ".woff" `isSuffixOf` fp = "font/woff"
| ".woff2" `isSuffixOf` fp = "font/woff2"
| ".ttf" `isSuffixOf` fp = "font/ttf"
| otherwise = "application/octet-stream"
-- | Substitutions for server information fields shared between SMP and XFTP pages.
serverInfoSubsts :: String -> Maybe ServerPublicInfo -> [(ByteString, Maybe ByteString)]
serverInfoSubsts simplexmqSource information =
concat
[ basic,
maybe [("usageConditions", Nothing), ("usageAmendments", Nothing)] conds (usageConditions spi),
maybe [("operator", Nothing)] operatorE (operator spi),
maybe [("admin", Nothing)] admin (adminContacts spi),
maybe [("complaints", Nothing)] complaints (complaintsContacts spi),
maybe [("hosting", Nothing)] hostingE (hosting spi),
server
]
where
basic =
[ ("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)
]
operatorE Entity {name, country} =
[ ("operator", Just ""),
("operatorEntity", Just $ encodeUtf8 name),
("operatorCountry", encodeUtf8 <$> country)
]
admin ServerContactAddress {simplex, email, pgp} =
[ ("admin", Just ""),
("adminSimplex", strEncode <$> simplex),
("adminEmail", encodeUtf8 <$> email),
("adminPGP", encodeUtf8 . pkURI <$> pgp),
("adminPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp)
]
complaints ServerContactAddress {simplex, email, pgp} =
[ ("complaints", Just ""),
("complaintsSimplex", strEncode <$> simplex),
("complaintsEmail", encodeUtf8 <$> email),
("complaintsPGP", encodeUtf8 . pkURI <$> pgp),
("complaintsPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp)
]
hostingE Entity {name, country} =
[ ("hosting", Just ""),
("hostingEntity", Just $ encodeUtf8 name),
("hostingCountry", encodeUtf8 <$> country)
]
server =
[ ("serverCountry", encodeUtf8 <$> serverCountry spi),
("hostingType", (\s -> maybe s (\(c, rest) -> toUpper c `B.cons` rest) $ B.uncons s) . strEncode <$> hostingType spi)
]
yesNo True = "Yes"
yesNo False = "No"
substInfo =
concat
[ basic,
maybe [("usageConditions", Nothing), ("usageAmendments", Nothing)] conds (usageConditions spi),
maybe [("operator", Nothing)] operatorE (operator spi),
maybe [("admin", Nothing)] admin (adminContacts spi),
maybe [("complaints", Nothing)] complaints (complaintsContacts spi),
maybe [("hosting", Nothing)] hostingE (hosting spi),
server
]
where
basic =
[ ("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)
]
operatorE Entity {name, country} =
[ ("operator", Just ""),
("operatorEntity", Just $ encodeUtf8 name),
("operatorCountry", encodeUtf8 <$> country)
]
admin ServerContactAddress {simplex, email, pgp} =
[ ("admin", Just ""),
("adminSimplex", strEncode <$> simplex),
("adminEmail", encodeUtf8 <$> email),
("adminPGP", encodeUtf8 . pkURI <$> pgp),
("adminPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp)
]
complaints ServerContactAddress {simplex, email, pgp} =
[ ("complaints", Just ""),
("complaintsSimplex", strEncode <$> simplex),
("complaintsEmail", encodeUtf8 <$> email),
("complaintsPGP", encodeUtf8 . pkURI <$> pgp),
("complaintsPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp)
]
hostingE Entity {name, country} =
[ ("hosting", Just ""),
("hostingEntity", Just $ encodeUtf8 name),
("hostingCountry", encodeUtf8 <$> country)
]
server =
[ ("serverCountry", encodeUtf8 <$> serverCountry spi),
("hostingType", (\s -> maybe s (\(c, rest) -> toUpper c `B.cons` rest) $ B.uncons s) . strEncode <$> hostingType spi)
]
-- Copy-pasted from simplex-chat Simplex.Chat.Types.Preferences
{-# INLINE timedTTLText #-}
@@ -237,13 +283,13 @@ section_ label content' src =
(inside, next') ->
let next = B.drop (B.length endMarker) next'
in case content' of
Just content | not (B.null content) -> before <> item_ label content inside <> section_ label content' next
_ -> before <> next -- collapse section
Just content -> before <> item_ label content inside <> section_ label content' next
Nothing -> before <> next -- collapse section
where
startMarker = "<x-" <> label <> ">"
endMarker = "</x-" <> label <> ">"
-- | Replace all occurences of @${label}@ with provided content.
-- | Replace all occurrences of @${label}@ with provided content.
item_ :: ByteString -> ByteString -> ByteString -> ByteString
item_ label content' src =
case B.breakSubstring marker src of
@@ -0,0 +1,18 @@
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Messaging.Server.Web.Embedded where
import Data.ByteString (ByteString)
import Data.FileEmbed (embedDir, embedFile)
indexHtml :: ByteString
indexHtml = $(embedFile "src/Simplex/Messaging/Server/Web/index.html")
linkHtml :: ByteString
linkHtml = $(embedFile "src/Simplex/Messaging/Server/Web/link.html")
mediaContent :: [(FilePath, ByteString)]
mediaContent = $(embedDir "src/Simplex/Messaging/Server/Web/media/")
wellKnown :: [(FilePath, ByteString)]
wellKnown = $(embedDir "src/Simplex/Messaging/Server/Web/.well-known/")
@@ -229,7 +229,7 @@
<td>Source code:</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>
<x-noSourceCode>add to ${iniFileName} (required by <a href="https://github.com/simplex-chat/simplexmq/blob/stable/LICENSE" target="_blank">AGPLv3</a>)</x-noSourceCode>
</td>
</tr>
<x-website>
@@ -317,6 +317,7 @@
<h2 class="text-[30px] mb-[20px] leading-[28px] text-[#606C71] dark:text-white font-bold max-w-[475px]">
Configuration</h2>
<table id="config">
<x-smpConfig>
<tr class="text-grey-black dark:text-white text-base">
<td>Persistence:</td>
<td>${persistence}</td>
@@ -337,6 +338,25 @@
<td>Basic auth enabled:</td>
<td>${basicAuthEnabled}</td>
</tr>
</x-smpConfig>
<x-xftpConfig>
<tr class="text-grey-black dark:text-white text-base">
<td>File expiration:</td>
<td>${fileExpiration}</td>
</tr>
<tr class="text-grey-black dark:text-white text-base">
<td>Stats enabled:</td>
<td>${statsEnabled}</td>
</tr>
<tr class="text-grey-black dark:text-white text-base">
<td>New uploads allowed:</td>
<td>${newUploadsAllowed}</td>
</tr>
<tr class="text-grey-black dark:text-white text-base">
<td>Basic auth enabled:</td>
<td>${basicAuthEnabled}</td>
</tr>
</x-xftpConfig>
</table>
</div>
</div>

Before

Width:  |  Height:  |  Size: 18 KiB

After

Width:  |  Height:  |  Size: 18 KiB

Before

Width:  |  Height:  |  Size: 16 KiB

After

Width:  |  Height:  |  Size: 16 KiB

Before

Width:  |  Height:  |  Size: 289 KiB

After

Width:  |  Height:  |  Size: 289 KiB

Before

Width:  |  Height:  |  Size: 12 KiB

After

Width:  |  Height:  |  Size: 12 KiB

Before

Width:  |  Height:  |  Size: 1.1 KiB

After

Width:  |  Height:  |  Size: 1.1 KiB

Before

Width:  |  Height:  |  Size: 6.3 KiB

After

Width:  |  Height:  |  Size: 6.3 KiB

Before

Width:  |  Height:  |  Size: 7.2 KiB

After

Width:  |  Height:  |  Size: 7.2 KiB

Before

Width:  |  Height:  |  Size: 8.1 KiB

After

Width:  |  Height:  |  Size: 8.1 KiB

Before

Width:  |  Height:  |  Size: 1.1 KiB

After

Width:  |  Height:  |  Size: 1.1 KiB

Before

Width:  |  Height:  |  Size: 1.2 KiB

After

Width:  |  Height:  |  Size: 1.2 KiB

Before

Width:  |  Height:  |  Size: 632 B

After

Width:  |  Height:  |  Size: 632 B

Before

Width:  |  Height:  |  Size: 3.5 KiB

After

Width:  |  Height:  |  Size: 3.5 KiB

Before

Width:  |  Height:  |  Size: 18 KiB

After

Width:  |  Height:  |  Size: 18 KiB

+3 -2
View File
@@ -30,7 +30,8 @@ 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 qualified SMPWeb
import Simplex.Messaging.Server.Web (serveStaticFiles, attachStaticFiles)
import System.Directory (doesFileExist)
import System.Environment (withArgs)
import System.FilePath ((</>))
@@ -151,7 +152,7 @@ smpServerTestStatic = do
Right ini_ <- readIniFile iniFile
lookupValue "WEB" "https" ini_ `shouldBe` Right "5223"
let smpServerCLI' = smpServerCLI_ Static.generateSite Static.serveStaticFiles Static.attachStaticFiles
let smpServerCLI' = smpServerCLI_ SMPWeb.smpGenerateSite serveStaticFiles attachStaticFiles
let server = capture_ (withArgs ["start"] $ smpServerCLI' cfgPath logPath `catchAny` print)
bracket (async server) cancel $ \_t -> do
threadDelay 1000000
+2
View File
@@ -35,6 +35,7 @@ import Util
import XFTPAgent
import XFTPCLI
import XFTPServerTests (xftpServerTests)
import WebTests (webTests)
import XFTPWebTests (xftpWebTests)
#if defined(dbPostgres)
@@ -150,6 +151,7 @@ main = do
describe "XFTP agent" xftpAgentTests
describe "XFTP Web Client" xftpWebTests
describe "XRCP" remoteControlTests
describe "Web" webTests
describe "Server CLIs" cliTests
#if defined(dbPostgres)
around_ (postgressBracket testDBConnectInfo) $
+70
View File
@@ -0,0 +1,70 @@
{-# LANGUAGE OverloadedStrings #-}
module WebTests where
import Simplex.Messaging.Server.Web (render, section_, item_, timedTTLText)
import Test.Hspec
webTests :: Spec
webTests = describe "Web module" $ do
describe "item_" $ do
it "replaces single placeholder" $
item_ "name" "Alice" "Hello, ${name}!" `shouldBe` "Hello, Alice!"
it "replaces multiple occurrences" $
item_ "x" "1" "${x}+${x}" `shouldBe` "1+1"
it "returns source unchanged when no placeholder found" $
item_ "missing" "val" "no placeholder here" `shouldBe` "no placeholder here"
it "handles empty content" $
item_ "x" "" "a${x}b" `shouldBe` "ab"
it "handles empty source" $
item_ "x" "val" "" `shouldBe` ""
describe "section_" $ do
it "keeps section and replaces items when content is Just" $
section_ "s" (Just "val") "<x-s>${s}</x-s>" `shouldBe` "val"
it "removes section when content is Nothing" $
section_ "s" Nothing "before<x-s>inside</x-s>after" `shouldBe` "beforeafter"
it "keeps section when content is Just empty" $
section_ "s" (Just "") "before<x-s>inside</x-s>after" `shouldBe` "beforeinsideafter"
it "handles multiple sections with same label" $
section_ "s" (Just "X") "<x-s>${s}</x-s>mid<x-s>${s}</x-s>"
`shouldBe` "XmidX"
it "falls back to item replacement when no section markers" $
section_ "s" (Just "val") "just ${s} here" `shouldBe` "just val here"
it "preserves surrounding content" $
section_ "s" (Just "Y") "aaa<x-s>${s}</x-s>bbb" `shouldBe` "aaaYbbb"
it "removes Nothing section preserving surroundings" $
section_ "s" Nothing "aaa<x-s>gone</x-s>bbb" `shouldBe` "aaabbb"
describe "render" $ do
it "applies multiple substitutions" $
render "Hello ${name}, you are ${age}." [("name", Just "Bob"), ("age", Just "30")]
`shouldBe` "Hello Bob, you are 30."
it "removes sections with Nothing" $
render "<x-opt>optional: ${opt}</x-opt>kept" [("opt", Nothing)]
`shouldBe` "kept"
it "handles mixed present and absent substitutions" $
render "<x-a>${a}</x-a><x-b>${b}</x-b>" [("a", Just "yes"), ("b", Nothing)]
`shouldBe` "yes"
it "returns source unchanged with empty substitutions" $
render "unchanged" [] `shouldBe` "unchanged"
describe "timedTTLText" $ do
it "formats zero" $
timedTTLText (0 :: Int) `shouldBe` "0 sec"
it "formats seconds" $
timedTTLText (45 :: Int) `shouldBe` "45 sec"
it "formats minutes and seconds" $
timedTTLText (90 :: Int) `shouldBe` "1 min 30 sec"
it "formats hours" $
timedTTLText (3600 :: Int) `shouldBe` "1 hour"
it "formats multiple hours" $
timedTTLText (7200 :: Int) `shouldBe` "2 hours"
it "formats days" $
timedTTLText (86400 :: Int) `shouldBe` "1 day"
it "formats weeks" $
timedTTLText (604800 :: Int) `shouldBe` "1 week"
it "formats months" $
timedTTLText (2592000 :: Int) `shouldBe` "1 month"
it "formats compound duration" $
timedTTLText (90061 :: Int) `shouldBe` "1 day 1 hour 1 min 1 sec"
+2 -1
View File
@@ -135,7 +135,8 @@ testXFTPServerConfig =
prometheusInterval = Nothing,
prometheusMetricsFile = xftpTestPrometheusMetricsFile,
transportConfig = mkTransportServerConfig True (Just alpnSupportedXFTPhandshakes) False,
responseDelay = 0
responseDelay = 0,
webStaticPath = Nothing
}
testXFTPClientConfig :: XFTPClientConfig