refactor: parameterize XFTPServerConfig over store type

Embed XFTPStoreConfig s as serverStoreCfg field, matching SMP's
ServerConfig. runXFTPServer and newXFTPServerEnv now take a single
XFTPServerConfig s. Restore verifyCmd local helper structure.

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

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

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

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,