From fbccca9947ede340cb6fcba6bbce75b6513f5042 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 18 Nov 2022 08:37:03 +0000 Subject: [PATCH] refactor server CLIs (#565) * refactor server CLIs * refactor --- .../Messaging/Notifications/Server/Main.hs | 205 +++++++---- src/Simplex/Messaging/Server/CLI.hs | 335 +++++++----------- src/Simplex/Messaging/Server/Main.hs | 287 +++++++++------ tests/CLITests.hs | 16 +- 4 files changed, 460 insertions(+), 383 deletions(-) diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index d92d7a351..4eeff27a7 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -1,76 +1,159 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Simplex.Messaging.Notifications.Server.Main where import Data.Functor (($>)) -import Data.Ini (lookupValue) +import Data.Ini (readIniFile) +import Data.Maybe (fromMaybe) +import Network.Socket (HostName) +import Options.Applicative import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig) import Simplex.Messaging.Notifications.Server (runNtfServer) import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig) -import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI) +import Simplex.Messaging.Server.CLI +import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) +import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) +import Text.Read (readMaybe) ntfServerCLI :: FilePath -> FilePath -> IO () -ntfServerCLI cfgPath logPath = protocolServerCLI (ntfServerCLIConfig cfgPath logPath) runNtfServer +ntfServerCLI cfgPath logPath = + getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case + Init opts -> + doesFileExist iniFile >>= \case + True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`." + _ -> initializeServer opts + Start -> + doesFileExist iniFile >>= \case + True -> readIniFile iniFile >>= either exitError runServer + _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." + Delete -> do + confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" + deleteDirIfExists cfgPath + deleteDirIfExists logPath + putStrLn "Deleted configuration and log files" + where + iniFile = combine cfgPath "ntf-server.ini" + serverVersion = "SMP notifications server v1.2.0" + defaultServerPort = "443" + executableName = "ntf-server" + storeLogFilePath = combine logPath "ntf-server-store.log" + initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do + deleteDirIfExists cfgPath + deleteDirIfExists logPath + createDirectoryIfMissing True cfgPath + createDirectoryIfMissing True logPath + let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm} + fp <- createServerX509 cfgPath x509cfg + writeFile iniFile iniFileContent + putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server." + printServiceInfo serverVersion fp + warnCAPrivateKeyFile cfgPath x509cfg + where + iniFileContent = + "[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\ + \# and restoring it when the server is started.\n\ + \# Log is compacted on start (deleted objects are removed).\n\ + \enable: " + <> (if enableStoreLog then "on" else "off") + <> "\n\ + \log_stats: off\n\n\ + \[TRANSPORT]\n\ + \port: " + <> defaultServerPort + <> "\n\ + \websockets: off\n" + runServer ini = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + fp <- checkSavedFingerprint cfgPath defaultX509Config + printServiceInfo serverVersion fp + let cfg@NtfServerConfig {transports, storeLogFile} = serverConfig + printServerConfig transports storeLogFile + runNtfServer cfg + where + enableStoreLog = settingIsOn "STORE_LOG" "enable" ini + logStats = settingIsOn "STORE_LOG" "log_stats" ini + c = combine cfgPath . ($ defaultX509Config) + serverConfig = + NtfServerConfig + { transports = iniTransports ini, + subIdBytes = 24, + regCodeBytes = 32, + clientQSize = 16, + subQSize = 64, + pushQSize = 128, + smpAgentCfg = defaultSMPClientAgentConfig, + apnsConfig = defaultAPNSPushClientConfig, + inactiveClientExpiration = Nothing, + storeLogFile = enableStoreLog $> storeLogFilePath, + resubscribeDelay = 50000, -- 50ms + caCertificateFile = c caCrtFile, + privateKeyFile = c serverKeyFile, + certificateFile = c serverCrtFile, + logStatsInterval = logStats $> 86400, -- seconds + logStatsStartTime = 0, -- seconds from 00:00 UTC + serverStatsLogFile = combine logPath "ntf-server-stats.daily.log", + serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log" + } -ntfServerCLIConfig :: FilePath -> FilePath -> ServerCLIConfig NtfServerConfig -ntfServerCLIConfig cfgPath logPath = - let caCrtFile = combine cfgPath "ca.crt" - serverKeyFile = combine cfgPath "server.key" - serverCrtFile = combine cfgPath "server.crt" - in ServerCLIConfig - { cfgDir = cfgPath, - logDir = logPath, - iniFile = combine cfgPath "ntf-server.ini", - storeLogFile = combine logPath "ntf-server-store.log", - caKeyFile = combine cfgPath "ca.key", - caCrtFile, - serverKeyFile, - serverCrtFile, - fingerprintFile = combine cfgPath "fingerprint", - defaultServerPort = "443", - executableName = "ntf-server", - serverVersion = "SMP notifications server v1.2.0", - mkIniFile = \enableStoreLog defaultServerPort -> - "[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\ - \# and restoring it when the server is started.\n\ - \# Log is compacted on start (deleted objects are removed).\n\ - \enable: " - <> (if enableStoreLog then "on" else "off") - <> "\n\ - \log_stats: off\n\n\ - \[TRANSPORT]\n\ - \port: " - <> defaultServerPort - <> "\n\ - \websockets: off\n", - mkServerConfig = \storeLogFile transports ini -> - let settingIsOn section name = if lookupValue section name ini == Right "on" then Just () else Nothing - logStats = settingIsOn "STORE_LOG" "log_stats" - in NtfServerConfig - { transports, - subIdBytes = 24, - regCodeBytes = 32, - clientQSize = 16, - subQSize = 64, - pushQSize = 128, - smpAgentCfg = defaultSMPClientAgentConfig, - apnsConfig = defaultAPNSPushClientConfig, - inactiveClientExpiration = Nothing, - storeLogFile, - resubscribeDelay = 50000, -- 50ms - caCertificateFile = caCrtFile, - privateKeyFile = serverKeyFile, - certificateFile = serverCrtFile, - logStatsInterval = logStats $> 86400, -- seconds - logStatsStartTime = 0, -- seconds from 00:00 UTC - serverStatsLogFile = combine logPath "ntf-server-stats.daily.log", - serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log" - } - } +data CliCommand + = Init InitOptions + | Start + | Delete + +data InitOptions = InitOptions + { enableStoreLog :: Bool, + signAlgorithm :: SignAlgorithm, + ip :: HostName, + fqdn :: Maybe HostName + } + deriving (Show) + +cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand +cliCommandP cfgPath logPath iniFile = + hsubparser + ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files")) + <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) + <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) + ) + where + initP :: Parser InitOptions + initP = + InitOptions + <$> switch + ( long "store-log" + <> short 'l' + <> help "Enable store log for persistence" + ) + <*> option + (maybeReader readMaybe) + ( long "sign-algorithm" + <> short 'a' + <> help "Signature algorithm used for TLS certificates: ED25519, ED448" + <> value ED448 + <> showDefault + <> metavar "ALG" + ) + <*> strOption + ( long "ip" + <> help + "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied" + <> value "127.0.0.1" + <> showDefault + <> metavar "IP" + ) + <*> (optional . strOption) + ( long "fqdn" + <> short 'n' + <> help "Server FQDN used as Common Name for TLS online certificate" + <> showDefault + <> metavar "FQDN" + ) diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index 408d0f029..c043185a1 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -13,8 +12,7 @@ import Control.Monad import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (fromRight) -import Data.Ini (Ini, lookupValue, readIniFile) -import Data.Maybe (fromMaybe) +import Data.Ini (Ini, lookupValue) import Data.Text (Text) import qualified Data.Text as T import Data.X509.Validation (Fingerprint (..)) @@ -25,45 +23,11 @@ import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport.Server (loadFingerprint) import Simplex.Messaging.Transport.WebSockets (WS) import Simplex.Messaging.Util (whenM) -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removePathForcibly) +import System.Directory (doesDirectoryExist, removeDirectoryRecursive) import System.Exit (exitFailure) import System.FilePath (combine) -import System.IO (BufferMode (..), IOMode (..), hFlush, hGetLine, hSetBuffering, stderr, stdout, withFile) +import System.IO (IOMode (..), hFlush, hGetLine, stdout, withFile) import System.Process (readCreateProcess, shell) -import Text.Read (readMaybe) - -data ServerCLIConfig cfg = ServerCLIConfig - { cfgDir :: FilePath, - logDir :: FilePath, - iniFile :: FilePath, - storeLogFile :: FilePath, - caKeyFile :: FilePath, - caCrtFile :: FilePath, - serverKeyFile :: FilePath, - serverCrtFile :: FilePath, - fingerprintFile :: FilePath, - defaultServerPort :: ServiceName, - executableName :: String, - serverVersion :: String, - mkIniFile :: Bool -> ServiceName -> String, - mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> Ini -> cfg - } - -protocolServerCLI :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IO () -protocolServerCLI cliCfg@ServerCLIConfig {iniFile, executableName} server = - getCliCommand cliCfg >>= \case - Init opts -> - doesFileExist iniFile >>= \case - True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`." - _ -> initializeServer cliCfg opts - Start -> - doesFileExist iniFile >>= \case - True -> readIniFile iniFile >>= either exitError (runServer cliCfg server) - _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." - Delete -> do - confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" - cleanup cliCfg - putStrLn "Deleted configuration and log files" exitError :: String -> IO () exitError msg = putStrLn msg >> exitFailure @@ -76,152 +40,110 @@ confirmOrExit s = do ok <- getLine when (ok /= "Y") exitFailure -data CliCommand - = Init InitOptions - | Start - | Delete - -data InitOptions = InitOptions - { enableStoreLog :: Bool, - signAlgorithm :: SignAlgorithm, - ip :: HostName, - fqdn :: Maybe HostName - } - deriving (Show) - data SignAlgorithm = ED448 | ED25519 deriving (Read, Show) -getCliCommand :: ServerCLIConfig cfg -> IO CliCommand -getCliCommand cliCfg = +data X509Config = X509Config + { commonName :: HostName, + signAlgorithm :: SignAlgorithm, + caKeyFile :: FilePath, + caCrtFile :: FilePath, + serverKeyFile :: FilePath, + serverCrtFile :: FilePath, + fingerprintFile :: FilePath, + opensslCaConfFile :: FilePath, + opensslServerConfFile :: FilePath, + serverCsrFile :: FilePath + } + +defaultX509Config :: X509Config +defaultX509Config = + X509Config + { commonName = "127.0.0.1", + signAlgorithm = ED448, + caKeyFile = "ca.key", + caCrtFile = "ca.crt", + serverKeyFile = "server.key", + serverCrtFile = "server.crt", + fingerprintFile = "fingerprint", + opensslCaConfFile = "openssl_ca.conf", + opensslServerConfFile = "openssl_server.conf", + serverCsrFile = "server.csr" + } + +getCliCommand' :: Parser cmd -> String -> IO cmd +getCliCommand' cmdP version = customExecParser (prefs showHelpOnEmpty) ( info - (helper <*> versionOption <*> cliCommandP cliCfg) + (helper <*> versionOption <*> cmdP) (header version <> fullDesc) ) where versionOption = infoOption version (long "version" <> short 'v' <> help "Show version") - version = serverVersion cliCfg -cliCommandP :: ServerCLIConfig cfg -> Parser CliCommand -cliCommandP ServerCLIConfig {cfgDir, logDir, iniFile} = - hsubparser - ( command "init" (info initP (progDesc $ "Initialize server - creates " <> cfgDir <> " and " <> logDir <> " directories and configuration files")) - <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) - <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) - ) +createServerX509 :: FilePath -> X509Config -> IO ByteString +createServerX509 cfgPath x509cfg = do + createOpensslCaConf + createOpensslServerConf + let alg = show $ signAlgorithm (x509cfg :: X509Config) + -- CA certificate (identity/offline) + run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c caKeyFile + run $ "openssl req -new -x509 -days 999999 -config " <> c opensslCaConfFile <> " -extensions v3 -key " <> c caKeyFile <> " -out " <> c caCrtFile + -- server certificate (online) + run $ "openssl genpkey -algorithm " <> alg <> " -out " <> c serverKeyFile + run $ "openssl req -new -config " <> c opensslServerConfFile <> " -reqexts v3 -key " <> c serverKeyFile <> " -out " <> c serverCsrFile + run $ "openssl x509 -req -days 999999 -extfile " <> c opensslServerConfFile <> " -extensions v3 -in " <> c serverCsrFile <> " -CA " <> c caCrtFile <> " -CAkey " <> c caKeyFile <> " -CAcreateserial -out " <> c serverCrtFile + saveFingerprint where - initP :: Parser CliCommand - initP = - Init - <$> ( InitOptions - <$> switch - ( long "store-log" - <> short 'l' - <> help "Enable store log for persistence" - ) - <*> option - (maybeReader readMaybe) - ( long "sign-algorithm" - <> short 'a' - <> help "Signature algorithm used for TLS certificates: ED25519, ED448" - <> value ED448 - <> showDefault - <> metavar "ALG" - ) - <*> strOption - ( long "ip" - <> help - "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied" - <> value "127.0.0.1" - <> showDefault - <> metavar "IP" - ) - <*> (optional . strOption) - ( long "fqdn" - <> short 'n' - <> help "Server FQDN used as Common Name for TLS online certificate" - <> showDefault - <> metavar "FQDN" - ) - ) - -initializeServer :: ServerCLIConfig cfg -> InitOptions -> IO () -initializeServer cliCfg InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do - clearDirs cliCfg - createDirectoryIfMissing True cfgDir - createDirectoryIfMissing True logDir - createX509 - fp <- saveFingerprint - writeFile iniFile $ mkIniFile enableStoreLog defaultServerPort - putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server." - printServiceInfo cliCfg fp - warnCAPrivateKeyFile - where - ServerCLIConfig {cfgDir, logDir, iniFile, executableName, caKeyFile, caCrtFile, serverKeyFile, serverCrtFile, fingerprintFile, defaultServerPort, mkIniFile} = cliCfg - createX509 = do - createOpensslCaConf - createOpensslServerConf - -- CA certificate (identity/offline) - run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile - run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile - -- server certificate (online) - run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile - run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile - run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile - where - run cmd = void $ readCreateProcess (shell cmd) "" - opensslCaConfFile = combine cfgDir "openssl_ca.conf" - opensslServerConfFile = combine cfgDir "openssl_server.conf" - serverCsrFile = combine cfgDir "server.csr" - createOpensslCaConf = - writeFile - opensslCaConfFile - "[req]\n\ - \distinguished_name = req_distinguished_name\n\ - \prompt = no\n\n\ - \[req_distinguished_name]\n\ - \CN = SMP server CA\n\ - \O = SimpleX\n\n\ - \[v3]\n\ - \subjectKeyIdentifier = hash\n\ - \authorityKeyIdentifier = keyid:always\n\ - \basicConstraints = critical,CA:true\n" - -- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5 - -- IP and FQDN can't both be used as server address interchangeably even if IP is added - -- as Subject Alternative Name, unless the following validation hook is disabled: - -- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName - createOpensslServerConf = - writeFile - opensslServerConfFile - ( "[req]\n\ - \distinguished_name = req_distinguished_name\n\ - \prompt = no\n\n\ - \[req_distinguished_name]\n" - <> ("CN = " <> cn <> "\n\n") - <> "[v3]\n\ - \basicConstraints = CA:FALSE\n\ - \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\ - \extendedKeyUsage = serverAuth\n" - ) - where - cn = fromMaybe ip fqdn + run cmd = void $ readCreateProcess (shell cmd) "" + c = combine cfgPath . ($ x509cfg) + createOpensslCaConf = + writeFile + (c opensslCaConfFile) + "[req]\n\ + \distinguished_name = req_distinguished_name\n\ + \prompt = no\n\n\ + \[req_distinguished_name]\n\ + \CN = SMP server CA\n\ + \O = SimpleX\n\n\ + \[v3]\n\ + \subjectKeyIdentifier = hash\n\ + \authorityKeyIdentifier = keyid:always\n\ + \basicConstraints = critical,CA:true\n" + -- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5 + -- IP and FQDN can't both be used as server address interchangeably even if IP is added + -- as Subject Alternative Name, unless the following validation hook is disabled: + -- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName + createOpensslServerConf = + writeFile + (c opensslServerConfFile) + ( "[req]\n\ + \distinguished_name = req_distinguished_name\n\ + \prompt = no\n\n\ + \[req_distinguished_name]\n" + <> ("CN = " <> commonName x509cfg <> "\n\n") + <> "[v3]\n\ + \basicConstraints = CA:FALSE\n\ + \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\ + \extendedKeyUsage = serverAuth\n" + ) saveFingerprint = do - Fingerprint fp <- loadFingerprint caCrtFile - withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp) + Fingerprint fp <- loadFingerprint $ c caCrtFile + withFile (c fingerprintFile) WriteMode (`B.hPutStrLn` strEncode fp) pure fp - warnCAPrivateKeyFile = - putStrLn $ - "----------\n\ - \You should store CA private key securely and delete it from the server.\n\ - \If server TLS credential is compromised this key can be used to sign a new one, \ - \keeping the same server identity and established connections.\n\ - \CA private key location:\n" - <> caKeyFile - <> "\n----------" +warnCAPrivateKeyFile :: FilePath -> X509Config -> IO () +warnCAPrivateKeyFile cfgPath X509Config {caKeyFile} = + putStrLn $ + "----------\n\ + \You should store CA private key securely and delete it from the server.\n\ + \If server TLS credential is compromised this key can be used to sign a new one, \ + \keeping the same server identity and established connections.\n\ + \CA private key location:\n" + <> combine cfgPath caKeyFile + <> "\n----------" data IniOptions = IniOptions { enableStoreLog :: Bool, @@ -245,49 +167,46 @@ strictIni section key ini = readStrictIni :: Read a => Text -> Text -> Ini -> a readStrictIni section key = read . T.unpack . strictIni section key -runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> Ini -> IO () -runServer cliCfg server ini = do - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering - fp <- checkSavedFingerprint - printServiceInfo cliCfg fp - let IniOptions {enableStoreLog, port, enableWebsockets} = mkIniOptions ini - transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets] - logFile = if enableStoreLog then Just storeLogFile else Nothing - cfg = mkServerConfig logFile transports ini - printServerConfig logFile transports - server cfg +iniOnOff :: Text -> Text -> Ini -> Maybe Bool +iniOnOff section name ini = case lookupValue section name ini of + Right "on" -> Just True + Right "off" -> Just False + Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s + _ -> Nothing + +settingIsOn :: Text -> Text -> Ini -> Maybe () +settingIsOn section name ini + | iniOnOff section name ini == Just True = Just () + | otherwise = Nothing + +checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString +checkSavedFingerprint cfgPath x509cfg = do + savedFingerprint <- withFile (c fingerprintFile) ReadMode hGetLine + Fingerprint fp <- loadFingerprint (c caCrtFile) + when (B.pack savedFingerprint /= strEncode fp) $ + exitError "Stored fingerprint is invalid." + pure fp where - ServerCLIConfig {storeLogFile, caCrtFile, fingerprintFile, mkServerConfig} = cliCfg - checkSavedFingerprint = do - savedFingerprint <- withFile fingerprintFile ReadMode hGetLine - Fingerprint fp <- loadFingerprint caCrtFile - when (B.pack savedFingerprint /= strEncode fp) $ - exitError "Stored fingerprint is invalid." - pure fp + c = combine cfgPath . ($ x509cfg) - printServerConfig logFile transports = do - putStrLn $ case logFile of - Just f -> "Store log: " <> f - _ -> "Store log disabled." - forM_ transports $ \(p, ATransport t) -> - putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..." +iniTransports :: Ini -> [(String, ATransport)] +iniTransports ini = + let port = T.unpack $ strictIni "TRANSPORT" "port" ini + enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini + in (port, transport @TLS) : [("80", transport @WS) | enableWebsockets] -cleanup :: ServerCLIConfig cfg -> IO () -cleanup ServerCLIConfig {cfgDir, logDir} = do - deleteDirIfExists cfgDir - deleteDirIfExists logDir - where - deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path +printServerConfig :: [(ServiceName, ATransport)] -> Maybe FilePath -> IO () +printServerConfig transports logFile = do + putStrLn $ case logFile of + Just f -> "Store log: " <> f + _ -> "Store log disabled." + forM_ transports $ \(p, ATransport t) -> + putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..." -clearDirs :: ServerCLIConfig cfg -> IO () -clearDirs ServerCLIConfig {cfgDir, logDir} = do - clearDirIfExists cfgDir - clearDirIfExists logDir - where - clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path) +deleteDirIfExists :: FilePath -> IO () +deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path -printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO () -printServiceInfo ServerCLIConfig {serverVersion} fpStr = do +printServiceInfo :: String -> ByteString -> IO () +printServiceInfo serverVersion fpStr = do putStrLn serverVersion B.putStrLn $ "Fingerprint: " <> strEncode fpStr diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index a2633427c..123f0a5df 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -1,124 +1,199 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Simplex.Messaging.Server.Main where import Data.Functor (($>)) -import Data.Ini (lookupValue) +import Data.Ini (lookupValue, readIniFile) import Data.Maybe (fromMaybe) -import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import Network.Socket (HostName) +import Options.Applicative import Simplex.Messaging.Encoding.String import Simplex.Messaging.Server (runSMPServer) -import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI, readStrictIni) +import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange) +import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) +import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) +import Text.Read (readMaybe) smpServerCLI :: FilePath -> FilePath -> IO () -smpServerCLI cfgPath logPath = protocolServerCLI (smpServerCLIConfig cfgPath logPath) $ \cfg@ServerConfig {inactiveClientExpiration} -> do - putStrLn $ case inactiveClientExpiration of - Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds" - _ -> "not expiring inactive clients" - putStrLn $ - "creating new queues " - <> if allowNewQueues cfg - then maybe "allowed" (const "requires basic auth") $ newQueueBasicAuth cfg - else "NOT allowed" - runSMPServer cfg +smpServerCLI cfgPath logPath = + getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case + Init opts -> + doesFileExist iniFile >>= \case + True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`." + _ -> initializeServer opts + Start -> + doesFileExist iniFile >>= \case + True -> readIniFile iniFile >>= either exitError runServer + _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." + Delete -> do + confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" + deleteDirIfExists cfgPath + deleteDirIfExists logPath + putStrLn "Deleted configuration and log files" + where + iniFile = combine cfgPath "smp-server.ini" + serverVersion = "SMP server v" <> simplexMQVersion + defaultServerPort = "5223" + executableName = "smp-server" + storeLogFilePath = combine logPath "smp-server-store.log" + initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do + deleteDirIfExists cfgPath + deleteDirIfExists logPath + createDirectoryIfMissing True cfgPath + createDirectoryIfMissing True logPath + let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm} + fp <- createServerX509 cfgPath x509cfg + writeFile iniFile iniFileContent + putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server." + printServiceInfo serverVersion fp + warnCAPrivateKeyFile cfgPath x509cfg + where + iniFileContent = + "[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\ + \# and restoring it when the server is started.\n\ + \# Log is compacted on start (deleted objects are removed).\n" + <> ("enable: " <> (if enableStoreLog then "on" else "off") <> "\n") + <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\ + \# they are preserved in the .bak file until the next restart.\n" + <> ("restore_messages: " <> (if enableStoreLog then "on" else "off") <> "\n") + <> "log_stats: off\n\n" + <> "[AUTH]\n" + <> "# Set new_queues option to off to completely prohibit creating new messaging queues.\n" + <> "# This can be useful when you want to decommission the server, but not all connections are switched yet.\n" + <> "new_queues: on\n\n" + <> "# Use create_password option to enable basic auth to create new messaging queues.\n" + <> "# The password should be used as part of server address in client configuration:\n" + <> "# smp://fingerprint:password@host1,host2\n" + <> "# The password will not be shared with the connecting contacts, you must share it only\n" + <> "# with the users who you want to allow creating messaging queues on your server.\n" + <> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')\n\n" + <> "[TRANSPORT]\n" + <> ("port: " <> defaultServerPort <> "\n") + <> "websockets: off\n\n" + <> "[INACTIVE_CLIENTS]\n\ + \# TTL and interval to check inactive clients\n\ + \disconnect: off\n" + <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n") + <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n") + runServer ini = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + fp <- checkSavedFingerprint cfgPath defaultX509Config + printServiceInfo serverVersion fp + let cfg@ServerConfig {transports, storeLogFile, inactiveClientExpiration} = serverConfig + printServerConfig transports storeLogFile + putStrLn $ case inactiveClientExpiration of + Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds" + _ -> "not expiring inactive clients" + putStrLn $ + "creating new queues " + <> if allowNewQueues cfg + then maybe "allowed" (const "requires basic auth") $ newQueueBasicAuth cfg + else "NOT allowed" + runSMPServer cfg + where + enableStoreLog = settingIsOn "STORE_LOG" "enable" ini + logStats = settingIsOn "STORE_LOG" "log_stats" ini + c = combine cfgPath . ($ defaultX509Config) + serverConfig = + ServerConfig + { transports = iniTransports ini, + tbqSize = 16, + serverTbqSize = 64, + msgQueueQuota = 128, + queueIdBytes = 24, + msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20 + caCertificateFile = c caCrtFile, + privateKeyFile = c serverKeyFile, + certificateFile = c serverCrtFile, + storeLogFile = enableStoreLog $> storeLogFilePath, + storeMsgsFile = + let messagesPath = combine logPath "smp-server-messages.log" + in case iniOnOff "STORE_LOG" "restore_messages" ini of + Just True -> Just messagesPath + Just False -> Nothing + -- if the setting is not set, it is enabled when store log is enabled + _ -> enableStoreLog $> messagesPath, + -- allow creating new queues by default + allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, + newQueueBasicAuth = case lookupValue "AUTH" "create_password" ini of + Right auth -> either error Just . strDecode $ encodeUtf8 auth + _ -> Nothing, + messageExpiration = Just defaultMessageExpiration, + inactiveClientExpiration = + settingIsOn "INACTIVE_CLIENTS" "disconnect" ini + $> ExpirationConfig + { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini, + checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini + }, + logStatsInterval = logStats $> 86400, -- seconds + logStatsStartTime = 0, -- seconds from 00:00 UTC + serverStatsLogFile = combine logPath "smp-server-stats.daily.log", + serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log", + smpServerVRange = supportedSMPServerVRange + } -smpServerCLIConfig :: FilePath -> FilePath -> ServerCLIConfig ServerConfig -smpServerCLIConfig cfgPath logPath = - let caCrtFile = combine cfgPath "ca.crt" - serverKeyFile = combine cfgPath "server.key" - serverCrtFile = combine cfgPath "server.crt" - in ServerCLIConfig - { cfgDir = cfgPath, - logDir = logPath, - iniFile = combine cfgPath "smp-server.ini", - storeLogFile = combine logPath "smp-server-store.log", - caKeyFile = combine cfgPath "ca.key", - caCrtFile, - serverKeyFile, - serverCrtFile, - fingerprintFile = combine cfgPath "fingerprint", - defaultServerPort = "5223", - executableName = "smp-server", - serverVersion = "SMP server v" <> simplexMQVersion, - mkIniFile = \enableStoreLog defaultServerPort -> - "[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\ - \# and restoring it when the server is started.\n\ - \# Log is compacted on start (deleted objects are removed).\n" - <> ("enable: " <> (if enableStoreLog then "on" else "off") <> "\n") - <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\ - \# they are preserved in the .bak file until the next restart.\n" - <> ("restore_messages: " <> (if enableStoreLog then "on" else "off") <> "\n") - <> "log_stats: off\n\n" - <> "[AUTH]\n" - <> "# Set new_queues option to off to completely prohibit creating new messaging queues.\n" - <> "# This can be useful when you want to decommission the server, but not all connections are switched yet.\n" - <> "new_queues: on\n\n" - <> "# Use create_password option to enable basic auth to create new messaging queues.\n" - <> "# The password should be used as part of server address in client configuration:\n" - <> "# smp://fingerprint:password@host1,host2\n" - <> "# The password will not be shared with the connecting contacts, you must share it only\n" - <> "# with the users who you want to allow creating messaging queues on your server.\n" - <> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')\n\n" - <> "[TRANSPORT]\n" - <> ("port: " <> defaultServerPort <> "\n") - <> "websockets: off\n\n" - <> "[INACTIVE_CLIENTS]\n\ - \# TTL and interval to check inactive clients\n\ - \disconnect: off\n" - <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n") - <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n"), - mkServerConfig = \storeLogFile transports ini -> - let onOff section name = case lookupValue section name ini of - Right "on" -> Just True - Right "off" -> Just False - Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s - _ -> Nothing - settingIsOn section name = if onOff section name == Just True then Just () else Nothing - logStats = settingIsOn "STORE_LOG" "log_stats" - in ServerConfig - { transports, - tbqSize = 16, - serverTbqSize = 64, - msgQueueQuota = 128, - queueIdBytes = 24, - msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20 - caCertificateFile = caCrtFile, - privateKeyFile = serverKeyFile, - certificateFile = serverCrtFile, - storeLogFile, - storeMsgsFile = - let messagesPath = combine logPath "smp-server-messages.log" - in case onOff "STORE_LOG" "restore_messages" of - Just True -> Just messagesPath - Just False -> Nothing - -- if the setting is not set, it is enabled when store log is enabled - _ -> storeLogFile $> messagesPath, - -- allow creating new queues by default - allowNewQueues = fromMaybe True $ onOff "AUTH" "new_queues", - newQueueBasicAuth = case lookupValue "AUTH" "create_password" ini of - Right auth -> either error Just . strDecode $ encodeUtf8 auth - _ -> Nothing, - messageExpiration = Just defaultMessageExpiration, - inactiveClientExpiration = - settingIsOn "INACTIVE_CLIENTS" "disconnect" - $> ExpirationConfig - { ttl = readStrictIni "INACTIVE_CLIENTS" "ttl" ini, - checkInterval = readStrictIni "INACTIVE_CLIENTS" "check_interval" ini - }, - logStatsInterval = logStats $> 86400, -- seconds - logStatsStartTime = 0, -- seconds from 00:00 UTC - serverStatsLogFile = combine logPath "smp-server-stats.daily.log", - serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log", - smpServerVRange = supportedSMPServerVRange - } - } +data CliCommand + = Init InitOptions + | Start + | Delete + +data InitOptions = InitOptions + { enableStoreLog :: Bool, + signAlgorithm :: SignAlgorithm, + ip :: HostName, + fqdn :: Maybe HostName + } + deriving (Show) + +cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand +cliCommandP cfgPath logPath iniFile = + hsubparser + ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files")) + <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) + <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) + ) + where + initP :: Parser InitOptions + initP = + InitOptions + <$> switch + ( long "store-log" + <> short 'l' + <> help "Enable store log for persistence" + ) + <*> option + (maybeReader readMaybe) + ( long "sign-algorithm" + <> short 'a' + <> help "Signature algorithm used for TLS certificates: ED25519, ED448" + <> value ED448 + <> showDefault + <> metavar "ALG" + ) + <*> strOption + ( long "ip" + <> help + "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied" + <> value "127.0.0.1" + <> showDefault + <> metavar "IP" + ) + <*> (optional . strOption) + ( long "fqdn" + <> short 'n' + <> help "Server FQDN used as Common Name for TLS online certificate" + <> showDefault + <> metavar "FQDN" + ) diff --git a/tests/CLITests.hs b/tests/CLITests.hs index 4dcf3f027..5129d3a58 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -36,11 +36,11 @@ cliTests = do it "should initialize, start and delete the server (with store log)" $ ntfServerTest True smpServerTest :: Bool -> IO () -smpServerTest enableStoreLog = do - capture_ (withArgs (["init"] <> ["-l" | enableStoreLog]) $ smpServerCLI cfgPath logPath) +smpServerTest storeLog = do + capture_ (withArgs (["init"] <> ["-l" | storeLog]) $ smpServerCLI cfgPath logPath) >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> cfgPath <> "/smp-server.ini") `isPrefixOf`)) Right ini <- readIniFile $ cfgPath <> "/smp-server.ini" - lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if enableStoreLog then "on" else "off") + lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off") lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off" lookupValue "TRANSPORT" "port" ini `shouldBe` Right "5223" lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off" @@ -49,7 +49,7 @@ smpServerTest enableStoreLog = do doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ())) r `shouldContain` ["SMP server v3.4.0"] - r `shouldContain` (if enableStoreLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."]) + r `shouldContain` (if storeLog then ["Store log: " <> logPath <> "/smp-server-store.log"] else ["Store log disabled."]) r `shouldContain` ["Listening on port 5223 (TLS)..."] r `shouldContain` ["not expiring inactive clients"] r `shouldContain` ["creating new queues allowed"] @@ -58,18 +58,18 @@ smpServerTest enableStoreLog = do doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False ntfServerTest :: Bool -> IO () -ntfServerTest enableStoreLog = do - capture_ (withArgs (["init"] <> ["-l" | enableStoreLog]) $ ntfServerCLI ntfCfgPath ntfLogPath) +ntfServerTest storeLog = do + capture_ (withArgs (["init"] <> ["-l" | storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath) >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> ntfCfgPath <> "/ntf-server.ini") `isPrefixOf`)) Right ini <- readIniFile $ ntfCfgPath <> "/ntf-server.ini" - lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if enableStoreLog then "on" else "off") + lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off") lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off" lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443" lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off" doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ())) r `shouldContain` ["SMP notifications server v1.2.0"] - r `shouldContain` (if enableStoreLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."]) + r `shouldContain` (if storeLog then ["Store log: " <> ntfLogPath <> "/ntf-server-store.log"] else ["Store log disabled."]) r `shouldContain` ["Listening on port 443 (TLS)..."] capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath) >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))