mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-28 00:44:38 +00:00
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
This commit is contained in:
Evgeny Poberezkin
@@ -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
|
||||
}
|
||||
}
|
||||
+39
-304
@@ -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
|
||||
|
||||
+12
-4
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
|
||||
+3
-6
@@ -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' =
|
||||
|
||||
Reference in New Issue
Block a user