diff --git a/apps/xftp-server/XFTPWeb.hs b/apps/xftp-server/XFTPWeb.hs index a3edb41f0..a9ee55e15 100644 --- a/apps/xftp-server/XFTPWeb.hs +++ b/apps/xftp-server/XFTPWeb.hs @@ -34,7 +34,7 @@ xftpMediaContent = $(embedDir "apps/xftp-server/static/media/") xftpFilePageHtml :: ByteString xftpFilePageHtml = $(embedFile "apps/xftp-server/static/file.html") -xftpGenerateSite :: XFTPServerConfig -> Maybe ServerPublicInfo -> Maybe TransportHost -> FilePath -> IO () +xftpGenerateSite :: XFTPServerConfig s -> Maybe ServerPublicInfo -> Maybe TransportHost -> FilePath -> IO () xftpGenerateSite cfg info onionHost path = do let substs = xftpSubsts cfg info onionHost Web.generateSite embeddedContent (render (Web.indexHtml embeddedContent) substs) [] path @@ -50,10 +50,10 @@ xftpGenerateSite cfg info onionHost path = do createDirectoryIfMissing True dir forM_ content_ $ \(fp, content) -> B.writeFile (dir fp) content -xftpServerInformation :: XFTPServerConfig -> Maybe ServerPublicInfo -> Maybe TransportHost -> ByteString +xftpServerInformation :: XFTPServerConfig s -> Maybe ServerPublicInfo -> Maybe TransportHost -> ByteString xftpServerInformation cfg info onionHost = render (Web.indexHtml embeddedContent) (xftpSubsts cfg info onionHost) -xftpSubsts :: XFTPServerConfig -> Maybe ServerPublicInfo -> Maybe TransportHost -> [(ByteString, Maybe ByteString)] +xftpSubsts :: XFTPServerConfig s -> Maybe ServerPublicInfo -> Maybe TransportHost -> [(ByteString, Maybe ByteString)] xftpSubsts XFTPServerConfig {fileExpiration, logStatsInterval, allowNewFiles, newFileBasicAuth} information onionHost = [("smpConfig", Nothing), ("xftpConfig", Just "y")] <> substConfig <> serverInfoSubsts simplexmqSource information <> [("onionHost", strEncode <$> onionHost), ("iniFileName", Just "file-server.ini")] where diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index fc57b777a..a7a7d7f7b 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -111,19 +111,19 @@ corsPreflightHeaders = ("Access-Control-Max-Age", "86400") ] -runXFTPServer :: FileStoreClass s => XFTPStoreConfig s -> XFTPServerConfig -> IO () -runXFTPServer storeCfg cfg = do +runXFTPServer :: FileStoreClass s => XFTPServerConfig s -> IO () +runXFTPServer cfg = do started <- newEmptyTMVarIO - runXFTPServerBlocking started storeCfg cfg + runXFTPServerBlocking started cfg -runXFTPServerBlocking :: FileStoreClass s => TMVar Bool -> XFTPStoreConfig s -> XFTPServerConfig -> IO () -runXFTPServerBlocking started storeCfg cfg = newXFTPServerEnv storeCfg cfg >>= runReaderT (xftpServer cfg started) +runXFTPServerBlocking :: FileStoreClass s => TMVar Bool -> XFTPServerConfig s -> IO () +runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started) data Handshake = HandshakeSent C.PrivateKeyX25519 | HandshakeAccepted (THandleParams XFTPVersion 'TServer) -xftpServer :: forall s. FileStoreClass s => XFTPServerConfig -> TMVar Bool -> M s () +xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s () xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do mapM_ (expireServerFiles Nothing) fileExpiration restoreServerStats @@ -244,7 +244,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira saveServerStats logNote "Server stopped" - expireFilesThread_ :: XFTPServerConfig -> [M s ()] + expireFilesThread_ :: XFTPServerConfig s -> [M s ()] expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp] expireFilesThread_ _ = [] @@ -255,7 +255,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira liftIO $ threadDelay' interval expireServerFiles (Just 100000) expCfg - serverStatsThread_ :: XFTPServerConfig -> [M s ()] + serverStatsThread_ :: XFTPServerConfig s -> [M s ()] serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = [logServerStats logStatsStartTime interval serverStatsLogFile] serverStatsThread_ _ = [] @@ -301,7 +301,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira ] liftIO $ threadDelay' interval - prometheusMetricsThread_ :: XFTPServerConfig -> [M s ()] + prometheusMetricsThread_ :: XFTPServerConfig s -> [M s ()] prometheusMetricsThread_ XFTPServerConfig {prometheusInterval = Just interval, prometheusMetricsFile} = [savePrometheusMetrics interval prometheusMetricsFile] prometheusMetricsThread_ _ = [] @@ -325,7 +325,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira let fd = periodStatDataCounts $ _filesDownloaded d pure FileServerMetrics {statsData = d, filesDownloadedPeriods = fd, rtsOptions} - controlPortThread_ :: XFTPServerConfig -> [M s ()] + controlPortThread_ :: XFTPServerConfig s -> [M s ()] controlPortThread_ XFTPServerConfig {controlPort = Just port} = [runCPServer port] controlPortThread_ _ = [] @@ -451,15 +451,16 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = verifyCmd :: SFileParty p -> M s VerificationResult verifyCmd party = do st <- asks store - liftIO (getFile st party fId) >>= \case - Right (fr, k) -> do - status <- readTVarIO (fileStatus fr) - pure $ case status of - EntityActive -> XFTPReqCmd fId fr cmd `verifyWith` k - EntityBlocked info -> VRFailed $ BLOCKED info - EntityOff -> noFileAuth - Left _ -> pure noFileAuth + liftIO $ verify =<< getFile st party fId where + verify = \case + Right (fr, k) -> result <$> readTVarIO (fileStatus fr) + where + result = \case + EntityActive -> XFTPReqCmd fId fr cmd `verifyWith` k + EntityBlocked info -> VRFailed $ BLOCKED info + EntityOff -> noFileAuth + Left _ -> pure noFileAuth noFileAuth = dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH -- TODO verify with DH authorization req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 3a2e6d785..cf88630f9 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -58,10 +58,11 @@ import Simplex.Messaging.Util (tshow) import System.IO (IOMode (..)) import UnliftIO.STM -data XFTPServerConfig = XFTPServerConfig +data XFTPServerConfig s = XFTPServerConfig { xftpPort :: ServiceName, controlPort :: Maybe ServiceName, fileIdSize :: Int, + serverStoreCfg :: XFTPStoreConfig s, storeLogFile :: Maybe FilePath, filesPath :: FilePath, -- | server storage quota @@ -111,7 +112,7 @@ data XFTPStoreConfig s where #endif data XFTPEnv s = XFTPEnv - { config :: XFTPServerConfig, + { config :: XFTPServerConfig s, store :: s, usedStorage :: TVar Int64, storeLog :: Maybe (StoreLog 'WriteMode), @@ -132,10 +133,10 @@ defaultFileExpiration = checkInterval = 2 * 3600 -- seconds, 2 hours } -newXFTPServerEnv :: FileStoreClass s => XFTPStoreConfig s -> XFTPServerConfig -> IO (XFTPEnv s) -newXFTPServerEnv storeCfg config@XFTPServerConfig {fileSizeQuota, xftpCredentials, httpCredentials} = do +newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s) +newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCredentials, httpCredentials} = do random <- C.newRandom - (store, storeLog) <- case storeCfg of + (store, storeLog) <- case serverStoreCfg of XSCMemory storeLogPath -> do st <- newFileStore () sl <- mapM (`readWriteFileStore` st) storeLogPath diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 9f5045300..9b31dcce5 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} module Simplex.FileTransfer.Server.Main @@ -28,7 +29,7 @@ import Options.Applicative import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Description (FileSize (..)) import Simplex.FileTransfer.Server (runXFTPServer) -import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, runWithStoreConfig, checkFileStoreMode, importToDatabase, exportFromDatabase) +import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig, defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, runWithStoreConfig, checkFileStoreMode, importToDatabase, exportFromDatabase) import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -52,7 +53,7 @@ xftpServerCLI :: FilePath -> FilePath -> IO () xftpServerCLI = xftpServerCLI_ (\_ _ _ _ -> pure ()) (\_ -> pure ()) xftpServerCLI_ :: - (XFTPServerConfig -> Maybe ServerPublicInfo -> Maybe TransportHost -> FilePath -> IO ()) -> + (forall s. XFTPServerConfig s -> Maybe ServerPublicInfo -> Maybe TransportHost -> FilePath -> IO ()) -> (EmbeddedWebParams -> IO ()) -> FilePath -> FilePath -> @@ -211,21 +212,22 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do 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 () let storeType = fromRight "memory" $ T.unpack <$> lookupValue "STORE_LOG" "store_files" ini checkFileStoreMode ini storeType storeLogFilePath - runWithStoreConfig ini storeType (storeLogFile serverConfig) storeLogFilePath confirmMigrations $ - \storeCfg -> runXFTPServer storeCfg serverConfig + runWithStoreConfig ini storeType (enableStoreLog $> storeLogFilePath) storeLogFilePath confirmMigrations $ \storeCfg -> do + let cfg = serverConfig storeCfg + printXFTPConfig cfg + 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 cfg information onionHost path + when (isJust webHttpPort || isJust webHttpsParams') $ + serveStaticFiles EmbeddedWebParams {webStaticPath = path, webHttpPort, webHttpsParams = webHttpsParams'} + Nothing -> pure () + runXFTPServer cfg where isOnion = \case THOnionHost _ -> True; _ -> False enableStoreLog = settingIsOn "STORE_LOG" "enable" ini @@ -267,11 +269,13 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do webStaticPath' = eitherToMaybe $ T.unpack <$> lookupValue "WEB" "static_path" ini - serverConfig = + serverConfig :: XFTPStoreConfig s -> XFTPServerConfig s + serverConfig serverStoreCfg = XFTPServerConfig { xftpPort = T.unpack $ strictIni "TRANSPORT" "port" ini, controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini, fileIdSize = 16, + serverStoreCfg, storeLogFile = enableStoreLog $> storeLogFilePath, filesPath = T.unpack $ strictIni "FILES" "path" ini, fileSizeQuota = either error unFileSize <$> strDecodeIni "FILES" "storage_quota" ini,