From fb26916eea4f7148d823b5c48fb7673433681ff1 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 3 Apr 2022 10:37:32 +0100 Subject: [PATCH] ntf-server CLI, re-use SMP server CLI as a library (#347) * ntf-server CLI, re-use SMP server CLI as a library * add executable name --- apps/ntf-server/Main.hs | 50 +++ apps/smp-server/Main.hs | 343 ++---------------- package.yaml | 16 +- simplexmq.cabal | 59 +++ src/Simplex/Messaging/Agent/Env/SQLite.hs | 7 +- src/Simplex/Messaging/Client.hs | 2 +- .../Messaging/Notifications/Server/Env.hs | 2 - src/Simplex/Messaging/Server/CLI.hs | 285 +++++++++++++++ src/Simplex/Messaging/Server/Env/STM.hs | 8 +- tests/SMPClient.hs | 9 +- 10 files changed, 458 insertions(+), 323 deletions(-) create mode 100644 apps/ntf-server/Main.hs create mode 100644 src/Simplex/Messaging/Server/CLI.hs diff --git a/apps/ntf-server/Main.hs b/apps/ntf-server/Main.hs new file mode 100644 index 000000000..8426093e5 --- /dev/null +++ b/apps/ntf-server/Main.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Main where + +import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig) +import Simplex.Messaging.Notifications.Server (runNtfServer) +import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) +import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI) +import System.FilePath (combine) + +cfgPath :: FilePath +cfgPath = "/etc/opt/simplex-notifications" + +logPath :: FilePath +logPath = "/var/opt/simplex-notifications" + +main :: IO () +main = protocolServerCLI ntfServerCLIConfig runNtfServer + +ntfServerCLIConfig :: ServerCLIConfig NtfServerConfig +ntfServerCLIConfig = + 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 v0.1.0", + mkServerConfig = \_storeLogFile transports -> + NtfServerConfig + { transports, + subIdBytes = 24, + clientQSize = 16, + subQSize = 64, + pushQSize = 128, + smpAgentCfg = defaultSMPClientAgentConfig, + caCertificateFile = caCrtFile, + privateKeyFile = serverKeyFile, + certificateFile = serverCrtFile + } + } diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index 163b312c8..28b6b754b 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -1,318 +1,53 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Main where -import Control.Monad.Except -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 qualified Data.Text as T -import Data.X509.Validation (Fingerprint (..)) -import Network.Socket (HostName, ServiceName) -import Options.Applicative -import Simplex.Messaging.Encoding.String import Simplex.Messaging.Server (runSMPServer) -import Simplex.Messaging.Server.Env.STM -import Simplex.Messaging.Server.StoreLog (StoreLog, openReadStoreLog, storeLogFilePath) -import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..), simplexMQVersion) -import Simplex.Messaging.Transport.Server (loadFingerprint) -import Simplex.Messaging.Transport.WebSockets (WS) -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive) -import System.Exit (exitFailure) +import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI) +import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) +import Simplex.Messaging.Transport (simplexMQVersion) import System.FilePath (combine) -import System.IO (BufferMode (..), IOMode (..), hGetLine, hSetBuffering, stderr, stdout, withFile) -import System.Process (readCreateProcess, shell) -import Text.Read (readMaybe) -cfgDir :: FilePath -cfgDir = "/etc/opt/simplex" +cfgPath :: FilePath +cfgPath = "/etc/opt/simplex" -logDir :: FilePath -logDir = "/var/opt/simplex" - -iniFile :: FilePath -iniFile = combine cfgDir "smp-server.ini" - -storeLogFile :: FilePath -storeLogFile = combine logDir "smp-server-store.log" - -caKeyFile :: FilePath -caKeyFile = combine cfgDir "ca.key" - -caCrtFile :: FilePath -caCrtFile = combine cfgDir "ca.crt" - -serverKeyFile :: FilePath -serverKeyFile = combine cfgDir "server.key" - -serverCrtFile :: FilePath -serverCrtFile = combine cfgDir "server.crt" - -fingerprintFile :: FilePath -fingerprintFile = combine cfgDir "fingerprint" +logPath :: FilePath +logPath = "/var/opt/simplex" main :: IO () -main = do - getCliCommand >>= \case - Init opts -> - doesFileExist iniFile >>= \case - True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `smp-server start`." - _ -> initializeServer opts - Start -> - doesFileExist iniFile >>= \case - True -> readIniFile iniFile >>= either exitError (runServer . mkIniOptions) - _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `smp-server init`." - Delete -> cleanup >> putStrLn "Deleted configuration and log files" +main = protocolServerCLI smpServerCLIConfig runSMPServer -exitError :: String -> IO () -exitError msg = putStrLn msg >> 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 :: IO CliCommand -getCliCommand = - customExecParser - (prefs showHelpOnEmpty) - ( info - (helper <*> versionOption <*> cliCommandP) - (header version <> fullDesc) - ) - where - versionOption = infoOption version (long "version" <> short 'v' <> help "Show version") - -cliCommandP :: Parser CliCommand -cliCommandP = - 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")) - ) - where - initP :: Parser CliCommand - initP = - Init - <$> ( InitOptions - <$> switch - ( long "store-log" - <> short 'l' - <> help "Enable store log for SMP queues 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 :: InitOptions -> IO () -initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn} = do - cleanup - createDirectoryIfMissing True cfgDir - createDirectoryIfMissing True logDir - createX509 - fp <- saveFingerprint - createIni - putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `smp-server start` to start server." - printServiceInfo fp - warnCAPrivateKeyFile - where - 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 - - saveFingerprint = do - Fingerprint fp <- loadFingerprint caCrtFile - withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp) - pure fp - - createIni = do - writeFile iniFile $ - "[STORE_LOG]\n\ - \# The server uses STM memory to store SMP queues and messages,\n\ - \# that will be lost on restart (e.g., as with redis).\n\ - \# This option enables saving SMP queues to append only log,\n\ - \# and restoring them when the server is started.\n\ - \# Log is compacted on start (deleted queues are removed).\n\ - \# The messages in the queues are not logged.\n" - <> ("enable: " <> (if enableStoreLog then "on" else "off # on") <> "\n\n") - <> "[TRANSPORT]\n\ - \port: 5223\n\ - \websockets: off\n" - - 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----------" - -data IniOptions = IniOptions - { enableStoreLog :: Bool, - port :: ServiceName, - enableWebsockets :: Bool - } - --- TODO ? properly parse ini as a whole -mkIniOptions :: Ini -> IniOptions -mkIniOptions ini = - IniOptions - { enableStoreLog = (== "on") $ strict "STORE_LOG" "enable", - port = T.unpack $ strict "TRANSPORT" "port", - enableWebsockets = (== "on") $ strict "TRANSPORT" "websockets" - } - where - strict :: String -> String -> T.Text - strict section key = - fromRight (error ("no key " <> key <> " in section " <> section)) $ - lookupValue (T.pack section) (T.pack key) ini - -runServer :: IniOptions -> IO () -runServer IniOptions {enableStoreLog, port, enableWebsockets} = do - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering - fp <- checkSavedFingerprint - printServiceInfo fp - storeLog <- openStoreLog - let cfg = mkServerConfig storeLog - printServerConfig cfg - runSMPServer cfg - where - checkSavedFingerprint = do - savedFingerprint <- loadSavedFingerprint - Fingerprint fp <- loadFingerprint caCrtFile - when (B.pack savedFingerprint /= strEncode fp) $ - exitError "Stored fingerprint is invalid." - pure fp - - mkServerConfig storeLog = - ServerConfig - { transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets], - 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, - storeLog +smpServerCLIConfig :: ServerCLIConfig ServerConfig +smpServerCLIConfig = + 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, + mkServerConfig = \storeLogFile transports -> + 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 + } } - - openStoreLog :: IO (Maybe (StoreLog 'ReadMode)) - openStoreLog = - if enableStoreLog - then Just <$> openReadStoreLog storeLogFile - else pure Nothing - - printServerConfig ServerConfig {storeLog, transports} = do - putStrLn $ case storeLog of - Just s -> "Store log: " <> storeLogFilePath s - Nothing -> "Store log disabled." - forM_ transports $ \(p, ATransport t) -> - putStrLn $ "Listening on port " <> p <> " (" <> transportName t <> ")..." - -cleanup :: IO () -cleanup = do - deleteDirIfExists cfgDir - deleteDirIfExists logDir - where - deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path) - -printServiceInfo :: ByteString -> IO () -printServiceInfo fpStr = do - putStrLn version - B.putStrLn $ "Fingerprint: " <> strEncode fpStr - -version :: String -version = "SMP server v" <> simplexMQVersion - -loadSavedFingerprint :: IO String -loadSavedFingerprint = withFile fingerprintFile ReadMode hGetLine diff --git a/package.yaml b/package.yaml index f87ca111b..40d8e8955 100644 --- a/package.yaml +++ b/package.yaml @@ -1,7 +1,7 @@ name: simplexmq version: 1.0.3 synopsis: SimpleXMQ message broker -description: | +description: | This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and <./docs/Simplex-Messaging-Agent.html agent> for SMP protocols: @@ -42,12 +42,15 @@ dependencies: - filepath == 1.4.* - http-types == 0.12.* - generic-random >= 1.3 && < 1.5 + - ini == 0.4.* - iso8601-time == 0.1.* - memory == 0.15.* - mtl == 2.2.* - network == 3.1.2.* - network-transport == 0.5.* + - optparse-applicative >= 0.15 && < 0.17 - QuickCheck == 2.14.* + - process == 1.6.* - random >= 1.1 && < 1.3 - simple-logger == 0.1.* - sqlite-simple == 0.4.* @@ -72,9 +75,14 @@ executables: source-dirs: apps/smp-server main: Main.hs dependencies: - - ini == 0.4.* - - optparse-applicative >= 0.15 && < 0.17 - - process == 1.6.* + - simplexmq + ghc-options: + - -threaded + + ntf-server: + source-dirs: apps/ntf-server + main: Main.hs + dependencies: - simplexmq ghc-options: - -threaded diff --git a/simplexmq.cabal b/simplexmq.cabal index 3b9e8eb7e..66089a3e3 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -57,6 +57,7 @@ library Simplex.Messaging.Parsers Simplex.Messaging.Protocol Simplex.Messaging.Server + Simplex.Messaging.Server.CLI Simplex.Messaging.Server.Env.STM Simplex.Messaging.Server.MsgStore Simplex.Messaging.Server.MsgStore.STM @@ -98,11 +99,14 @@ library , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* + , ini ==0.4.* , iso8601-time ==0.1.* , memory ==0.15.* , mtl ==2.2.* , network ==3.1.2.* , network-transport ==0.5.* + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* , random >=1.1 && <1.3 , simple-logger ==0.1.* , sqlite-simple ==0.4.* @@ -227,6 +231,61 @@ executable smp-server , x509-validation ==1.6.* default-language: Haskell2010 +executable ntf-server + main-is: Main.hs + other-modules: + Paths_simplexmq + hs-source-dirs: + apps/ntf-server + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + QuickCheck ==2.14.* + , aeson ==2.0.* + , ansi-terminal >=0.10 && <0.12 + , asn1-encoding ==0.9.* + , asn1-types ==0.3.* + , async ==2.2.* + , attoparsec ==0.14.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , composition ==1.0.* + , constraints >=0.12 && <0.14 + , containers ==0.6.* + , cryptonite >=0.27 && <0.30 + , cryptostore ==0.2.* + , data-default ==0.7.* + , direct-sqlite ==2.3.* + , directory ==1.3.* + , filepath ==1.4.* + , generic-random >=1.3 && <1.5 + , http-types ==0.12.* + , ini ==0.4.* + , iso8601-time ==0.1.* + , memory ==0.15.* + , mtl ==2.2.* + , network ==3.1.2.* + , network-transport ==0.5.* + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* + , random >=1.1 && <1.3 + , simple-logger ==0.1.* + , simplexmq + , sqlite-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.16.* + , text ==1.2.* + , time ==1.9.* + , tls >=1.5.7 && <1.6 + , transformers ==0.5.* + , unliftio ==0.2.* + , unliftio-core ==0.2.* + , websockets ==0.12.* + , x509 ==1.7.* + , x509-store ==1.6.* + , x509-validation ==1.6.* + default-language: Haskell2010 + test-suite smp-server-test type: exitcode-stdio-1.0 main-is: Test.hs diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 66f510ff6..af400ff81 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} module Simplex.Messaging.Agent.Env.SQLite @@ -23,8 +24,8 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client -import Simplex.Messaging.Client.Agent (SMPClientAgentConfig, defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Transport (TLS, Transport (..)) import System.Random (StdGen, newStdGen) import UnliftIO.STM @@ -57,8 +58,8 @@ defaultAgentConfig = dbFile = "smp-agent.db", dbPoolSize = 4, yesToMigrations = False, - smpCfg = defaultClientConfig, - ntfCfg = defaultClientConfig, + smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)}, + ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)}, reconnectInterval = RetryInterval { initialInterval = second, diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index db30d3085..75ce01126 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -112,7 +112,7 @@ defaultClientConfig :: ProtocolClientConfig defaultClientConfig = ProtocolClientConfig { qSize = 64, - defaultTransport = ("5223", transport @TLS), + defaultTransport = ("443", transport @TLS), tcpTimeout = 5_000_000, tcpKeepAlive = Just defaultKeepAliveOpts, smpPing = 300_000_000 -- 5 min diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index fec2aafb6..8b2a416a1 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -13,7 +13,6 @@ import Data.X509.Validation (Fingerprint (..)) import Network.Socket import qualified Network.TLS as T import Numeric.Natural -import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Client.Agent import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol @@ -30,7 +29,6 @@ data NtfServerConfig = NtfServerConfig subQSize :: Natural, pushQSize :: Natural, smpAgentCfg :: SMPClientAgentConfig, - reconnectInterval :: RetryInterval, -- CA certificate private key is not needed for initialization caCertificateFile :: FilePath, privateKeyFile :: FilePath, diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs new file mode 100644 index 000000000..63959d45a --- /dev/null +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Simplex.Messaging.Server.CLI where + +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 qualified Data.Text as T +import Data.X509.Validation (Fingerprint (..)) +import Network.Socket (HostName, ServiceName) +import Options.Applicative +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) +import Simplex.Messaging.Transport.Server (loadFingerprint) +import Simplex.Messaging.Transport.WebSockets (WS) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive) +import System.Exit (exitFailure) +import System.FilePath (combine) +import System.IO (BufferMode (..), IOMode (..), hGetLine, hSetBuffering, stderr, 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, + mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> 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 . mkIniOptions) + _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." + Delete -> cleanup cliCfg >> putStrLn "Deleted configuration and log files" + +exitError :: String -> IO () +exitError msg = putStrLn msg >> 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 = + customExecParser + (prefs showHelpOnEmpty) + ( info + (helper <*> versionOption <*> cliCommandP cliCfg) + (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")) + ) + 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 + cleanup cliCfg + createDirectoryIfMissing True cfgDir + createDirectoryIfMissing True logDir + createX509 + fp <- saveFingerprint + createIni + 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} = 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 + + saveFingerprint = do + Fingerprint fp <- loadFingerprint caCrtFile + withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp) + pure fp + + createIni = do + writeFile iniFile $ + "[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\ + \# The messages are not logged.\n" + <> ("enable: " <> (if enableStoreLog then "on" else "off # on") <> "\n\n") + <> "[TRANSPORT]\n\ + \port: " + <> defaultServerPort + <> "\n\ + \websockets: off\n" + + 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----------" + +data IniOptions = IniOptions + { enableStoreLog :: Bool, + port :: ServiceName, + enableWebsockets :: Bool + } + +-- TODO ? properly parse ini as a whole +mkIniOptions :: Ini -> IniOptions +mkIniOptions ini = + IniOptions + { enableStoreLog = (== "on") $ strict "STORE_LOG" "enable", + port = T.unpack $ strict "TRANSPORT" "port", + enableWebsockets = (== "on") $ strict "TRANSPORT" "websockets" + } + where + strict :: String -> String -> T.Text + strict section key = + fromRight (error ("no key " <> key <> " in section " <> section)) $ + lookupValue (T.pack section) (T.pack key) ini + +runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IniOptions -> IO () +runServer cliCfg server IniOptions {enableStoreLog, port, enableWebsockets} = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + fp <- checkSavedFingerprint + printServiceInfo cliCfg fp + let transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets] + logFile = if enableStoreLog then Just storeLogFile else Nothing + cfg = mkServerConfig logFile transports + printServerConfig logFile transports + server cfg + 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 + + 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 <> ")..." + +cleanup :: ServerCLIConfig cfg -> IO () +cleanup ServerCLIConfig {cfgDir, logDir} = do + deleteDirIfExists cfgDir + deleteDirIfExists logDir + where + deleteDirIfExists path = doesDirectoryExist path >>= (`when` removeDirectoryRecursive path) + +printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO () +printServiceInfo ServerCLIConfig {serverVersion} fpStr = do + putStrLn serverVersion + B.putStrLn $ "Fingerprint: " <> strEncode fpStr diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 3c4599a97..f704367a6 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -35,7 +35,8 @@ data ServerConfig = ServerConfig msgQueueQuota :: Natural, queueIdBytes :: Int, msgIdBytes :: Int, - storeLog :: Maybe (StoreLog 'ReadMode), + storeLogFile :: Maybe FilePath, + -- storeLog :: Maybe (StoreLog 'ReadMode), -- CA certificate private key is not needed for initialization caCertificateFile :: FilePath, privateKeyFile :: FilePath, @@ -99,12 +100,13 @@ newSubscription = do return Sub {subThread = NoSub, delivered} newEnv :: forall m. (MonadUnliftIO m, MonadRandom m) => ServerConfig -> m Env -newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile} = do +newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do server <- atomically $ newServer (serverTbqSize config) queueStore <- atomically newQueueStore msgStore <- atomically newMsgStore idsDrg <- drgNew >>= newTVarIO - s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig) + storeLog <- liftIO $ openReadStoreLog `mapM` storeLogFile + s' <- restoreQueues queueStore `mapM` storeLog tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile let serverIdentity = KeyHash fp diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 3789647f5..e5a57ab72 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -19,7 +19,6 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM -import Simplex.Messaging.Server.StoreLog (openReadStoreLog) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.KeepAlive @@ -60,19 +59,17 @@ cfg = msgQueueQuota = 4, queueIdBytes = 24, msgIdBytes = 24, - storeLog = Nothing, + storeLogFile = Nothing, caCertificateFile = "tests/fixtures/ca.crt", privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt" } withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a -withSmpServerStoreLogOn t port' client = do - s <- liftIO $ openReadStoreLog testStoreLogFile +withSmpServerStoreLogOn t port' = serverBracket - (\started -> runSMPServerBlocking started cfg {transports = [(port', t)], storeLog = Just s}) + (\started -> runSMPServerBlocking started cfg {transports = [(port', t)], storeLogFile = Just testStoreLogFile}) (pure ()) - client withSmpServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a withSmpServerThreadOn t port' =