293 lines
12 KiB
Haskell
293 lines
12 KiB
Haskell
{-# 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 Simplex.Messaging.Util (whenM)
|
|
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
|
|
import System.Exit (exitFailure)
|
|
import System.FilePath (combine)
|
|
import System.IO (BufferMode (..), IOMode (..), hFlush, 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,
|
|
mkIniFile :: Bool -> ServiceName -> String,
|
|
mkServerConfig :: Maybe FilePath -> [(ServiceName, ATransport)] -> Ini -> cfg
|
|
}
|
|
|
|
protocolServerCLI :: ServerCLIConfig cfg -> (cfg -> IO ()) -> IO ()
|
|
protocolServerCLI cliCfg@ServerCLIConfig {iniFile, executableName} server =
|
|
getCliCommand cliCfg >>= \case
|
|
Init opts ->
|
|
doesFileExist iniFile >>= \case
|
|
True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`."
|
|
_ -> initializeServer cliCfg opts
|
|
Start ->
|
|
doesFileExist iniFile >>= \case
|
|
True -> readIniFile iniFile >>= either exitError (runServer cliCfg server)
|
|
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
|
|
Delete -> do
|
|
confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
|
|
cleanup cliCfg
|
|
putStrLn "Deleted configuration and log files"
|
|
|
|
exitError :: String -> IO ()
|
|
exitError msg = putStrLn msg >> exitFailure
|
|
|
|
confirmOrExit :: String -> IO ()
|
|
confirmOrExit s = do
|
|
putStrLn s
|
|
putStr "Continue (Y/n): "
|
|
hFlush stdout
|
|
ok <- getLine
|
|
when (ok /= "Y") exitFailure
|
|
|
|
data CliCommand
|
|
= Init InitOptions
|
|
| Start
|
|
| Delete
|
|
|
|
data InitOptions = InitOptions
|
|
{ enableStoreLog :: Bool,
|
|
signAlgorithm :: SignAlgorithm,
|
|
ip :: HostName,
|
|
fqdn :: Maybe HostName
|
|
}
|
|
deriving (Show)
|
|
|
|
data SignAlgorithm = ED448 | ED25519
|
|
deriving (Read, Show)
|
|
|
|
getCliCommand :: ServerCLIConfig cfg -> IO CliCommand
|
|
getCliCommand cliCfg =
|
|
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
|
|
clearDirs cliCfg
|
|
createDirectoryIfMissing True cfgDir
|
|
createDirectoryIfMissing True logDir
|
|
createX509
|
|
fp <- saveFingerprint
|
|
writeFile iniFile $ mkIniFile enableStoreLog defaultServerPort
|
|
putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server."
|
|
printServiceInfo cliCfg fp
|
|
warnCAPrivateKeyFile
|
|
where
|
|
ServerCLIConfig {cfgDir, logDir, iniFile, executableName, caKeyFile, caCrtFile, serverKeyFile, serverCrtFile, fingerprintFile, defaultServerPort, mkIniFile} = cliCfg
|
|
createX509 = do
|
|
createOpensslCaConf
|
|
createOpensslServerConf
|
|
-- CA certificate (identity/offline)
|
|
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> caKeyFile
|
|
run $ "openssl req -new -x509 -days 999999 -config " <> opensslCaConfFile <> " -extensions v3 -key " <> caKeyFile <> " -out " <> caCrtFile
|
|
-- server certificate (online)
|
|
run $ "openssl genpkey -algorithm " <> show signAlgorithm <> " -out " <> serverKeyFile
|
|
run $ "openssl req -new -config " <> opensslServerConfFile <> " -reqexts v3 -key " <> serverKeyFile <> " -out " <> serverCsrFile
|
|
run $ "openssl x509 -req -days 999999 -extfile " <> opensslServerConfFile <> " -extensions v3 -in " <> serverCsrFile <> " -CA " <> caCrtFile <> " -CAkey " <> caKeyFile <> " -CAcreateserial -out " <> serverCrtFile
|
|
where
|
|
run cmd = void $ readCreateProcess (shell cmd) ""
|
|
opensslCaConfFile = combine cfgDir "openssl_ca.conf"
|
|
opensslServerConfFile = combine cfgDir "openssl_server.conf"
|
|
serverCsrFile = combine cfgDir "server.csr"
|
|
createOpensslCaConf =
|
|
writeFile
|
|
opensslCaConfFile
|
|
"[req]\n\
|
|
\distinguished_name = req_distinguished_name\n\
|
|
\prompt = no\n\n\
|
|
\[req_distinguished_name]\n\
|
|
\CN = SMP server CA\n\
|
|
\O = SimpleX\n\n\
|
|
\[v3]\n\
|
|
\subjectKeyIdentifier = hash\n\
|
|
\authorityKeyIdentifier = keyid:always\n\
|
|
\basicConstraints = critical,CA:true\n"
|
|
-- TODO revise https://www.rfc-editor.org/rfc/rfc5280#section-4.2.1.3, https://www.rfc-editor.org/rfc/rfc3279#section-2.3.5
|
|
-- IP and FQDN can't both be used as server address interchangeably even if IP is added
|
|
-- as Subject Alternative Name, unless the following validation hook is disabled:
|
|
-- https://hackage.haskell.org/package/x509-validation-1.6.10/docs/src/Data-X509-Validation.html#validateCertificateName
|
|
createOpensslServerConf =
|
|
writeFile
|
|
opensslServerConfFile
|
|
( "[req]\n\
|
|
\distinguished_name = req_distinguished_name\n\
|
|
\prompt = no\n\n\
|
|
\[req_distinguished_name]\n"
|
|
<> ("CN = " <> cn <> "\n\n")
|
|
<> "[v3]\n\
|
|
\basicConstraints = CA:FALSE\n\
|
|
\keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
|
|
\extendedKeyUsage = serverAuth\n"
|
|
)
|
|
where
|
|
cn = fromMaybe ip fqdn
|
|
|
|
saveFingerprint = do
|
|
Fingerprint fp <- loadFingerprint caCrtFile
|
|
withFile fingerprintFile WriteMode (`B.hPutStrLn` strEncode fp)
|
|
pure fp
|
|
|
|
warnCAPrivateKeyFile =
|
|
putStrLn $
|
|
"----------\n\
|
|
\You should store CA private key securely and delete it from the server.\n\
|
|
\If server TLS credential is compromised this key can be used to sign a new one, \
|
|
\keeping the same server identity and established connections.\n\
|
|
\CA private key location:\n"
|
|
<> caKeyFile
|
|
<> "\n----------"
|
|
|
|
data IniOptions = IniOptions
|
|
{ enableStoreLog :: Bool,
|
|
port :: ServiceName,
|
|
enableWebsockets :: Bool
|
|
}
|
|
|
|
mkIniOptions :: Ini -> IniOptions
|
|
mkIniOptions ini =
|
|
IniOptions
|
|
{ enableStoreLog = (== "on") $ strictIni "STORE_LOG" "enable" ini,
|
|
port = T.unpack $ strictIni "TRANSPORT" "port" ini,
|
|
enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
|
|
}
|
|
|
|
strictIni :: String -> String -> Ini -> T.Text
|
|
strictIni section key ini =
|
|
fromRight (error ("no key " <> key <> " in section " <> section)) $
|
|
lookupValue (T.pack section) (T.pack key) ini
|
|
|
|
readStrictIni :: Read a => String -> String -> Ini -> a
|
|
readStrictIni section key = read . T.unpack . strictIni section key
|
|
|
|
runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> Ini -> IO ()
|
|
runServer cliCfg server ini = do
|
|
hSetBuffering stdout LineBuffering
|
|
hSetBuffering stderr LineBuffering
|
|
fp <- checkSavedFingerprint
|
|
printServiceInfo cliCfg fp
|
|
let IniOptions {enableStoreLog, port, enableWebsockets} = mkIniOptions ini
|
|
transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets]
|
|
logFile = if enableStoreLog then Just storeLogFile else Nothing
|
|
cfg = mkServerConfig logFile transports ini
|
|
printServerConfig logFile transports
|
|
server cfg
|
|
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 = whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
|
|
|
|
clearDirs :: ServerCLIConfig cfg -> IO ()
|
|
clearDirs ServerCLIConfig {cfgDir, logDir} = do
|
|
clearDirIfExists cfgDir
|
|
clearDirIfExists logDir
|
|
where
|
|
clearDirIfExists path = whenM (doesDirectoryExist path) $ listDirectory path >>= mapM_ (removePathForcibly . combine path)
|
|
|
|
printServiceInfo :: ServerCLIConfig cfg -> ByteString -> IO ()
|
|
printServiceInfo ServerCLIConfig {serverVersion} fpStr = do
|
|
putStrLn serverVersion
|
|
B.putStrLn $ "Fingerprint: " <> strEncode fpStr
|