diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index 36abd1091..3a334d0d5 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -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 diff --git a/apps/smp-server/SMPWeb.hs b/apps/smp-server/SMPWeb.hs new file mode 100644 index 000000000..efa7edee3 --- /dev/null +++ b/apps/smp-server/SMPWeb.hs @@ -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" diff --git a/apps/smp-server/static/a/index.html b/apps/smp-server/static/a/index.html deleted file mode 120000 index 1140bcf31..000000000 --- a/apps/smp-server/static/a/index.html +++ /dev/null @@ -1 +0,0 @@ -../link.html \ No newline at end of file diff --git a/apps/smp-server/static/c/index.html b/apps/smp-server/static/c/index.html deleted file mode 120000 index 1140bcf31..000000000 --- a/apps/smp-server/static/c/index.html +++ /dev/null @@ -1 +0,0 @@ -../link.html \ No newline at end of file diff --git a/apps/smp-server/static/contact/index.html b/apps/smp-server/static/contact/index.html deleted file mode 120000 index 1140bcf31..000000000 --- a/apps/smp-server/static/contact/index.html +++ /dev/null @@ -1 +0,0 @@ -../link.html \ No newline at end of file diff --git a/apps/smp-server/static/i/index.html b/apps/smp-server/static/i/index.html deleted file mode 120000 index 1140bcf31..000000000 --- a/apps/smp-server/static/i/index.html +++ /dev/null @@ -1 +0,0 @@ -../link.html \ No newline at end of file diff --git a/apps/smp-server/static/invitation/index.html b/apps/smp-server/static/invitation/index.html deleted file mode 120000 index 1140bcf31..000000000 --- a/apps/smp-server/static/invitation/index.html +++ /dev/null @@ -1 +0,0 @@ -../link.html \ No newline at end of file diff --git a/apps/smp-server/web/Static/Embedded.hs b/apps/smp-server/web/Static/Embedded.hs deleted file mode 100644 index c1c4fde2f..000000000 --- a/apps/smp-server/web/Static/Embedded.hs +++ /dev/null @@ -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/") diff --git a/simplexmq.cabal b/simplexmq.cabal index ee0654e9a..bd4cdabcc 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -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 @@ -245,6 +245,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 @@ -341,11 +343,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) @@ -402,30 +409,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 @@ -498,9 +494,9 @@ test-suite simplexmq-test XFTPCLI XFTPClient XFTPServerTests + WebTests XFTPWebTests - Static - Static.Embedded + SMPWeb Paths_simplexmq if flag(client_postgres) other-modules: @@ -517,7 +513,7 @@ test-suite simplexmq-test PostgresSchemaDump hs-source-dirs: tests - apps/smp-server/web + apps/smp-server default-extensions: StrictData -- add -fhpc to ghc-options to run tests with coverage @@ -535,7 +531,6 @@ test-suite simplexmq-test , crypton-x509-store , crypton-x509-validation , directory - , file-embed , filepath , generic-random ==1.5.* , hashable @@ -564,10 +559,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) diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 1e8490bec..92f0b0821 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -75,6 +75,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 @@ -569,7 +570,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 @@ -610,18 +611,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 () @@ -745,18 +745,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 diff --git a/apps/smp-server/web/Static.hs b/src/Simplex/Messaging/Server/Web.hs similarity index 52% rename from apps/smp-server/web/Static.hs rename to src/Simplex/Messaging/Server/Web.hs index cf6d5834b..23a534429 100644 --- a/apps/smp-server/web/Static.hs +++ b/src/Simplex/Messaging/Server/Web.hs @@ -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 = " label <> ">" endMarker = " 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 diff --git a/apps/smp-server/static/.well-known/apple-app-site-association b/src/Simplex/Messaging/Server/Web/.well-known/apple-app-site-association similarity index 100% rename from apps/smp-server/static/.well-known/apple-app-site-association rename to src/Simplex/Messaging/Server/Web/.well-known/apple-app-site-association diff --git a/apps/smp-server/static/.well-known/assetlinks.json b/src/Simplex/Messaging/Server/Web/.well-known/assetlinks.json similarity index 100% rename from apps/smp-server/static/.well-known/assetlinks.json rename to src/Simplex/Messaging/Server/Web/.well-known/assetlinks.json diff --git a/src/Simplex/Messaging/Server/Web/Embedded.hs b/src/Simplex/Messaging/Server/Web/Embedded.hs new file mode 100644 index 000000000..7345829cc --- /dev/null +++ b/src/Simplex/Messaging/Server/Web/Embedded.hs @@ -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/") diff --git a/apps/smp-server/static/index.html b/src/Simplex/Messaging/Server/Web/index.html similarity index 99% rename from apps/smp-server/static/index.html rename to src/Simplex/Messaging/Server/Web/index.html index a66cd7988..2c1ac871a 100644 --- a/apps/smp-server/static/index.html +++ b/src/Simplex/Messaging/Server/Web/index.html @@ -229,7 +229,7 @@ Source code: ${sourceCode} - add to smp-server.ini (required by AGPLv3) + add to ${iniFileName} (required by AGPLv3) @@ -317,6 +317,7 @@

