diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index 4eeff27a7..0e1b7136c 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -1,20 +1,27 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Simplex.Messaging.Notifications.Server.Main where +import Data.Either (fromRight) import Data.Functor (($>)) -import Data.Ini (readIniFile) +import Data.Ini (lookupValue, readIniFile) import Data.Maybe (fromMaybe) +import qualified Data.Text as T import Network.Socket (HostName) import Options.Applicative import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig) +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Server (runNtfServer) import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig) +import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer) import Simplex.Messaging.Server.CLI +import Simplex.Messaging.Transport.Client (TransportHost (..)) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) @@ -49,33 +56,36 @@ ntfServerCLI cfgPath logPath = createDirectoryIfMissing True logPath let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm} fp <- createServerX509 cfgPath x509cfg - writeFile iniFile iniFileContent + let host = fromMaybe (if ip == "127.0.0.1" then "" else ip) fqdn + srv = ProtoServerWithAuth (NtfServer [THDomainName host] "" (C.KeyHash fp)) Nothing + writeFile iniFile $ iniFileContent host putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server." - printServiceInfo serverVersion fp warnCAPrivateKeyFile cfgPath x509cfg + printServiceInfo serverVersion srv where - iniFileContent = + iniFileContent host = "[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" + \# Log is compacted on start (deleted objects are removed).\n" + <> ("enable: " <> onOff enableStoreLog <> "\n\n") + <> "log_stats: off\n\n" + <> "[TRANSPORT]\n" + <> "# host is only used to print server address on start\n" + <> ("host: " <> host <> "\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 + let host = fromRight "" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini + port = T.unpack $ strictIni "TRANSPORT" "port" ini + cfg@NtfServerConfig {transports, storeLogFile} = serverConfig + srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing + printServiceInfo serverVersion srv printServerConfig transports storeLogFile runNtfServer cfg where diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index c043185a1..4789c0d8e 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -19,6 +20,7 @@ import Data.X509.Validation (Fingerprint (..)) import Network.Socket (HostName, ServiceName) import Options.Applicative import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport.Server (loadFingerprint) import Simplex.Messaging.Transport.WebSockets (WS) @@ -33,12 +35,10 @@ exitError :: String -> IO () exitError msg = putStrLn msg >> exitFailure confirmOrExit :: String -> IO () -confirmOrExit s = do - putStrLn s - putStr "Continue (Y/n): " - hFlush stdout - ok <- getLine - when (ok /= "Y") exitFailure +confirmOrExit s = + withPrompt (s <> "\nContinue (Y/n): ") $ do + ok <- getLine + when (ok /= "Y") $ putStrLn "Server NOT deleted" >> exitFailure data SignAlgorithm = ED448 | ED25519 deriving (Read, Show) @@ -174,6 +174,24 @@ iniOnOff section name ini = case lookupValue section name ini of Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s _ -> Nothing +withPrompt :: String -> IO a -> IO a +withPrompt s a = putStr s >> hFlush stdout >> a + +onOffPrompt :: String -> Bool -> IO Bool +onOffPrompt prompt def = + withPrompt (prompt <> if def then " (Yn): " else " (yN): ") $ + getLine >>= \case + "" -> pure def + "y" -> pure True + "Y" -> pure True + "n" -> pure False + "N" -> pure False + _ -> putStrLn "Invalid input, please enter 'y' or 'n'" >> onOffPrompt prompt def + +onOff :: Bool -> String +onOff True = "on" +onOff _ = "off" + settingIsOn :: Text -> Text -> Ini -> Maybe () settingIsOn section name ini | iniOnOff section name ini == Just True = Just () @@ -206,7 +224,8 @@ printServerConfig transports logFile = do deleteDirIfExists :: FilePath -> IO () deleteDirIfExists path = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path -printServiceInfo :: String -> ByteString -> IO () -printServiceInfo serverVersion fpStr = do +printServiceInfo :: ProtocolTypeI p => String -> ProtoServerWithAuth p -> IO () +printServiceInfo serverVersion srv@(ProtoServerWithAuth ProtocolServer {keyHash} _) = do putStrLn serverVersion - B.putStrLn $ "Fingerprint: " <> strEncode fpStr + B.putStrLn $ "Fingerprint: " <> strEncode keyHash + B.putStrLn $ "Server address: " <> strEncode srv diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 123f0a5df..9d791c725 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -1,22 +1,34 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Simplex.Messaging.Server.Main where +import Control.Monad (void) +import Crypto.Random (getRandomBytes) +import qualified Data.ByteString.Char8 as B +import Data.Either (fromRight) import Data.Functor (($>)) 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 qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer) import Simplex.Messaging.Server (runSMPServer) 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 Simplex.Messaging.Transport.Client (TransportHost (..)) +import Simplex.Messaging.Util (safeDecodeUtf8) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (combine) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) @@ -44,54 +56,92 @@ smpServerCLI cfgPath logPath = 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 + initializeServer opts + | scripted opts = initialize opts + | otherwise = do + putStrLn "Use `smp-server init -h` for available options." + void $ withPrompt "SMP server will be initialized (press Enter)" getLine + enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True + logStats <- onOffPrompt "Enable logging daily statistics" False + putStrLn "Require a password to create new messaging queues?" + password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword + let host = fromMaybe (ip opts) (fqdn opts) + host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine + initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn opts else Just host', password} 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") + serverPassword = + getLine >>= \case + "" -> pure $ Just SPRandom + "r" -> pure $ Just SPRandom + "n" -> pure Nothing + s -> + case strDecode $ encodeUtf8 $ T.pack s of + Right auth -> pure . Just $ ServerPassword auth + _ -> putStrLn "Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" >> serverPassword + initialize InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password} = do + deleteDirIfExists cfgPath + deleteDirIfExists logPath + createDirectoryIfMissing True cfgPath + createDirectoryIfMissing True logPath + let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm} + fp <- createServerX509 cfgPath x509cfg + basicAuth <- mapM createServerPassword password + let host = fromMaybe (if ip == "127.0.0.1" then "" else ip) fqdn + srv = ProtoServerWithAuth (SMPServer [THDomainName host] "" (C.KeyHash fp)) basicAuth + writeFile iniFile $ iniFileContent host basicAuth + putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server." + warnCAPrivateKeyFile cfgPath x509cfg + printServiceInfo serverVersion srv + where + createServerPassword = \case + ServerPassword s -> pure s + SPRandom -> BasicAuth . strEncode <$> (getRandomBytes 32 :: IO B.ByteString) + iniFileContent host basicAuth = + "[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: " <> onOff enableStoreLog <> "\n\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: " <> onOff enableStoreLog <> "\n\n") + <> "# Log daily server statistics to CSV file\n" + <> ("log_stats: " <> onOff logStats <> "\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" + <> ( case basicAuth of + Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth) + _ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')" + ) + <> "\n\n" + <> "[TRANSPORT]\n" + <> "# host is only used to print server address on start\n" + <> ("host: " <> host <> "\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 + let host = fromRight "" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini + port = T.unpack $ strictIni "TRANSPORT" "port" ini + cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, inactiveClientExpiration} = serverConfig + srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth + printServiceInfo serverVersion srv printServerConfig transports storeLogFile putStrLn $ case inactiveClientExpiration of Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds" @@ -99,7 +149,7 @@ smpServerCLI cfgPath logPath = putStrLn $ "creating new queues " <> if allowNewQueues cfg - then maybe "allowed" (const "requires basic auth") $ newQueueBasicAuth cfg + then maybe "allowed" (const "requires password") newQueueBasicAuth else "NOT allowed" runSMPServer cfg where @@ -151,12 +201,18 @@ data CliCommand data InitOptions = InitOptions { enableStoreLog :: Bool, + logStats :: Bool, signAlgorithm :: SignAlgorithm, ip :: HostName, - fqdn :: Maybe HostName + fqdn :: Maybe HostName, + password :: Maybe ServerPassword, + scripted :: Bool } deriving (Show) +data ServerPassword = ServerPassword BasicAuth | SPRandom + deriving (Show) + cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand cliCommandP cfgPath logPath iniFile = hsubparser @@ -166,14 +222,21 @@ cliCommandP cfgPath logPath iniFile = ) where initP :: Parser InitOptions - initP = - InitOptions - <$> switch + initP = do + enableStoreLog <- + switch ( long "store-log" <> short 'l' <> help "Enable store log for persistence" ) - <*> option + logStats <- + switch + ( long "daily-stats" + <> short 's' + <> help "Enable logging daily server statistics" + ) + signAlgorithm <- + option (maybeReader readMaybe) ( long "sign-algorithm" <> short 'a' @@ -182,7 +245,8 @@ cliCommandP cfgPath logPath iniFile = <> showDefault <> metavar "ALG" ) - <*> strOption + ip <- + strOption ( long "ip" <> help "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied" @@ -190,10 +254,30 @@ cliCommandP cfgPath logPath iniFile = <> showDefault <> metavar "IP" ) - <*> (optional . strOption) + fqdn <- + (optional . strOption) ( long "fqdn" <> short 'n' <> help "Server FQDN used as Common Name for TLS online certificate" <> showDefault <> metavar "FQDN" ) + password <- + flag' Nothing (long "no-password" <> help "Allow creating new queues without password") + <|> Just + <$> option + parseBasicAuth + ( long "password" + <> metavar "PASSWORD" + <> help "Set password to create new messaging queues" + <> value SPRandom + ) + scripted <- + switch + ( long "yes" + <> short 'y' + <> help "Non-interactive initialization using command-line options" + ) + pure InitOptions {enableStoreLog, logStats, signAlgorithm, ip, fqdn, password, scripted} + parseBasicAuth :: ReadM ServerPassword + parseBasicAuth = eitherReader $ fmap ServerPassword . strDecode . B.pack diff --git a/tests/CLITests.hs b/tests/CLITests.hs index 5129d3a58..b52816166 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -29,15 +29,18 @@ ntfLogPath = "tests/tmp/cli/etc/var/simplex-notifications" cliTests :: Spec cliTests = do describe "SMP server CLI" $ do - it "should initialize, start and delete the server (no store log)" $ smpServerTest False - it "should initialize, start and delete the server (with store log)" $ smpServerTest True + describe "initialize, start and delete the server" $ do + it "no store log, random password (default)" $ smpServerTest False True + it "with store log, random password (default)" $ smpServerTest True True + it "no store log, no password" $ smpServerTest False False + it "with store log, no password" $ smpServerTest True False describe "Ntf server CLI" $ do it "should initialize, start and delete the server (no store log)" $ ntfServerTest False it "should initialize, start and delete the server (with store log)" $ ntfServerTest True -smpServerTest :: Bool -> IO () -smpServerTest storeLog = do - capture_ (withArgs (["init"] <> ["-l" | storeLog]) $ smpServerCLI cfgPath logPath) +smpServerTest :: Bool -> Bool -> IO () +smpServerTest storeLog basicAuth = do + capture_ (withArgs (["init", "-y"] <> ["-l" | storeLog] <> ["--no-password" | not basicAuth]) $ 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 storeLog then "on" else "off") @@ -52,7 +55,7 @@ smpServerTest storeLog = do 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"] + r `shouldContain` (if basicAuth then ["creating new queues requires password"] else ["creating new queues allowed"]) capture_ (withStdin "Y" . withArgs ["delete"] $ smpServerCLI cfgPath logPath) >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`)) doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False diff --git a/tests/Test.hs b/tests/Test.hs index fbf8a4af6..1fb6af7f8 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -35,5 +35,5 @@ main = do describe "SMP server via WebSockets" $ serverTests (transport @WS) describe "Notifications server" $ ntfServerTests (transport @TLS) describe "SMP client agent" $ agentTests (transport @TLS) - describe "Server CLIs" cliTests + fdescribe "Server CLIs" cliTests removeDirectoryRecursive "tests/tmp"