xftp: add web page for server information (#1724)

* xftp: add web page for server information

* web: rename XFTP.Web to XFTPWeb, remove XFTP subdirectory

* refactor(xftp): remove storage quota from web page

* refactor

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>

apps/xftp-server/Main.hs

@@ -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

apps/xftp-server/XFTPWeb.hs

@@ -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"

simplexmq.cabal

@@ -445,6 +445,7 @@ executable xftp-server
       buildable: False
   main-is: Main.hs
   other-modules:
+      XFTPWeb
       Paths_simplexmq
   hs-source-dirs:
       apps/xftp-server
@@ -453,6 +454,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
@@ -497,6 +499,7 @@ test-suite simplexmq-test
       WebTests
       XFTPWebTests
       SMPWeb
+      XFTPWeb
       Paths_simplexmq
   if flag(client_postgres)
       other-modules:
@@ -514,6 +517,7 @@ test-suite simplexmq-test
   hs-source-dirs:
       tests
       apps/smp-server
+      apps/xftp-server
   default-extensions:
       StrictData
   -- add -fhpc to ghc-options to run tests with coverage

src/Simplex/FileTransfer/Server.hs

@@ -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

src/Simplex/FileTransfer/Server/Env.hs

@@ -77,7 +77,8 @@ data XFTPServerConfig = XFTPServerConfig
     prometheusInterval :: Maybe Int,
     prometheusMetricsFile :: FilePath,
     transportConfig :: TransportServerConfig,
-    responseDelay :: Int
+    responseDelay :: Int,
+    webStaticPath :: Maybe FilePath
   }
 
 defaultInactiveClientExpiration :: ExpirationConfig

src/Simplex/FileTransfer/Server/Main.hs

@@ -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}

src/Simplex/Messaging/Server/Web/index.html

@@ -339,6 +339,24 @@
                 <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>

tests/XFTPClient.hs

@@ -135,7 +135,8 @@ testXFTPServerConfig =
       prometheusInterval = Nothing,
       prometheusMetricsFile = xftpTestPrometheusMetricsFile,
       transportConfig = mkTransportServerConfig True (Just alpnSupportedXFTPhandshakes) False,
-      responseDelay = 0
+      responseDelay = 0,
+      webStaticPath = Nothing
     }
 
 testXFTPClientConfig :: XFTPClientConfig