Configuration

+ @@ -337,6 +338,7 @@ +
Persistence: ${persistence}Basic auth enabled: ${basicAuthEnabled}
diff --git a/apps/smp-server/static/link.html b/src/Simplex/Messaging/Server/Web/link.html similarity index 100% rename from apps/smp-server/static/link.html rename to src/Simplex/Messaging/Server/Web/link.html diff --git a/apps/smp-server/static/media/GilroyBold.woff2 b/src/Simplex/Messaging/Server/Web/media/GilroyBold.woff2 similarity index 100% rename from apps/smp-server/static/media/GilroyBold.woff2 rename to src/Simplex/Messaging/Server/Web/media/GilroyBold.woff2 diff --git a/apps/smp-server/static/media/GilroyLight.woff2 b/src/Simplex/Messaging/Server/Web/media/GilroyLight.woff2 similarity index 100% rename from apps/smp-server/static/media/GilroyLight.woff2 rename to src/Simplex/Messaging/Server/Web/media/GilroyLight.woff2 diff --git a/apps/smp-server/static/media/GilroyMedium.woff2 b/src/Simplex/Messaging/Server/Web/media/GilroyMedium.woff2 similarity index 100% rename from apps/smp-server/static/media/GilroyMedium.woff2 rename to src/Simplex/Messaging/Server/Web/media/GilroyMedium.woff2 diff --git a/apps/smp-server/static/media/GilroyRegular.woff2 b/src/Simplex/Messaging/Server/Web/media/GilroyRegular.woff2 similarity index 100% rename from apps/smp-server/static/media/GilroyRegular.woff2 rename to src/Simplex/Messaging/Server/Web/media/GilroyRegular.woff2 diff --git a/apps/smp-server/static/media/GilroyRegularItalic.woff2 b/src/Simplex/Messaging/Server/Web/media/GilroyRegularItalic.woff2 similarity index 100% rename from apps/smp-server/static/media/GilroyRegularItalic.woff2 rename to src/Simplex/Messaging/Server/Web/media/GilroyRegularItalic.woff2 diff --git a/apps/smp-server/static/media/apk_icon.png b/src/Simplex/Messaging/Server/Web/media/apk_icon.png similarity index 100% rename from apps/smp-server/static/media/apk_icon.png rename to src/Simplex/Messaging/Server/Web/media/apk_icon.png diff --git a/apps/smp-server/static/media/apple_store.svg b/src/Simplex/Messaging/Server/Web/media/apple_store.svg similarity index 100% rename from apps/smp-server/static/media/apple_store.svg rename to src/Simplex/Messaging/Server/Web/media/apple_store.svg diff --git a/apps/smp-server/static/media/contact.js b/src/Simplex/Messaging/Server/Web/media/contact.js similarity index 100% rename from apps/smp-server/static/media/contact.js rename to src/Simplex/Messaging/Server/Web/media/contact.js diff --git a/apps/smp-server/static/media/contact_page_mobile.png b/src/Simplex/Messaging/Server/Web/media/contact_page_mobile.png similarity index 100% rename from apps/smp-server/static/media/contact_page_mobile.png rename to src/Simplex/Messaging/Server/Web/media/contact_page_mobile.png diff --git a/apps/smp-server/static/media/f_droid.svg b/src/Simplex/Messaging/Server/Web/media/f_droid.svg similarity index 100% rename from apps/smp-server/static/media/f_droid.svg rename to src/Simplex/Messaging/Server/Web/media/f_droid.svg diff --git a/apps/smp-server/static/media/favicon.ico b/src/Simplex/Messaging/Server/Web/media/favicon.ico similarity index 100% rename from apps/smp-server/static/media/favicon.ico rename to src/Simplex/Messaging/Server/Web/media/favicon.ico diff --git a/apps/smp-server/static/media/google_play.svg b/src/Simplex/Messaging/Server/Web/media/google_play.svg similarity index 100% rename from apps/smp-server/static/media/google_play.svg rename to src/Simplex/Messaging/Server/Web/media/google_play.svg diff --git a/apps/smp-server/static/media/logo-dark.png b/src/Simplex/Messaging/Server/Web/media/logo-dark.png similarity index 100% rename from apps/smp-server/static/media/logo-dark.png rename to src/Simplex/Messaging/Server/Web/media/logo-dark.png diff --git a/apps/smp-server/static/media/logo-light.png b/src/Simplex/Messaging/Server/Web/media/logo-light.png similarity index 100% rename from apps/smp-server/static/media/logo-light.png rename to src/Simplex/Messaging/Server/Web/media/logo-light.png diff --git a/apps/smp-server/static/media/logo-symbol-dark.svg b/src/Simplex/Messaging/Server/Web/media/logo-symbol-dark.svg similarity index 100% rename from apps/smp-server/static/media/logo-symbol-dark.svg rename to src/Simplex/Messaging/Server/Web/media/logo-symbol-dark.svg diff --git a/apps/smp-server/static/media/logo-symbol-light.svg b/src/Simplex/Messaging/Server/Web/media/logo-symbol-light.svg similarity index 100% rename from apps/smp-server/static/media/logo-symbol-light.svg rename to src/Simplex/Messaging/Server/Web/media/logo-symbol-light.svg diff --git a/apps/smp-server/static/media/moon.svg b/src/Simplex/Messaging/Server/Web/media/moon.svg similarity index 100% rename from apps/smp-server/static/media/moon.svg rename to src/Simplex/Messaging/Server/Web/media/moon.svg diff --git a/apps/smp-server/static/media/qrcode.js b/src/Simplex/Messaging/Server/Web/media/qrcode.js similarity index 100% rename from apps/smp-server/static/media/qrcode.js rename to src/Simplex/Messaging/Server/Web/media/qrcode.js diff --git a/apps/smp-server/static/media/script.js b/src/Simplex/Messaging/Server/Web/media/script.js similarity index 100% rename from apps/smp-server/static/media/script.js rename to src/Simplex/Messaging/Server/Web/media/script.js diff --git a/apps/smp-server/static/media/style.css b/src/Simplex/Messaging/Server/Web/media/style.css similarity index 100% rename from apps/smp-server/static/media/style.css rename to src/Simplex/Messaging/Server/Web/media/style.css diff --git a/apps/smp-server/static/media/sun.svg b/src/Simplex/Messaging/Server/Web/media/sun.svg similarity index 100% rename from apps/smp-server/static/media/sun.svg rename to src/Simplex/Messaging/Server/Web/media/sun.svg diff --git a/apps/smp-server/static/media/swiper-bundle.min.css b/src/Simplex/Messaging/Server/Web/media/swiper-bundle.min.css similarity index 100% rename from apps/smp-server/static/media/swiper-bundle.min.css rename to src/Simplex/Messaging/Server/Web/media/swiper-bundle.min.css diff --git a/apps/smp-server/static/media/swiper-bundle.min.js b/src/Simplex/Messaging/Server/Web/media/swiper-bundle.min.js similarity index 100% rename from apps/smp-server/static/media/swiper-bundle.min.js rename to src/Simplex/Messaging/Server/Web/media/swiper-bundle.min.js diff --git a/apps/smp-server/static/media/tailwind.css b/src/Simplex/Messaging/Server/Web/media/tailwind.css similarity index 100% rename from apps/smp-server/static/media/tailwind.css rename to src/Simplex/Messaging/Server/Web/media/tailwind.css diff --git a/apps/smp-server/static/media/testflight.png b/src/Simplex/Messaging/Server/Web/media/testflight.png similarity index 100% rename from apps/smp-server/static/media/testflight.png rename to src/Simplex/Messaging/Server/Web/media/testflight.png diff --git a/tests/CLITests.hs b/tests/CLITests.hs index 30d798ca7..798b3e939 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -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 diff --git a/tests/Test.hs b/tests/Test.hs index dcc5de3fb..c3fe92953 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -35,6 +35,7 @@ import Util import XFTPAgent import XFTPCLI import XFTPServerTests (xftpServerTests) +import WebTests (webTests) import XFTPWebTests (xftpWebTests) #if defined(dbPostgres) @@ -152,6 +153,7 @@ main = do describe "XFTP agent" xftpAgentTests describe "XFTP Web Client" xftpWebTests describe "XRCP" remoteControlTests + describe "Web" webTests describe "Server CLIs" cliTests eventuallyRemove :: FilePath -> Int -> IO () diff --git a/tests/WebTests.hs b/tests/WebTests.hs new file mode 100644 index 000000000..9eb123d34 --- /dev/null +++ b/tests/WebTests.hs @@ -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") "${s}" `shouldBe` "val" + it "removes section when content is Nothing" $ + section_ "s" Nothing "beforeinsideafter" `shouldBe` "beforeafter" + it "keeps section when content is Just empty" $ + section_ "s" (Just "") "beforeinsideafter" `shouldBe` "beforeinsideafter" + it "handles multiple sections with same label" $ + section_ "s" (Just "X") "${s}mid${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${s}bbb" `shouldBe` "aaaYbbb" + it "removes Nothing section preserving surroundings" $ + section_ "s" Nothing "aaagonebbb" `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 "optional: ${opt}kept" [("opt", Nothing)] + `shouldBe` "kept" + it "handles mixed present and absent substitutions" $ + render "${a}${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"