{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

module Simplex.Messaging.Server.Main
  ( EmbeddedWebParams (..),
    WebHttpsParams (..),
    CliCommand (..),
    StoreCmd (..),
    DatabaseTable (..),
    smpServerCLI,
    smpServerCLI_,
#if defined(dbServerPostgres)
    importStoreLogToDatabase,
    importMessagesToDatabase,
    exportDatabaseToStoreLog,
#endif
    newJournalMsgStore,
    storeMsgsJournalDir',
    getServerSourceCode,
    simplexmqSource,
    serverPublicInfo,
    validCountryValue,
    printSourceCode,
    cliCommandP,
    strParse,
  ) where

import Control.Concurrent.STM
import Control.Exception (SomeException, finally, try)
import Control.Logger.Simple
import Control.Monad
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlpha, isAscii, toUpper)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.Ini (Ini, lookupValue, readIniFile)
import Data.Int (Int64)
import Data.List (find, isPrefixOf)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import qualified Data.Text.IO as T
import Options.Applicative
import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), connReqUriP')
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.Main.Init
import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..))
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore)
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
import Simplex.Messaging.Server.QueueStore.Postgres.Config
import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
import Simplex.Messaging.Util (eitherToMaybe, ifM, unlessM)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import System.Exit (exitFailure)
import System.FilePath (combine)
import System.IO (BufferMode (..), IOMode (..), hSetBuffering, stderr, stdout, withFile)
import Text.Read (readMaybe)

#if defined(dbServerPostgres)
import Data.Semigroup (Sum (..))
import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
import Simplex.Messaging.Server.MsgStore.Journal (postgresQueueStore)
import Simplex.Messaging.Server.MsgStore.Postgres
import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs)
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.StoreLog (closeStoreLog, logNewService, logCreateQueue, openWriteStoreLog)
import System.Directory (renameFile)
#endif

smpServerCLI :: FilePath -> FilePath -> IO ()
smpServerCLI :: String -> String -> IO ()
smpServerCLI = (ServerInformation -> Maybe TransportHost -> String -> IO ())
-> (EmbeddedWebParams -> IO ())
-> (String -> (AttachHTTP -> IO ()) -> IO ())
-> String
-> String
-> IO ()
smpServerCLI_ (\ServerInformation
_ Maybe TransportHost
_ String
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\EmbeddedWebParams
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\String
_ -> String -> (AttachHTTP -> IO ()) -> IO ()
forall a. HasCallStack => String -> a
error String
"attachStaticFiles not available")

smpServerCLI_ ::
  (ServerInformation -> Maybe TransportHost -> FilePath -> IO ()) ->
  (EmbeddedWebParams -> IO ()) ->
  (FilePath -> (AttachHTTP -> IO ()) -> IO ()) ->
  FilePath ->
  FilePath ->
  IO ()
smpServerCLI_ :: (ServerInformation -> Maybe TransportHost -> String -> IO ())
-> (EmbeddedWebParams -> IO ())
-> (String -> (AttachHTTP -> IO ()) -> IO ())
-> String
-> String
-> IO ()
smpServerCLI_ ServerInformation -> Maybe TransportHost -> String -> IO ()
generateSite EmbeddedWebParams -> IO ()
serveStaticFiles String -> (AttachHTTP -> IO ()) -> IO ()
attachStaticFiles String
cfgPath String
logPath =
  Parser CliCommand -> String -> IO CliCommand
forall cmd. Parser cmd -> String -> IO cmd
getCliCommand' (String -> String -> String -> Parser CliCommand
cliCommandP String
cfgPath String
logPath String
iniFile) String
serverVersion IO CliCommand -> (CliCommand -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Init InitOptions
opts ->
      String -> IO Bool
doesFileExist String
iniFile IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> String -> IO ()
forall a. String -> IO a
exitError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error: server is already initialized (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
iniFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" exists).\nRun `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
executableName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" start`."
        Bool
_ -> InitOptions -> IO ()
initializeServer InitOptions
opts
    OnlineCert CertOptions
certOpts -> (Ini -> IO ()) -> IO ()
withIniFile ((Ini -> IO ()) -> IO ()) -> (Ini -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ini
_ -> String -> CertOptions -> IO ()
genOnline String
cfgPath CertOptions
certOpts
    Start StartOptions
opts -> (Ini -> IO ()) -> IO ()
withIniFile ((Ini -> IO ()) -> IO ()) -> (Ini -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ StartOptions -> Ini -> IO ()
runServer StartOptions
opts
    CliCommand
Delete -> do
      String -> String -> IO ()
confirmOrExit
        String
"WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!"
        String
"Server NOT deleted"
      String -> IO ()
deleteDirIfExists String
cfgPath
      String -> IO ()
deleteDirIfExists String
logPath
      String -> IO ()
putStrLn String
"Deleted configuration and log files"
    Journal StoreCmd
cmd -> (Ini -> IO ()) -> IO ()
withIniFile ((Ini -> IO ()) -> IO ()) -> (Ini -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ini
ini -> do
      Bool
msgsDirExists <- String -> IO Bool
doesDirectoryExist String
storeMsgsJournalDir
      Bool
msgsFileExists <- String -> IO Bool
doesFileExist String
storeMsgsFilePath
      String
storeLogFile <- Ini -> IO String
getRequiredStoreLogFile Ini
ini
      case StoreCmd
cmd of
        StoreCmd
SCImport
          | Bool
msgsFileExists Bool -> Bool -> Bool
&& Bool
msgsDirExists -> IO ()
exitConfigureMsgStorage
          | Bool
msgsDirExists -> do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
storeMsgsJournalDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" directory already exists."
              IO ()
forall a. IO a
exitFailure
          | Bool -> Bool
not Bool
msgsFileExists -> do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
storeMsgsFilePath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" file does not exist."
              IO ()
forall a. IO a
exitFailure
          | Bool
otherwise -> do
              String -> String -> IO ()
confirmOrExit
                (String
"WARNING: message log file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsFilePath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" will be imported to journal directory " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsJournalDir)
                String
"Messages not imported"
              JournalMsgStore 'QSMemory
ms <- String -> QStoreCfg 'QSMemory -> IO (JournalMsgStore 'QSMemory)
forall (s :: QSType).
String -> QStoreCfg s -> IO (JournalMsgStore s)
newJournalMsgStore String
logPath QStoreCfg 'QSMemory
MQStoreCfg
              Bool
-> (RecipientId -> QueueRec -> IO (JournalQueue 'QSMemory))
-> String
-> STMQueueStore (JournalQueue 'QSMemory)
-> IO ()
forall q.
StoreQueueClass q =>
Bool
-> (RecipientId -> QueueRec -> IO q)
-> String
-> STMQueueStore q
-> IO ()
readQueueStore Bool
True (JournalMsgStore 'QSMemory
-> Bool
-> RecipientId
-> QueueRec
-> IO (StoreQueue (JournalMsgStore 'QSMemory))
forall s.
MsgStoreClass s =>
s -> Bool -> RecipientId -> QueueRec -> IO (StoreQueue s)
mkQueue JournalMsgStore 'QSMemory
ms Bool
False) String
storeLogFile (STMQueueStore (JournalQueue 'QSMemory) -> IO ())
-> STMQueueStore (JournalQueue 'QSMemory) -> IO ()
forall a b. (a -> b) -> a -> b
$ JournalMsgStore 'QSMemory -> STMQueueStore (JournalQueue 'QSMemory)
stmQueueStore JournalMsgStore 'QSMemory
ms
              MessageStats
msgStats <- Bool
-> JournalMsgStore 'QSMemory
-> String
-> Maybe Int64
-> Bool
-> IO MessageStats
forall s.
MsgStoreClass s =>
Bool -> s -> String -> Maybe Int64 -> Bool -> IO MessageStats
importMessages Bool
True JournalMsgStore 'QSMemory
ms String
storeMsgsFilePath Maybe Int64
forall a. Maybe a
Nothing Bool
False -- no expiration
              String -> IO ()
putStrLn String
"Import completed"
              Text -> MessageStats -> IO ()
printMessageStats Text
"Messages" MessageStats
msgStats
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case Ini -> Either String AStoreType
readStoreType Ini
ini of
                Right (ASType SQSType qs
SQSMemory SMSType ms
SMSMemory) -> String
"store_messages set to `memory`, update it to `journal` in INI file"
                Right (ASType SQSType qs
SQSPostgres SMSType ms
SMSPostgres) -> String
"store_messages set to `database`, update it to `journal` in INI file"
                Right (ASType SQSType qs
_ SMSType ms
SMSJournal) -> String
"store_messages set to `journal`"
                Left String
e -> String
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", configure storage correctly"
        StoreCmd
SCExport
          | Bool
msgsFileExists Bool -> Bool -> Bool
&& Bool
msgsDirExists -> IO ()
exitConfigureMsgStorage
          | Bool
msgsFileExists -> do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
storeMsgsFilePath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" file already exists."
              IO ()
forall a. IO a
exitFailure
          | Bool
otherwise -> do
              String -> String -> IO ()
confirmOrExit
                (String
"WARNING: journal directory " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsJournalDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" will be exported to message log file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsFilePath)
                String
"Journal not exported"
              case Ini -> Either String AStoreType
readStoreType Ini
ini of
                Right (ASType SQSType qs
SQSMemory SMSType ms
msType) -> do
                  JournalMsgStore 'QSMemory
ms <- String -> QStoreCfg 'QSMemory -> IO (JournalMsgStore 'QSMemory)
forall (s :: QSType).
String -> QStoreCfg s -> IO (JournalMsgStore s)
newJournalMsgStore String
logPath QStoreCfg 'QSMemory
MQStoreCfg
                  Bool
-> (RecipientId -> QueueRec -> IO (JournalQueue 'QSMemory))
-> String
-> STMQueueStore (JournalQueue 'QSMemory)
-> IO ()
forall q.
StoreQueueClass q =>
Bool
-> (RecipientId -> QueueRec -> IO q)
-> String
-> STMQueueStore q
-> IO ()
readQueueStore Bool
True (JournalMsgStore 'QSMemory
-> Bool
-> RecipientId
-> QueueRec
-> IO (StoreQueue (JournalMsgStore 'QSMemory))
forall s.
MsgStoreClass s =>
s -> Bool -> RecipientId -> QueueRec -> IO (StoreQueue s)
mkQueue JournalMsgStore 'QSMemory
ms Bool
False) String
storeLogFile (STMQueueStore (JournalQueue 'QSMemory) -> IO ())
-> STMQueueStore (JournalQueue 'QSMemory) -> IO ()
forall a b. (a -> b) -> a -> b
$ JournalMsgStore 'QSMemory -> STMQueueStore (JournalQueue 'QSMemory)
stmQueueStore JournalMsgStore 'QSMemory
ms
                  Bool
-> MsgStore (JournalMsgStore 'QSMemory) -> String -> Bool -> IO ()
forall s.
MsgStoreClass s =>
Bool -> MsgStore s -> String -> Bool -> IO ()
exportMessages Bool
True (JournalMsgStore 'QSMemory -> MsgStore (JournalMsgStore 'QSMemory)
forall (qs :: QSType).
JournalMsgStore qs -> MsgStore (JournalMsgStore qs)
StoreJournal JournalMsgStore 'QSMemory
ms) String
storeMsgsFilePath Bool
False
                  String -> IO ()
putStrLn String
"Export completed"
                  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case SMSType ms
msType of
                    SMSType ms
SMSMemory -> String
"store_messages set to `memory`, start the server."
                    SMSType ms
SMSJournal -> String
"store_messages set to `journal`, update it to `memory` in INI file"
#if defined(dbServerPostgres)
                Right (ASType SQSPostgres SMSJournal) -> do
                  let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
                      dbOpts@DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
                  unlessM (checkSchemaExists connstr schema) $ do
                    putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
                    exitFailure
                  ms <- newJournalMsgStore logPath $ PQStoreCfg PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
                  exportMessages True (StoreJournal ms) storeMsgsFilePath False
                  putStrLn "Export completed"
                  putStrLn "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)."
                Right (ASType SQSPostgres SMSPostgres) -> do
                  putStrLn $ "Messages can be exported with `dabatase export --table messages`."
                  exitFailure
#else
                Right (ASType SQSType qs
SQSPostgres SMSType ms
SMSJournal) -> IO ()
forall a. IO a
noPostgresExit
#endif
                Left String
e -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", configure storage correctly"
        StoreCmd
SCDelete
          | Bool -> Bool
not Bool
msgsDirExists -> do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
storeMsgsJournalDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" directory does not exists."
              IO ()
forall a. IO a
exitFailure
          | Bool
otherwise -> do
              String -> String -> IO ()
confirmOrExit
                (String
"WARNING: journal directory " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsJournalDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" will be permanently deleted.\nTHIS CANNOT BE UNDONE!")
                String
"Messages NOT deleted"
              String -> IO ()
deleteDirIfExists String
storeMsgsJournalDir
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Deleted all messages in journal " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsJournalDir
#if defined(dbServerPostgres)
    Database cmd tables dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
      schemaExists <- checkSchemaExists connstr schema
      storeLogExists <- doesFileExist storeLogFilePath
      msgsFileExists <- doesFileExist storeMsgsFilePath
      case (cmd, tables) of
        (SCImport, DTAll)
          | not schemaExists && storeLogExists && msgsFileExists -> do
              storeLogFile <- getRequiredStoreLogFile ini
              confirmOrExit
                ("WARNING: store log file " <> storeLogFile <> " and message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
                "Store logs not imported"
              (sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
              putStrLn $ "Imported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
              putStrLn "Importing messages..."
              mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts
              putStrLn $ "Import completed: " <> show mCnt <> " messages"
              putStrLn $ case readStoreType ini of
                Right (ASType SQSPostgres SMSPostgres) -> "store_queues and store_messages set to `database`, start the server."
                Right _ -> "set store_queues and store_messages to `database` in INI file"
                Left e -> e <> ", configure storage correctly"
          | otherwise -> do
              when schemaExists $ putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
              unless storeLogExists $ putStrLn $ storeLogFilePath <> " file does not exist."
              unless msgsFileExists $ putStrLn $ storeMsgsFilePath <> " file does not exist."
              exitFailure
        (SCImport, DTQueues)
          | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
          | schemaExists -> do
              putStrLn $ "Schema " <> B.unpack schema <> " already exists in PostrgreSQL database: " <> B.unpack connstr
              exitFailure
          | not storeLogExists -> do
              putStrLn $ storeLogFilePath <> " file does not exist."
              exitFailure
          | otherwise -> do
              storeLogFile <- getRequiredStoreLogFile ini
              confirmOrExit
                ("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
                "Queue records not imported"
              (sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
              putStrLn $ "Import completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
              putStrLn $ case readStoreType ini of
                Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, import messages to journal to use PostgreSQL database for queues (`smp-server journal import`)"
                Right (ASType SQSMemory SMSJournal) -> setToDbStr
                Right (ASType SQSPostgres _) -> "store_queues set to `database`, start the server."
                Left e -> e <> ", configure storage correctly"
          where
            setToDbStr :: String
            setToDbStr = "store_queues set to `memory`, update it to `database` in INI file"
        (SCImport, DTMessages)
          | not schemaExists -> do
              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
              exitFailure
          | not msgsFileExists -> do
              putStrLn $ storeMsgsFilePath <> " file does not exist."
              exitFailure
          | otherwise -> do
              confirmOrExit
                ("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
                "Message records not imported"
              mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts
              putStrLn $ "Import completed: " <> show mCnt <> " messages"
              putStrLn $ case readStoreType ini of
                Right (ASType SQSPostgres SMSPostgres) -> "store_queues and store_messages set to `database`, start the server."
                Right _ -> "set store_queues and store_messages to `database` in INI file"
                Left e -> e <> ", configure storage correctly"
        (SCExport, DTAll)
          | schemaExists && not storeLogExists && not msgsFileExists -> do
              confirmOrExit
                ("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath <> " and to message log file " <> storeMsgsFilePath)
                "Database store not exported"
              (sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
              putStrLn $ "Exported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
              putStrLn "Exporting messages..."
              let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
              ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
              withFile storeMsgsFilePath WriteMode (try . exportDbMessages True ms) >>= \case
                Right mCnt -> putStrLn $ "Export completed: " <> show mCnt <> " messages"
                Left (e :: SomeException) -> putStrLn $ "Error exporting messages: " <> show e
              closeMsgStore ms
          | otherwise -> do
              unless schemaExists $ putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
              when storeLogExists $ putStrLn $ storeLogFilePath <> " file already exists."
              when msgsFileExists $ putStrLn $ storeMsgsFilePath <> " file already exists."
              exitFailure
        (SCExport, DTQueues)
          | schemaExists && storeLogExists -> exitConfigureQueueStore connstr schema
          | not schemaExists -> do
              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
              exitFailure
          | storeLogExists -> do
              putStrLn $ storeLogFilePath <> " file already exists."
              exitFailure
          | otherwise -> do
              confirmOrExit
                ("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
                "Queue records not exported"
              (sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
              putStrLn $ "Export completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
              putStrLn $ case readStoreType ini of
                Right (ASType SQSPostgres _) -> "store_queues or store_messages set to `database`, update it to `memory` in INI file."
                Right (ASType SQSMemory _) -> "store_queues set to `memory`, start the server"
                Left e -> e <> ", configure storage correctly"
        (SCExport, DTMessages)
          | not schemaExists -> do
              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
              exitFailure
          | msgsFileExists -> do
              putStrLn $ storeMsgsFilePath <> " file already exists."
              exitFailure
          | otherwise -> do
              confirmOrExit
                ("WARNING: Messages from PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to message log file " <> storeMsgsFilePath)
                "Message records not exported"
              let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
              ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
              withFile storeMsgsFilePath WriteMode (try . exportDbMessages True ms) >>= \case
                Right mCnt -> do
                  putStrLn $ "Export completed: " <> show mCnt <> " messages"
                  putStrLn "Export queues with `smp-server database export queues`"
                Left (e :: SomeException) -> putStrLn $ "Error exporting messages: " <> show e
              closeMsgStore ms
        (SCDelete, _)
          | not schemaExists -> do
              putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
              exitFailure
          | otherwise -> do
              putStrLn $ "Open database: psql " <> B.unpack connstr
              putStrLn $ "Delete schema: DROP SCHEMA " <> B.unpack schema <> " CASCADE;"
#else
    Database {} -> IO ()
forall a. IO a
noPostgresExit
#endif
  where
    withIniFile :: (Ini -> IO ()) -> IO ()
withIniFile Ini -> IO ()
a =
      String -> IO Bool
doesFileExist String
iniFile IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> String -> IO (Either String Ini)
readIniFile String
iniFile IO (Either String Ini) -> (Either String Ini -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO ()) -> (Ini -> IO ()) -> Either String Ini -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO ()
forall a. String -> IO a
exitError Ini -> IO ()
a
        Bool
_ -> String -> IO ()
forall a. String -> IO a
exitError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error: server is not initialized (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
iniFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not exist).\nRun `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
executableName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" init`."
    getRequiredStoreLogFile :: Ini -> IO String
getRequiredStoreLogFile Ini
ini = do
      case Ini -> Maybe ()
enableStoreLog' Ini
ini Maybe () -> String -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String
storeLogFilePath of
        Just String
storeLogFile -> do
          IO Bool -> IO String -> IO String -> IO String
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
            (String -> IO Bool
doesFileExist String
storeLogFile)
            (String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
storeLogFile)
            (String -> IO ()
putStrLn (String
"Store log file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeLogFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not found") IO () -> IO String -> IO String
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO String
forall a. IO a
exitFailure)
        Maybe String
Nothing -> String -> IO ()
putStrLn String
"Store log disabled, see `[STORE_LOG] enable`" IO () -> IO String -> IO String
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO String
forall a. IO a
exitFailure
    iniFile :: String
iniFile = String -> String -> String
combine String
cfgPath String
"smp-server.ini"
    serverVersion :: String
serverVersion = String
"SMP server v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
simplexmqVersionCommit
    executableName :: String
executableName = String
"smp-server"
    storeLogFilePath :: String
storeLogFilePath = String -> String -> String
combine String
logPath String
"smp-server-store.log"
    storeMsgsFilePath :: String
storeMsgsFilePath = String -> String -> String
combine String
logPath String
"smp-server-messages.log"
    storeMsgsJournalDir :: String
storeMsgsJournalDir = String -> String
storeMsgsJournalDir' String
logPath
    storeNtfsFilePath :: String
storeNtfsFilePath = String -> String -> String
combine String
logPath String
"smp-server-ntfs.log"
    readStoreType :: Ini -> Either String AStoreType
    readStoreType :: Ini -> Either String AStoreType
readStoreType Ini
ini = case (Text
iniStoreQueues, Text
iniStoreMessage) of
      (Text
"memory", Text
"memory") -> AStoreType -> Either String AStoreType
forall a b. b -> Either a b
Right (AStoreType -> Either String AStoreType)
-> AStoreType -> Either String AStoreType
forall a b. (a -> b) -> a -> b
$ SQSType 'QSMemory -> SMSType 'MSMemory -> AStoreType
forall (qs :: QSType) (ms :: MSType).
(SupportedStore qs ms, MsgStoreClass (MsgStoreType qs ms)) =>
SQSType qs -> SMSType ms -> AStoreType
ASType SQSType 'QSMemory
SQSMemory SMSType 'MSMemory
SMSMemory
      (Text
"memory", Text
"journal") -> AStoreType -> Either String AStoreType
forall a b. b -> Either a b
Right (AStoreType -> Either String AStoreType)
-> AStoreType -> Either String AStoreType
forall a b. (a -> b) -> a -> b
$ SQSType 'QSMemory -> SMSType 'MSJournal -> AStoreType
forall (qs :: QSType) (ms :: MSType).
(SupportedStore qs ms, MsgStoreClass (MsgStoreType qs ms)) =>
SQSType qs -> SMSType ms -> AStoreType
ASType SQSType 'QSMemory
SQSMemory SMSType 'MSJournal
SMSJournal
      (Text
"memory", Text
"database") -> String -> Either String AStoreType
forall a b. a -> Either a b
Left String
"Database and memory storage are not compatible."
      (Text
"database", Text
"memory") -> String -> Either String AStoreType
forall a b. a -> Either a b
Left String
"Database and memory storage are not compatible."
      (Text
"database", Text
"journal") -> AStoreType -> Either String AStoreType
forall a b. b -> Either a b
Right (AStoreType -> Either String AStoreType)
-> AStoreType -> Either String AStoreType
forall a b. (a -> b) -> a -> b
$ SQSType 'QSPostgres -> SMSType 'MSJournal -> AStoreType
forall (qs :: QSType) (ms :: MSType).
(SupportedStore qs ms, MsgStoreClass (MsgStoreType qs ms)) =>
SQSType qs -> SMSType ms -> AStoreType
ASType SQSType 'QSPostgres
SQSPostgres SMSType 'MSJournal
SMSJournal
#if defined(dbServerPostgres)
      ("database", "database") -> Right $ ASType SQSPostgres SMSPostgres
#else
      (Text
"database", Text
"database") -> String -> Either String AStoreType
forall a b. a -> Either a b
Left String
noPostgresExitStr
#endif
      (Text
q, Text
m) -> String -> Either String AStoreType
forall a b. a -> Either a b
Left (String -> Either String AStoreType)
-> String -> Either String AStoreType
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Invalid storage settings: store_queues: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", store_messages: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
m
      where
        iniStoreQueues :: Text
iniStoreQueues = Text -> Either String Text -> Text
forall b a. b -> Either a b -> b
fromRight Text
"memory" (Either String Text -> Text) -> Either String Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Either String Text
lookupValue Text
"STORE_LOG" Text
"store_queues" Ini
ini
        iniStoreMessage :: Text
iniStoreMessage = Text -> Either String Text -> Text
forall b a. b -> Either a b -> b
fromRight Text
"memory" (Either String Text -> Text) -> Either String Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Either String Text
lookupValue Text
"STORE_LOG" Text
"store_messages" Ini
ini
    iniDeletedTTL :: Ini -> Int64
iniDeletedTTL Ini
ini = Int64 -> Text -> Text -> Ini -> Int64
forall a. Read a => a -> Text -> Text -> Ini -> a
readIniDefault (Int64
86400 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
defaultDeletedTTL) Text
"STORE_LOG" Text
"db_deleted_ttl" Ini
ini
    defaultStaticPath :: String
defaultStaticPath = String -> String -> String
combine String
logPath String
"www"
    enableStoreLog' :: Ini -> Maybe ()
enableStoreLog' = Text -> Text -> Ini -> Maybe ()
settingIsOn Text
"STORE_LOG" Text
"enable"
    enableDbStoreLog' :: Ini -> Maybe ()
enableDbStoreLog' = Text -> Text -> Ini -> Maybe ()
settingIsOn Text
"STORE_LOG" Text
"db_store_log"
    initializeServer :: InitOptions -> IO ()
initializeServer InitOptions
opts
      | InitOptions -> Bool
scripted InitOptions
opts = InitOptions -> IO ()
initialize InitOptions
opts
      | Bool
otherwise = do
          let InitOptions {String
ip :: String
$sel:ip:InitOptions :: InitOptions -> String
ip, Maybe String
fqdn :: Maybe String
$sel:fqdn:InitOptions :: InitOptions -> Maybe String
fqdn, $sel:sourceCode:InitOptions :: InitOptions -> Maybe Text
sourceCode = Maybe Text
src', $sel:webStaticPath:InitOptions :: InitOptions -> Maybe String
webStaticPath = Maybe String
sp', $sel:disableWeb:InitOptions :: InitOptions -> Bool
disableWeb = Bool
noWeb'} = InitOptions
opts
          String -> IO ()
putStrLn String
"Use `smp-server init -h` for available options."
          InitOptions -> IO ()
checkInitOptions InitOptions
opts
          IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String -> IO String
forall a. String -> IO a -> IO a
withPrompt String
"SMP server will be initialized (press Enter)" IO String
getLine
          Bool
enableStoreLog <- String -> Bool -> IO Bool
onOffPrompt String
"Enable store log to restore queues and messages on server restart" Bool
True
          Bool
logStats <- String -> Bool -> IO Bool
onOffPrompt String
"Enable logging daily statistics" Bool
False
          String -> IO ()
putStrLn String
"Require a password to create new messaging queues?"
          Maybe ServerPassword
password <- String -> IO (Maybe ServerPassword) -> IO (Maybe ServerPassword)
forall a. String -> IO a -> IO a
withPrompt String
"'r' for random (default), 'n' - no password (recommended for public servers), or enter password: " IO (Maybe ServerPassword)
serverPassword
          let host :: String
host = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
ip Maybe String
fqdn
          String
host' <- String -> IO String -> IO String
forall a. String -> IO a -> IO a
withPrompt (String
"Enter server FQDN or IP address for certificate (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
host String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"): ") IO String
getLine
          Maybe String
sourceCode' <- String -> IO (Maybe String) -> IO (Maybe String)
forall a. String -> IO a -> IO a
withPrompt (String
"Enter server source code URI (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
simplexmqSource Text -> String
T.unpack Maybe Text
src' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"): ") IO (Maybe String)
getServerSourceCode
          String
staticPath' <- String -> IO String -> IO String
forall a. String -> IO a -> IO a
withPrompt (String
"Enter path to store generated server pages to show connection links (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
defaultStaticPath Maybe String
sp' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"): ") IO String
getLine
          InitOptions -> IO ()
initialize
            InitOptions
opts
              { enableStoreLog,
                logStats,
                fqdn = if null host' then fqdn else Just host',
                password,
                sourceCode = (T.pack <$> sourceCode') <|> src' <|> Just (T.pack simplexmqSource),
                webStaticPath = if null staticPath' then sp' else Just staticPath',
                disableWeb = noWeb'
              }
      where
        serverPassword :: IO (Maybe ServerPassword)
serverPassword =
          IO String
getLine IO String
-> (String -> IO (Maybe ServerPassword))
-> IO (Maybe ServerPassword)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            String
"" -> Maybe ServerPassword -> IO (Maybe ServerPassword)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ServerPassword -> IO (Maybe ServerPassword))
-> Maybe ServerPassword -> IO (Maybe ServerPassword)
forall a b. (a -> b) -> a -> b
$ ServerPassword -> Maybe ServerPassword
forall a. a -> Maybe a
Just ServerPassword
SPRandom
            String
"r" -> Maybe ServerPassword -> IO (Maybe ServerPassword)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ServerPassword -> IO (Maybe ServerPassword))
-> Maybe ServerPassword -> IO (Maybe ServerPassword)
forall a b. (a -> b) -> a -> b
$ ServerPassword -> Maybe ServerPassword
forall a. a -> Maybe a
Just ServerPassword
SPRandom
            String
"n" -> Maybe ServerPassword -> IO (Maybe ServerPassword)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ServerPassword
forall a. Maybe a
Nothing
            String
s ->
              case ByteString -> Either String BasicAuth
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String BasicAuth)
-> ByteString -> Either String BasicAuth
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s of
                Right BasicAuth
auth -> Maybe ServerPassword -> IO (Maybe ServerPassword)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ServerPassword -> IO (Maybe ServerPassword))
-> (ServerPassword -> Maybe ServerPassword)
-> ServerPassword
-> IO (Maybe ServerPassword)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerPassword -> Maybe ServerPassword
forall a. a -> Maybe a
Just (ServerPassword -> IO (Maybe ServerPassword))
-> ServerPassword -> IO (Maybe ServerPassword)
forall a b. (a -> b) -> a -> b
$ BasicAuth -> ServerPassword
ServerPassword BasicAuth
auth
                Either String BasicAuth
_ -> String -> IO ()
putStrLn String
"Invalid password. Only latin letters, digits and symbols other than '@' and ':' are allowed" IO () -> IO (Maybe ServerPassword) -> IO (Maybe ServerPassword)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe ServerPassword)
serverPassword
        checkInitOptions :: InitOptions -> IO ()
checkInitOptions InitOptions {Maybe Text
$sel:sourceCode:InitOptions :: InitOptions -> Maybe Text
sourceCode :: Maybe Text
sourceCode, ServerPublicInfo
serverInfo :: ServerPublicInfo
$sel:serverInfo:InitOptions :: InitOptions -> ServerPublicInfo
serverInfo, Maybe Text
operatorCountry :: Maybe Text
$sel:operatorCountry:InitOptions :: InitOptions -> Maybe Text
operatorCountry, Maybe Text
hostingCountry :: Maybe Text
$sel:hostingCountry:InitOptions :: InitOptions -> Maybe Text
hostingCountry} = do
          let err_ :: Maybe String
err_
                | Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
sourceCode Bool -> Bool -> Bool
&& ServerPublicInfo -> Bool
hasServerInfo ServerPublicInfo
serverInfo =
                    String -> Maybe String
forall a. a -> Maybe a
Just String
"Error: passing any server information requires passing --source-code"
                | Maybe Entity -> Bool
forall a. Maybe a -> Bool
isNothing (ServerPublicInfo -> Maybe Entity
operator ServerPublicInfo
serverInfo) Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
operatorCountry =
                    String -> Maybe String
forall a. a -> Maybe a
Just String
"Error: passing --operator-country requires passing --operator"
                | Maybe Entity -> Bool
forall a. Maybe a -> Bool
isNothing (ServerPublicInfo -> Maybe Entity
hosting ServerPublicInfo
serverInfo) Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
hostingCountry =
                    String -> Maybe String
forall a. a -> Maybe a
Just String
"Error: passing --hosting-country requires passing --hosting"
                | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing
          Maybe String -> (String -> IO Any) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
err_ ((String -> IO Any) -> IO ()) -> (String -> IO Any) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
err -> String -> IO ()
putStrLn String
err IO () -> IO Any -> IO Any
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Any
forall a. IO a
exitFailure
        initialize :: InitOptions -> IO ()
initialize opts' :: InitOptions
opts'@InitOptions {String
$sel:ip:InitOptions :: InitOptions -> String
ip :: String
ip, Maybe String
$sel:fqdn:InitOptions :: InitOptions -> Maybe String
fqdn :: Maybe String
fqdn, SignAlgorithm
signAlgorithm :: SignAlgorithm
$sel:signAlgorithm:InitOptions :: InitOptions -> SignAlgorithm
signAlgorithm, Maybe ServerPassword
$sel:password:InitOptions :: InitOptions -> Maybe ServerPassword
password :: Maybe ServerPassword
password, Maybe Int
controlPort :: Maybe Int
$sel:controlPort:InitOptions :: InitOptions -> Maybe Int
controlPort, Maybe Text
$sel:sourceCode:InitOptions :: InitOptions -> Maybe Text
sourceCode :: Maybe Text
sourceCode} = do
          InitOptions -> IO ()
checkInitOptions InitOptions
opts'
          String -> IO ()
clearDirIfExists String
cfgPath
          String -> IO ()
clearDirIfExists String
logPath
          Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cfgPath
          Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
logPath
          let x509cfg :: X509Config
x509cfg = X509Config
defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm}
          ByteString
fp <- String -> X509Config -> IO ByteString
createServerX509 String
cfgPath X509Config
x509cfg
          Maybe BasicAuth
basicAuth <- (ServerPassword -> IO BasicAuth)
-> Maybe ServerPassword -> IO (Maybe BasicAuth)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ServerPassword -> IO BasicAuth
createServerPassword Maybe ServerPassword
password
          Maybe (Text, Text)
controlPortPwds <- Maybe Int -> (Int -> IO (Text, Text)) -> IO (Maybe (Text, Text))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Int
controlPort ((Int -> IO (Text, Text)) -> IO (Maybe (Text, Text)))
-> (Int -> IO (Text, Text)) -> IO (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ \Int
_ -> let pwd :: IO Text
pwd = ByteString -> Text
decodeLatin1 (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
randomBase64 Int
18 in (,) (Text -> Text -> (Text, Text))
-> IO Text -> IO (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
pwd IO (Text -> (Text, Text)) -> IO Text -> IO (Text, Text)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Text
pwd
          let host :: String
host = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (if String
ip String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"127.0.0.1" then String
"<hostnames>" else String
ip) Maybe String
fqdn
              srv :: ProtoServerWithAuth 'PSMP
srv = ProtocolServer 'PSMP
-> Maybe BasicAuth -> ProtoServerWithAuth 'PSMP
forall (p :: ProtocolType).
ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
ProtoServerWithAuth (NonEmpty TransportHost -> String -> KeyHash -> ProtocolServer 'PSMP
SMPServer [String -> TransportHost
THDomainName String
host] String
"" (ByteString -> KeyHash
C.KeyHash ByteString
fp)) Maybe BasicAuth
basicAuth
          String -> Text -> IO ()
T.writeFile String
iniFile (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String
-> String
-> InitOptions
-> String
-> Maybe BasicAuth
-> Maybe (Text, Text)
-> Text
iniFileContent String
cfgPath String
logPath InitOptions
opts' String
host Maybe BasicAuth
basicAuth Maybe (Text, Text)
controlPortPwds
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Server initialized, please provide additional server information in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
iniFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Run `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
executableName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" start` to start server."
          String -> X509Config -> IO ()
warnCAPrivateKeyFile String
cfgPath X509Config
x509cfg
          String -> ProtoServerWithAuth 'PSMP -> IO ()
forall (p :: ProtocolType).
ProtocolTypeI p =>
String -> ProtoServerWithAuth p -> IO ()
printServiceInfo String
serverVersion ProtoServerWithAuth 'PSMP
srv
          Maybe Text -> IO ()
printSourceCode Maybe Text
sourceCode
          where
            createServerPassword :: ServerPassword -> IO BasicAuth
createServerPassword = \case
              ServerPassword BasicAuth
s -> BasicAuth -> IO BasicAuth
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BasicAuth
s
              ServerPassword
SPRandom -> ByteString -> BasicAuth
BasicAuth (ByteString -> BasicAuth) -> IO ByteString -> IO BasicAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
randomBase64 Int
32
            randomBase64 :: Int -> IO ByteString
randomBase64 Int
n = ByteString -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (STM ByteString -> IO ByteString
forall a. STM a -> IO a
atomically (STM ByteString -> IO ByteString)
-> (TVar ChaChaDRG -> STM ByteString)
-> TVar ChaChaDRG
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TVar ChaChaDRG -> STM ByteString
C.randomBytes Int
n (TVar ChaChaDRG -> IO ByteString)
-> IO (TVar ChaChaDRG) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (TVar ChaChaDRG)
C.newRandom)
    runServer :: StartOptions -> Ini -> IO ()
runServer StartOptions
startOptions Ini
ini = do
      LogLevel -> IO ()
setLogLevel (LogLevel -> IO ()) -> LogLevel -> IO ()
forall a b. (a -> b) -> a -> b
$ StartOptions -> LogLevel
logLevel StartOptions
startOptions
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
      AStoreType -> IO ()
run AStoreType
iniStoreType
      where
        run :: AStoreType -> IO ()
        run :: AStoreType -> IO ()
run (ASType SQSType qs
qs SMSType ms
ms) = do
          ByteString
fp <- String -> X509Config -> IO ByteString
checkSavedFingerprint String
cfgPath X509Config
defaultX509Config
          let host :: String
host = (String -> String)
-> (Text -> String) -> Either String Text -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> String -> String
forall a b. a -> b -> a
const String
"<hostnames>") Text -> String
T.unpack (Either String Text -> String) -> Either String Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Either String Text
lookupValue Text
"TRANSPORT" Text
"host" Ini
ini
              port :: String
port = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Text
strictIni Text
"TRANSPORT" Text
"port" Ini
ini
              serverStoreCfg :: ServerStoreCfg (MsgStoreType qs ms)
serverStoreCfg = SQSType qs -> SMSType ms -> ServerStoreCfg (MsgStoreType qs ms)
forall (qs :: QSType) (ms :: MSType).
SupportedStore qs ms =>
SQSType qs -> SMSType ms -> ServerStoreCfg (MsgStoreType qs ms)
iniStoreCfg SQSType qs
qs SMSType ms
ms
              cfg :: ServerConfig (MsgStoreType qs ms)
cfg@ServerConfig {Maybe ServerPublicInfo
information :: Maybe ServerPublicInfo
$sel:information:ServerConfig :: forall s. ServerConfig s -> Maybe ServerPublicInfo
information, Maybe BasicAuth
newQueueBasicAuth :: Maybe BasicAuth
$sel:newQueueBasicAuth:ServerConfig :: forall s. ServerConfig s -> Maybe BasicAuth
newQueueBasicAuth, Maybe ExpirationConfig
messageExpiration :: Maybe ExpirationConfig
$sel:messageExpiration:ServerConfig :: forall s. ServerConfig s -> Maybe ExpirationConfig
messageExpiration, Maybe ExpirationConfig
inactiveClientExpiration :: Maybe ExpirationConfig
$sel:inactiveClientExpiration:ServerConfig :: forall s. ServerConfig s -> Maybe ExpirationConfig
inactiveClientExpiration} = ServerStoreCfg (MsgStoreType qs ms)
-> ServerConfig (MsgStoreType qs ms)
forall s. ServerStoreCfg s -> ServerConfig s
serverConfig ServerStoreCfg (MsgStoreType qs ms)
serverStoreCfg
              sourceCode' :: Maybe Text
sourceCode' = (\ServerPublicInfo {Text
sourceCode :: Text
$sel:sourceCode:ServerPublicInfo :: ServerPublicInfo -> Text
sourceCode} -> Text
sourceCode) (ServerPublicInfo -> Text) -> Maybe ServerPublicInfo -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ServerPublicInfo
information
              srv :: ProtoServerWithAuth 'PSMP
srv = ProtocolServer 'PSMP
-> Maybe BasicAuth -> ProtoServerWithAuth 'PSMP
forall (p :: ProtocolType).
ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
ProtoServerWithAuth (NonEmpty TransportHost -> String -> KeyHash -> ProtocolServer 'PSMP
SMPServer [String -> TransportHost
THDomainName String
host] (if String
port String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"5223" then String
"" else String
port) (ByteString -> KeyHash
C.KeyHash ByteString
fp)) Maybe BasicAuth
newQueueBasicAuth
          String -> ProtoServerWithAuth 'PSMP -> IO ()
forall (p :: ProtocolType).
ProtocolTypeI p =>
String -> ProtoServerWithAuth p -> IO ()
printServiceInfo String
serverVersion ProtoServerWithAuth 'PSMP
srv
          Maybe Text -> IO ()
printSourceCode Maybe Text
sourceCode'
          [(String, ASrvTransport, Bool)]
-> ServerStoreCfg (MsgStoreType qs ms) -> IO ()
forall s.
[(String, ASrvTransport, Bool)] -> ServerStoreCfg s -> IO ()
printSMPServerConfig [(String, ASrvTransport, Bool)]
transports ServerStoreCfg (MsgStoreType qs ms)
serverStoreCfg
          Ini -> AStoreType -> IO ()
checkMsgStoreMode Ini
ini AStoreType
iniStoreType
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe ExpirationConfig
messageExpiration of
            Just ExpirationConfig {Int64
ttl :: Int64
ttl :: ExpirationConfig -> Int64
ttl} -> String
"expiring messages after " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
showTTL Int64
ttl
            Maybe ExpirationConfig
_ -> String
"not expiring messages"
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe ExpirationConfig
inactiveClientExpiration of
            Just ExpirationConfig {Int64
ttl :: ExpirationConfig -> Int64
ttl :: Int64
ttl, Int64
checkInterval :: Int64
checkInterval :: ExpirationConfig -> Int64
checkInterval} -> String
"expiring clients inactive for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show Int64
ttl String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" seconds every " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show Int64
checkInterval String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" seconds"
            Maybe ExpirationConfig
_ -> String
"not expiring inactive clients"
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"creating new queues "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> if ServerConfig (MsgStoreType qs ms) -> Bool
forall s. ServerConfig s -> Bool
allowNewQueues ServerConfig (MsgStoreType qs ms)
cfg
                then String -> (BasicAuth -> String) -> Maybe BasicAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"allowed" (String -> BasicAuth -> String
forall a b. a -> b -> a
const String
"requires password") Maybe BasicAuth
newQueueBasicAuth
                else String
"NOT allowed"
          -- print information
          let persistence :: ServerPersistenceMode
persistence = case ServerStoreCfg (MsgStoreType qs ms)
serverStoreCfg of
                SSCMemory Maybe StorePaths
Nothing -> ServerPersistenceMode
SPMMemoryOnly
                SSCMemory (Just StorePaths {Maybe String
storeMsgsFile :: Maybe String
$sel:storeMsgsFile:StorePaths :: StorePaths -> Maybe String
storeMsgsFile}) | Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
storeMsgsFile -> ServerPersistenceMode
SPMQueues
                ServerStoreCfg (MsgStoreType qs ms)
_ -> ServerPersistenceMode
SPMMessages
          let config :: ServerPublicConfig
config =
                ServerPublicConfig
                  { ServerPersistenceMode
persistence :: ServerPersistenceMode
$sel:persistence:ServerPublicConfig :: ServerPersistenceMode
persistence,
                    $sel:messageExpiration:ServerPublicConfig :: Maybe Int64
messageExpiration = ExpirationConfig -> Int64
ttl (ExpirationConfig -> Int64)
-> Maybe ExpirationConfig -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ExpirationConfig
messageExpiration,
                    $sel:statsEnabled:ServerPublicConfig :: Bool
statsEnabled = Maybe () -> Bool
forall a. Maybe a -> Bool
isJust Maybe ()
logStats,
                    $sel:newQueuesAllowed:ServerPublicConfig :: Bool
newQueuesAllowed = ServerConfig (MsgStoreType qs ms) -> Bool
forall s. ServerConfig s -> Bool
allowNewQueues ServerConfig (MsgStoreType qs ms)
cfg,
                    $sel:basicAuthEnabled:ServerPublicConfig :: Bool
basicAuthEnabled = Maybe BasicAuth -> Bool
forall a. Maybe a -> Bool
isJust Maybe BasicAuth
newQueueBasicAuth
                  }
          case Maybe String
webStaticPath' of
            Just String
path | Bool
sharedHTTP -> do
              String -> Maybe WebHttpsParams -> ServerInformation -> IO ()
runWebServer String
path Maybe WebHttpsParams
forall a. Maybe a
Nothing ServerInformation {ServerPublicConfig
config :: ServerPublicConfig
$sel:config:ServerInformation :: ServerPublicConfig
config, Maybe ServerPublicInfo
information :: Maybe ServerPublicInfo
$sel:information:ServerInformation :: Maybe ServerPublicInfo
information}
              String -> (AttachHTTP -> IO ()) -> IO ()
attachStaticFiles String
path ((AttachHTTP -> IO ()) -> IO ()) -> (AttachHTTP -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AttachHTTP
attachHTTP -> do
                Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logDebug Text
"Allocated web server resources"
                ServerConfig (MsgStoreType qs ms) -> Maybe AttachHTTP -> IO ()
forall s.
MsgStoreClass s =>
ServerConfig s -> Maybe AttachHTTP -> IO ()
runSMPServer ServerConfig (MsgStoreType qs ms)
cfg (AttachHTTP -> Maybe AttachHTTP
forall a. a -> Maybe a
Just AttachHTTP
attachHTTP) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logDebug Text
"Releasing web server resources..."
            Just String
path -> do
              String -> Maybe WebHttpsParams -> ServerInformation -> IO ()
runWebServer String
path Maybe WebHttpsParams
webHttpsParams' ServerInformation {ServerPublicConfig
config :: ServerPublicConfig
$sel:config:ServerInformation :: ServerPublicConfig
config, Maybe ServerPublicInfo
information :: Maybe ServerPublicInfo
$sel:information:ServerInformation :: Maybe ServerPublicInfo
information}
              ServerConfig (MsgStoreType qs ms) -> Maybe AttachHTTP -> IO ()
forall s.
MsgStoreClass s =>
ServerConfig s -> Maybe AttachHTTP -> IO ()
runSMPServer ServerConfig (MsgStoreType qs ms)
cfg Maybe AttachHTTP
forall a. Maybe a
Nothing
            Maybe String
Nothing -> do
              Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logWarn Text
"No server static path set"
              ServerConfig (MsgStoreType qs ms) -> Maybe AttachHTTP -> IO ()
forall s.
MsgStoreClass s =>
ServerConfig s -> Maybe AttachHTTP -> IO ()
runSMPServer ServerConfig (MsgStoreType qs ms)
cfg Maybe AttachHTTP
forall a. Maybe a
Nothing
          Text -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logDebug Text
"Bye"
        logStats :: Maybe ()
logStats = Text -> Text -> Ini -> Maybe ()
settingIsOn Text
"STORE_LOG" Text
"log_stats" Ini
ini
        c :: (X509Config -> String) -> String
c = String -> String -> String
combine String
cfgPath (String -> String)
-> ((X509Config -> String) -> String)
-> (X509Config -> String)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((X509Config -> String) -> X509Config -> String
forall a b. (a -> b) -> a -> b
$ X509Config
defaultX509Config)
        restoreMessagesFile :: String -> Maybe String
restoreMessagesFile String
path = case Text -> Text -> Ini -> Maybe Bool
iniOnOff Text
"STORE_LOG" Text
"restore_messages" Ini
ini of
          Just Bool
True -> String -> Maybe String
forall a. a -> Maybe a
Just String
path
          Just Bool
False -> Maybe String
forall a. Maybe a
Nothing
          -- if the setting is not set, it is enabled when store log is enabled
          Maybe Bool
_ -> Ini -> Maybe ()
enableStoreLog' Ini
ini Maybe () -> String -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String
path
        transports :: [(String, ASrvTransport, Bool)]
transports = Ini -> [(String, ASrvTransport, Bool)]
iniTransports Ini
ini
        sharedHTTP :: Bool
sharedHTTP = ((String, ASrvTransport, Bool) -> Bool)
-> [(String, ASrvTransport, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(String
_, ASrvTransport
_, Bool
addHTTP) -> Bool
addHTTP) [(String, ASrvTransport, Bool)]
transports
        iniStoreType :: AStoreType
iniStoreType = (String -> AStoreType)
-> (AStoreType -> AStoreType)
-> Either String AStoreType
-> AStoreType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> AStoreType
forall a. HasCallStack => String -> a
error AStoreType -> AStoreType
forall a. a -> a
id (Either String AStoreType -> AStoreType)
-> Either String AStoreType -> AStoreType
forall a b. (a -> b) -> a -> b
$! Ini -> Either String AStoreType
readStoreType Ini
ini
        iniStoreCfg :: SupportedStore qs ms => SQSType qs -> SMSType ms -> ServerStoreCfg (MsgStoreType qs ms)
        iniStoreCfg :: forall (qs :: QSType) (ms :: MSType).
SupportedStore qs ms =>
SQSType qs -> SMSType ms -> ServerStoreCfg (MsgStoreType qs ms)
iniStoreCfg SQSType qs
SQSMemory SMSType ms
SMSMemory = Maybe StorePaths -> ServerStoreCfg STMMsgStore
SSCMemory (Maybe StorePaths -> ServerStoreCfg STMMsgStore)
-> Maybe StorePaths -> ServerStoreCfg STMMsgStore
forall a b. (a -> b) -> a -> b
$ Ini -> Maybe ()
enableStoreLog' Ini
ini Maybe () -> StorePaths -> Maybe StorePaths
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StorePaths {$sel:storeLogFile:StorePaths :: String
storeLogFile = String
storeLogFilePath, $sel:storeMsgsFile:StorePaths :: Maybe String
storeMsgsFile = String -> Maybe String
restoreMessagesFile String
storeMsgsFilePath}
        iniStoreCfg SQSType qs
SQSMemory SMSType ms
SMSJournal = SSCMemoryJournal {$sel:storeLogFile:SSCMemory :: String
storeLogFile = String
storeLogFilePath, $sel:storeMsgsPath:SSCMemory :: String
storeMsgsPath = String
storeMsgsJournalDir}
        iniStoreCfg SQSType qs
SQSPostgres SMSType ms
SMSJournal =
          let dbStoreLogPath :: Maybe String
dbStoreLogPath = Ini -> Maybe ()
enableDbStoreLog' Ini
ini Maybe () -> String -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String
storeLogFilePath
              storeCfg :: PostgresStoreCfg
storeCfg = PostgresStoreCfg {dbOpts :: DBOpts
dbOpts = Ini -> DBOpts -> DBOpts
iniDBOptions Ini
ini DBOpts
defaultDBOpts, Maybe String
dbStoreLogPath :: Maybe String
dbStoreLogPath :: Maybe String
dbStoreLogPath, confirmMigrations :: MigrationConfirmation
confirmMigrations = MigrationConfirmation
MCYesUp, deletedTTL :: Int64
deletedTTL = Ini -> Int64
iniDeletedTTL Ini
ini}
           in SSCDatabaseJournal {PostgresStoreCfg
storeCfg :: PostgresStoreCfg
$sel:storeCfg:SSCMemory :: PostgresStoreCfg
storeCfg, $sel:storeMsgsPath':SSCMemory :: String
storeMsgsPath' = String
storeMsgsJournalDir}
#if defined(dbServerPostgres)
        iniStoreCfg SQSPostgres SMSPostgres =
          let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
              storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
           in SSCDatabase storeCfg
#endif
        serverConfig :: ServerStoreCfg s -> ServerConfig s
        serverConfig :: forall s. ServerStoreCfg s -> ServerConfig s
serverConfig ServerStoreCfg s
serverStoreCfg =
          ServerConfig
            { [(String, ASrvTransport, Bool)]
transports :: [(String, ASrvTransport, Bool)]
$sel:transports:ServerConfig :: [(String, ASrvTransport, Bool)]
transports,
              $sel:smpHandshakeTimeout:ServerConfig :: Int
smpHandshakeTimeout = Int
120000000,
              $sel:tbqSize:ServerConfig :: Natural
tbqSize = Natural
128,
              $sel:msgQueueQuota:ServerConfig :: Int
msgQueueQuota = Int
defaultMsgQueueQuota,
              $sel:maxJournalMsgCount:ServerConfig :: Int
maxJournalMsgCount = Int
defaultMaxJournalMsgCount,
              $sel:maxJournalStateLines:ServerConfig :: Int
maxJournalStateLines = Int
defaultMaxJournalStateLines,
              $sel:queueIdBytes:ServerConfig :: Int
queueIdBytes = Int
24,
              $sel:msgIdBytes:ServerConfig :: Int
msgIdBytes = Int
24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
              $sel:smpCredentials:ServerConfig :: ServerCredentials
smpCredentials =
                ServerCredentials
                  { $sel:caCertificateFile:ServerCredentials :: Maybe String
caCertificateFile = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (X509Config -> String) -> String
c X509Config -> String
caCrtFile,
                    $sel:privateKeyFile:ServerCredentials :: String
privateKeyFile = (X509Config -> String) -> String
c X509Config -> String
serverKeyFile,
                    $sel:certificateFile:ServerCredentials :: String
certificateFile = (X509Config -> String) -> String
c X509Config -> String
serverCrtFile
                  },
              $sel:httpCredentials:ServerConfig :: Maybe ServerCredentials
httpCredentials = (\WebHttpsParams {String
key :: String
key :: WebHttpsParams -> String
key, String
cert :: String
cert :: WebHttpsParams -> String
cert} -> ServerCredentials {$sel:caCertificateFile:ServerCredentials :: Maybe String
caCertificateFile = Maybe String
forall a. Maybe a
Nothing, $sel:privateKeyFile:ServerCredentials :: String
privateKeyFile = String
key, $sel:certificateFile:ServerCredentials :: String
certificateFile = String
cert}) (WebHttpsParams -> ServerCredentials)
-> Maybe WebHttpsParams -> Maybe ServerCredentials
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe WebHttpsParams
webHttpsParams',
              ServerStoreCfg s
serverStoreCfg :: ServerStoreCfg s
$sel:serverStoreCfg:ServerConfig :: ServerStoreCfg s
serverStoreCfg,
              $sel:storeNtfsFile:ServerConfig :: Maybe String
storeNtfsFile = String -> Maybe String
restoreMessagesFile String
storeNtfsFilePath,
              -- allow creating new queues by default
              $sel:allowNewQueues:ServerConfig :: Bool
allowNewQueues = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Maybe Bool
iniOnOff Text
"AUTH" Text
"new_queues" Ini
ini,
              $sel:newQueueBasicAuth:ServerConfig :: Maybe BasicAuth
newQueueBasicAuth = (String -> BasicAuth)
-> (BasicAuth -> BasicAuth) -> Either String BasicAuth -> BasicAuth
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> BasicAuth
forall a. HasCallStack => String -> a
error BasicAuth -> BasicAuth
forall a. a -> a
id (Either String BasicAuth -> BasicAuth)
-> Maybe (Either String BasicAuth) -> Maybe BasicAuth
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Text -> Text -> Ini -> Maybe (Either String BasicAuth)
forall a.
StrEncoding a =>
Text -> Text -> Ini -> Maybe (Either String a)
strDecodeIni Text
"AUTH" Text
"create_password" Ini
ini,
              $sel:controlPortAdminAuth:ServerConfig :: Maybe BasicAuth
controlPortAdminAuth = (String -> BasicAuth)
-> (BasicAuth -> BasicAuth) -> Either String BasicAuth -> BasicAuth
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> BasicAuth
forall a. HasCallStack => String -> a
error BasicAuth -> BasicAuth
forall a. a -> a
id (Either String BasicAuth -> BasicAuth)
-> Maybe (Either String BasicAuth) -> Maybe BasicAuth
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Text -> Text -> Ini -> Maybe (Either String BasicAuth)
forall a.
StrEncoding a =>
Text -> Text -> Ini -> Maybe (Either String a)
strDecodeIni Text
"AUTH" Text
"control_port_admin_password" Ini
ini,
              $sel:controlPortUserAuth:ServerConfig :: Maybe BasicAuth
controlPortUserAuth = (String -> BasicAuth)
-> (BasicAuth -> BasicAuth) -> Either String BasicAuth -> BasicAuth
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> BasicAuth
forall a. HasCallStack => String -> a
error BasicAuth -> BasicAuth
forall a. a -> a
id (Either String BasicAuth -> BasicAuth)
-> Maybe (Either String BasicAuth) -> Maybe BasicAuth
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Text -> Text -> Ini -> Maybe (Either String BasicAuth)
forall a.
StrEncoding a =>
Text -> Text -> Ini -> Maybe (Either String a)
strDecodeIni Text
"AUTH" Text
"control_port_user_password" Ini
ini,
              $sel:dailyBlockQueueQuota:ServerConfig :: Int
dailyBlockQueueQuota = Int -> Text -> Text -> Ini -> Int
forall a. Read a => a -> Text -> Text -> Ini -> a
readIniDefault Int
20 Text
"AUTH" Text
"daily_block_queue_quota" Ini
ini,
              $sel:messageExpiration:ServerConfig :: Maybe ExpirationConfig
messageExpiration =
                ExpirationConfig -> Maybe ExpirationConfig
forall a. a -> Maybe a
Just
                  ExpirationConfig
defaultMessageExpiration
                    { ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
                    },
              $sel:expireMessagesOnStart:ServerConfig :: Bool
expireMessagesOnStart = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Maybe Bool
iniOnOff Text
"STORE_LOG" Text
"expire_messages_on_start" Ini
ini,
              $sel:expireMessagesOnSend:ServerConfig :: Bool
expireMessagesOnSend = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Maybe Bool
iniOnOff Text
"STORE_LOG" Text
"expire_messages_on_send" Ini
ini,
              $sel:idleQueueInterval:ServerConfig :: Int64
idleQueueInterval = Int64
defaultIdleQueueInterval,
              $sel:notificationExpiration:ServerConfig :: ExpirationConfig
notificationExpiration =
                ExpirationConfig
defaultNtfExpiration
                  { ttl = 3600 * readIniDefault defNtfExpirationHours "STORE_LOG" "expire_ntfs_hours" ini
                  },
              $sel:inactiveClientExpiration:ServerConfig :: Maybe ExpirationConfig
inactiveClientExpiration =
                Text -> Text -> Ini -> Maybe ()
settingIsOn Text
"INACTIVE_CLIENTS" Text
"disconnect" Ini
ini
                  Maybe () -> ExpirationConfig -> Maybe ExpirationConfig
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ExpirationConfig
                    { ttl :: Int64
ttl = Text -> Text -> Ini -> Int64
forall a. Read a => Text -> Text -> Ini -> a
readStrictIni Text
"INACTIVE_CLIENTS" Text
"ttl" Ini
ini,
                      checkInterval :: Int64
checkInterval = Text -> Text -> Ini -> Int64
forall a. Read a => Text -> Text -> Ini -> a
readStrictIni Text
"INACTIVE_CLIENTS" Text
"check_interval" Ini
ini
                    },
              $sel:logStatsInterval:ServerConfig :: Maybe Int64
logStatsInterval = Maybe ()
logStats Maybe () -> Int64 -> Maybe Int64
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int64
86400, -- seconds
              $sel:logStatsStartTime:ServerConfig :: Int64
logStatsStartTime = Int64
0, -- seconds from 00:00 UTC
              $sel:serverStatsLogFile:ServerConfig :: String
serverStatsLogFile = String -> String -> String
combine String
logPath String
"smp-server-stats.daily.log",
              $sel:serverStatsBackupFile:ServerConfig :: Maybe String
serverStatsBackupFile = Maybe ()
logStats Maybe () -> String -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String -> String -> String
combine String
logPath String
"smp-server-stats.log",
              $sel:prometheusInterval:ServerConfig :: Maybe Int
prometheusInterval = Either String Text -> Maybe Text
forall a b. Either a b -> Maybe b
eitherToMaybe (Text -> Text -> Ini -> Either String Text
lookupValue Text
"STORE_LOG" Text
"prometheus_interval" Ini
ini) Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack,
              $sel:prometheusMetricsFile:ServerConfig :: String
prometheusMetricsFile = String -> String -> String
combine String
logPath String
"smp-server-metrics.txt",
              $sel:pendingENDInterval:ServerConfig :: Int
pendingENDInterval = Int
15000000, -- 15 seconds
              $sel:ntfDeliveryInterval:ServerConfig :: Int
ntfDeliveryInterval = Int
1500000, -- 1.5 second
              $sel:smpServerVRange:ServerConfig :: VersionRangeSMP
smpServerVRange = VersionRangeSMP
supportedServerSMPRelayVRange,
              $sel:transportConfig:ServerConfig :: TransportServerConfig
transportConfig =
                Bool -> Maybe [ByteString] -> Bool -> TransportServerConfig
mkTransportServerConfig
                  (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Maybe Bool
iniOnOff Text
"TRANSPORT" Text
"log_tls_errors" Ini
ini)
                  ([ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
Just ([ByteString] -> Maybe [ByteString])
-> [ByteString] -> Maybe [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString]
alpnSupportedSMPHandshakes [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
httpALPN)
                  (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Maybe Bool
iniOnOff Text
"TRANSPORT" Text
"accept_service_credentials" Ini
ini), -- TODO [certs] remove this option
              $sel:controlPort:ServerConfig :: Maybe String
controlPort = Either String String -> Maybe String
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String String -> Maybe String)
-> Either String String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Either String Text -> Either String String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Ini -> Either String Text
lookupValue Text
"TRANSPORT" Text
"control_port" Ini
ini,
              $sel:smpAgentCfg:ServerConfig :: SMPClientAgentConfig
smpAgentCfg =
                SMPClientAgentConfig
defaultSMPClientAgentConfig
                  { smpCfg =
                      (smpCfg defaultSMPClientAgentConfig)
                        { serverVRange = supportedProxyClientSMPRelayVRange,
                          agreeSecret = True,
                          proxyServer = True,
                          networkConfig =
                            defaultNetworkConfig
                              { socksProxy = either error id <$!> strDecodeIni "PROXY" "socks_proxy" ini,
                                socksMode = maybe SMOnion (either error id) $! strDecodeIni "PROXY" "socks_mode" ini,
                                hostMode = either (const HMPublic) (either error id . textToHostMode) $ lookupValue "PROXY" "host_mode" ini,
                                requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini,
                                smpWebPortServers = SWPOff
                              }
                        },
                    ownServerDomains = either (const []) textToOwnServers $ lookupValue "PROXY" "own_server_domains" ini,
                    persistErrorInterval = 30 -- seconds
                  },
              $sel:allowSMPProxy:ServerConfig :: Bool
allowSMPProxy = Bool
True,
              $sel:serverClientConcurrency:ServerConfig :: Int
serverClientConcurrency = Int -> Text -> Text -> Ini -> Int
forall a. Read a => a -> Text -> Text -> Ini -> a
readIniDefault Int
defaultProxyClientConcurrency Text
"PROXY" Text
"client_concurrency" Ini
ini,
              $sel:information:ServerConfig :: Maybe ServerPublicInfo
information = Ini -> Maybe ServerPublicInfo
serverPublicInfo Ini
ini,
              StartOptions
startOptions :: StartOptions
$sel:startOptions:ServerConfig :: StartOptions
startOptions
            }
        textToOwnServers :: Text -> [ByteString]
        textToOwnServers :: Text -> [ByteString]
textToOwnServers = (Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 ([Text] -> [ByteString])
-> (Text -> [Text]) -> Text -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words
        runWebServer :: String -> Maybe WebHttpsParams -> ServerInformation -> IO ()
runWebServer String
webStaticPath Maybe WebHttpsParams
webHttpsParams ServerInformation
si = do
          let onionHost :: Maybe TransportHost
onionHost =
                (String -> Maybe TransportHost)
-> (NonEmpty TransportHost -> Maybe TransportHost)
-> Either String (NonEmpty TransportHost)
-> Maybe TransportHost
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe TransportHost -> String -> Maybe TransportHost
forall a b. a -> b -> a
const Maybe TransportHost
forall a. Maybe a
Nothing) ((TransportHost -> Bool)
-> NonEmpty TransportHost -> Maybe TransportHost
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find TransportHost -> Bool
isOnion) (Either String (NonEmpty TransportHost) -> Maybe TransportHost)
-> Either String (NonEmpty TransportHost) -> Maybe TransportHost
forall a b. (a -> b) -> a -> b
$
                  forall a. StrEncoding a => ByteString -> Either String a
strDecode @(L.NonEmpty TransportHost) (ByteString -> Either String (NonEmpty TransportHost))
-> (Text -> ByteString)
-> Text
-> Either String (NonEmpty TransportHost)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> Either String (NonEmpty TransportHost))
-> Either String Text -> Either String (NonEmpty TransportHost)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Text -> Ini -> Either String Text
lookupValue Text
"TRANSPORT" Text
"host" Ini
ini
              webHttpPort :: Maybe Int
webHttpPort = Either String Text -> Maybe Text
forall a b. Either a b -> Maybe b
eitherToMaybe (Text -> Text -> Ini -> Either String Text
lookupValue Text
"WEB" Text
"http" Ini
ini) Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
          ServerInformation -> Maybe TransportHost -> String -> IO ()
generateSite ServerInformation
si Maybe TransportHost
onionHost String
webStaticPath
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
webHttpPort Bool -> Bool -> Bool
|| Maybe WebHttpsParams -> Bool
forall a. Maybe a -> Bool
isJust Maybe WebHttpsParams
webHttpsParams) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            EmbeddedWebParams -> IO ()
serveStaticFiles EmbeddedWebParams {String
webStaticPath :: String
webStaticPath :: String
webStaticPath, Maybe Int
webHttpPort :: Maybe Int
webHttpPort :: Maybe Int
webHttpPort, Maybe WebHttpsParams
webHttpsParams :: Maybe WebHttpsParams
webHttpsParams :: Maybe WebHttpsParams
webHttpsParams}
          where
            isOnion :: TransportHost -> Bool
isOnion = \case THOnionHost ByteString
_ -> Bool
True; TransportHost
_ -> Bool
False
        webHttpsParams' :: Maybe WebHttpsParams
webHttpsParams' = do
          Int
port <- Either String Text -> Maybe Text
forall a b. Either a b -> Maybe b
eitherToMaybe (Text -> Text -> Ini -> Either String Text
lookupValue Text
"WEB" Text
"https" Ini
ini) Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
          String
cert <- Either String String -> Maybe String
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String String -> Maybe String)
-> Either String String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Either String Text -> Either String String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Ini -> Either String Text
lookupValue Text
"WEB" Text
"cert" Ini
ini
          String
key <- Either String String -> Maybe String
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String String -> Maybe String)
-> Either String String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Either String Text -> Either String String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Ini -> Either String Text
lookupValue Text
"WEB" Text
"key" Ini
ini
          pure WebHttpsParams {Int
port :: Int
port :: Int
port, String
cert :: String
cert :: String
cert, String
key :: String
key :: String
key}
        webStaticPath' :: Maybe String
webStaticPath' = Either String String -> Maybe String
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String String -> Maybe String)
-> Either String String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Either String Text -> Either String String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Ini -> Either String Text
lookupValue Text
"WEB" Text
"static_path" Ini
ini

    checkMsgStoreMode :: Ini -> AStoreType -> IO ()
    checkMsgStoreMode :: Ini -> AStoreType -> IO ()
checkMsgStoreMode Ini
ini AStoreType
mode = do
      Bool
msgsDirExists <- String -> IO Bool
doesDirectoryExist String
storeMsgsJournalDir
      Bool
msgsFileExists <- String -> IO Bool
doesFileExist String
storeMsgsFilePath
      Bool
storeLogExists <- String -> IO Bool
doesFileExist String
storeLogFilePath
      case AStoreType
mode of
#if defined(dbServerPostgres)
        ASType SQSPostgres SMSPostgres
          | msgsFileExists || msgsDirExists -> do
              putStrLn $ "Error: " <> storeMsgsFilePath <> " file or " <> storeMsgsJournalDir <> " directory are present."
              putStrLn "Configure memory storage."
              exitFailure
          | otherwise -> checkDbStorage ini storeLogExists
#endif
        ASType SQSType qs
qs SMSType ms
SMSJournal
          | Bool
msgsFileExists Bool -> Bool -> Bool
&& Bool
msgsDirExists -> IO ()
exitConfigureMsgStorage
          | Bool
msgsFileExists -> do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error: store_messages is `journal` with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsFilePath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" file present."
              String -> IO ()
putStrLn String
"Set store_messages to `memory` or use `smp-server journal export` to migrate."
              IO ()
forall a. IO a
exitFailure
          | Bool -> Bool
not Bool
msgsDirExists ->
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"store_messages is `journal`, " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsJournalDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" directory will be created."
          | Bool
otherwise -> case SQSType qs
qs of
              SQSType qs
SQSMemory ->
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
storeLogExists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"store_queues is `memory`, " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeLogFilePath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" file will be created."
#if defined(dbServerPostgres)
              SQSPostgres -> checkDbStorage ini storeLogExists
#else
              SQSType qs
SQSPostgres -> IO ()
forall a. IO a
noPostgresExit
#endif
        ASType SQSType qs
SQSMemory SMSType ms
SMSMemory
          | Bool
msgsFileExists Bool -> Bool -> Bool
&& Bool
msgsDirExists -> IO ()
exitConfigureMsgStorage
          | Bool
msgsDirExists -> do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error: store_messages is `memory` with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsJournalDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" directory present."
              String -> IO ()
putStrLn String
"Set store_messages to `journal` or use `smp-server journal import` to migrate."
              IO ()
forall a. IO a
exitFailure
          | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    exitConfigureMsgStorage :: IO ()
exitConfigureMsgStorage = do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error: both " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsFilePath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" file and " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
storeMsgsJournalDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" directory are present."
      String -> IO ()
putStrLn String
"Configure memory storage."
      IO ()
forall a. IO a
exitFailure

#if defined(dbServerPostgres)
    checkDbStorage ini storeLogExists = do
      let DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
      schemaExists <- checkSchemaExists connstr schema
      case enableDbStoreLog' ini of
        Just ()
          | not schemaExists -> noDatabaseSchema connstr schema
          | not storeLogExists -> do
              putStrLn $ "Error: db_store_log is `on`, " <> storeLogFilePath <> " does not exist"
              exitFailure
          | otherwise -> pure ()
        Nothing
          | storeLogExists && schemaExists -> exitConfigureQueueStore connstr schema
          | storeLogExists -> do
              putStrLn $ "Error: store_queues is `database` with " <> storeLogFilePath <> " file present."
              putStrLn "Set store_queues to `memory` or use `smp-server database import` to migrate."
              exitFailure
          | not schemaExists -> noDatabaseSchema connstr schema
          | otherwise -> pure ()
      where
        noDatabaseSchema connstr schema = do
          putStrLn $ "Error: store_queues is `database`, create schema " <> B.unpack schema <> " in PostgreSQL database " <> B.unpack connstr
          exitFailure

    exitConfigureQueueStore connstr schema = do
      putStrLn $ "Error: both " <> storeLogFilePath <> " file and " <> B.unpack schema <> " schema are present (database: " <> B.unpack connstr <> ")."
      putStrLn "Configure queue storage."
      exitFailure

importStoreLogToDatabase :: FilePath -> FilePath -> DBOpts -> IO (Int64, Int64)
importStoreLogToDatabase logPath storeLogFile dbOpts = do
  ms <- newJournalMsgStore logPath MQStoreCfg
  let st = stmQueueStore ms
  sl <- readWriteQueueStore True (mkQueue ms False) storeLogFile st
  closeStoreLog sl
  queues <- readTVarIO $ loadedQueues st
  services' <- M.elems <$> readTVarIO (services st)
  let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
  ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
  sCnt <- batchInsertServices services' $ postgresQueueStore ps
  qCnt <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps
  renameFile storeLogFile $ storeLogFile <> ".bak"
  pure (sCnt, qCnt)

importMessagesToDatabase :: FilePath -> DBOpts -> IO Int64
importMessagesToDatabase msgsLogFile dbOpts = do
  let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
  ms <- newMsgStore $ PostgresMsgStoreCfg storeCfg defaultMsgQueueQuota
  mCnt <- getDbMessageCount ms
  when (mCnt > 0) $ do
    confirmOrExit ("WARNING: the database contains messages, they will be deleted.") "Message records not imported"
    deleteAllMessages ms
  inserted <- batchInsertMessages True msgsLogFile $ queueStore ms
  mCnt' <- getDbMessageCount ms
  unless (inserted == mCnt') $ putStrLn $ "WARNING: inserted " <> show inserted <> " rows, table has " <> show mCnt' <> " messages."
  updateQueueCounts ms
  renameFile msgsLogFile $ msgsLogFile <> ".bak"
  pure mCnt'

exportDatabaseToStoreLog :: FilePath -> DBOpts -> FilePath -> IO (Int, Int)
exportDatabaseToStoreLog logPath dbOpts storeLogFilePath = do
  let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
  ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
  sl <- openWriteStoreLog False storeLogFilePath
  Sum sCnt <- foldServiceRecs (postgresQueueStore ps) $ \sr -> logNewService sl sr $> Sum (1 :: Int)
  Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
  closeStoreLog sl
  pure (sCnt, qCnt)
#endif

newJournalMsgStore :: FilePath -> QStoreCfg s -> IO (JournalMsgStore s)
newJournalMsgStore :: forall (s :: QSType).
String -> QStoreCfg s -> IO (JournalMsgStore s)
newJournalMsgStore String
logPath QStoreCfg s
qsCfg =
  let cfg :: JournalStoreConfig s
cfg = QStoreCfg s
-> String -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s
forall (s :: QSType).
QStoreCfg s
-> String -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s
mkJournalStoreConfig QStoreCfg s
qsCfg (String -> String
storeMsgsJournalDir' String
logPath) Int
defaultMsgQueueQuota Int
defaultMaxJournalMsgCount Int
defaultMaxJournalStateLines (Int64 -> JournalStoreConfig s) -> Int64 -> JournalStoreConfig s
forall a b. (a -> b) -> a -> b
$ ExpirationConfig -> Int64
checkInterval ExpirationConfig
defaultMessageExpiration
   in MsgStoreConfig (JournalMsgStore s) -> IO (JournalMsgStore s)
forall s. MsgStoreClass s => MsgStoreConfig s -> IO s
newMsgStore MsgStoreConfig (JournalMsgStore s)
JournalStoreConfig s
cfg

storeMsgsJournalDir' :: FilePath -> FilePath
storeMsgsJournalDir' :: String -> String
storeMsgsJournalDir' String
logPath = String -> String -> String
combine String
logPath String
"messages"

getServerSourceCode :: IO (Maybe String)
getServerSourceCode :: IO (Maybe String)
getServerSourceCode =
  IO String
getLine IO String -> (String -> IO (Maybe String)) -> IO (Maybe String)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    String
"" -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    String
s | String
"https://" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s Bool -> Bool -> Bool
|| String
"http://" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
s
    String
_ -> String -> IO ()
putStrLn String
"Invalid source code. URI should start from http:// or https://" IO () -> IO (Maybe String) -> IO (Maybe String)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe String)
getServerSourceCode

simplexmqSource :: String
simplexmqSource :: String
simplexmqSource = String
"https://github.com/simplex-chat/simplexmq"

serverPublicInfo :: Ini -> Maybe ServerPublicInfo
serverPublicInfo :: Ini -> Maybe ServerPublicInfo
serverPublicInfo Ini
ini = Text -> ServerPublicInfo
serverInfo (Text -> ServerPublicInfo) -> Maybe Text -> Maybe ServerPublicInfo
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Text -> Maybe Text
infoValue Text
"source_code"
  where
    serverInfo :: Text -> ServerPublicInfo
serverInfo Text
sourceCode =
      ServerPublicInfo
        { Text
$sel:sourceCode:ServerPublicInfo :: Text
sourceCode :: Text
sourceCode,
          $sel:usageConditions:ServerPublicInfo :: Maybe ServerConditions
usageConditions =
            (\Text
conditions -> ServerConditions {Text
conditions :: Text
$sel:conditions:ServerConditions :: Text
conditions, $sel:amendments:ServerConditions :: Maybe Text
amendments = Text -> Maybe Text
infoValue Text
"condition_amendments"})
              (Text -> ServerConditions) -> Maybe Text -> Maybe ServerConditions
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Text -> Maybe Text
infoValue Text
"usage_conditions",
          $sel:serverCountry:ServerPublicInfo :: Maybe Text
serverCountry = Text -> Maybe Text
countryValue Text
"server_country",
          $sel:operator:ServerPublicInfo :: Maybe Entity
operator = Text -> Text -> Maybe Entity
iniEntity Text
"operator" Text
"operator_country",
          $sel:website:ServerPublicInfo :: Maybe Text
website = Text -> Maybe Text
infoValue Text
"website",
          $sel:adminContacts:ServerPublicInfo :: Maybe ServerContactAddress
adminContacts = Text -> Text -> Text -> Text -> Maybe ServerContactAddress
iniContacts Text
"admin_simplex" Text
"admin_email" Text
"admin_pgp" Text
"admin_pgp_fingerprint",
          $sel:complaintsContacts:ServerPublicInfo :: Maybe ServerContactAddress
complaintsContacts = Text -> Text -> Text -> Text -> Maybe ServerContactAddress
iniContacts Text
"complaints_simplex" Text
"complaints_email" Text
"complaints_pgp" Text
"complaints_pgp_fingerprint",
          $sel:hosting:ServerPublicInfo :: Maybe Entity
hosting = Text -> Text -> Maybe Entity
iniEntity Text
"hosting" Text
"hosting_country",
          $sel:hostingType:ServerPublicInfo :: Maybe HostingType
hostingType = (String -> HostingType)
-> (HostingType -> HostingType)
-> Either String HostingType
-> HostingType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> HostingType
forall a. HasCallStack => String -> a
error HostingType -> HostingType
forall a. a -> a
id (Either String HostingType -> HostingType)
-> Maybe (Either String HostingType) -> Maybe HostingType
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Text -> Text -> Ini -> Maybe (Either String HostingType)
forall a.
StrEncoding a =>
Text -> Text -> Ini -> Maybe (Either String a)
strDecodeIni Text
"INFORMATION" Text
"hosting_type" Ini
ini
        }
    infoValue :: Text -> Maybe Text
infoValue Text
name = Either String Text -> Maybe Text
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String Text -> Maybe Text)
-> Either String Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Either String Text
lookupValue Text
"INFORMATION" Text
name Ini
ini
    iniEntity :: Text -> Text -> Maybe Entity
iniEntity Text
nameField Text
countryField =
      (\Text
name -> Entity {Text
name :: Text
$sel:name:Entity :: Text
name, $sel:country:Entity :: Maybe Text
country = Text -> Maybe Text
countryValue Text
countryField})
        (Text -> Entity) -> Maybe Text -> Maybe Entity
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Text -> Maybe Text
infoValue Text
nameField
    countryValue :: Text -> Maybe Text
countryValue Text
field = ((String -> Text) -> (Text -> Text) -> Either String Text -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Text
forall a. HasCallStack => String -> a
error Text -> Text
forall a. a -> a
id (Either String Text -> Text)
-> (Text -> Either String Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Either String Text
validCountryValue (Text -> String
T.unpack Text
field) (String -> Either String Text)
-> (Text -> String) -> Text -> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Text -> Text) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Text -> Maybe Text
infoValue Text
field
    iniContacts :: Text -> Text -> Text -> Text -> Maybe ServerContactAddress
iniContacts Text
simplexField Text
emailField Text
pgpKeyUriField Text
pgpKeyFingerprintField =
      let simplex :: Maybe (ConnectionLink 'CMContact)
simplex = (String -> ConnectionLink 'CMContact)
-> (ConnectionLink 'CMContact -> ConnectionLink 'CMContact)
-> Either String (ConnectionLink 'CMContact)
-> ConnectionLink 'CMContact
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ConnectionLink 'CMContact
forall a. HasCallStack => String -> a
error ConnectionLink 'CMContact -> ConnectionLink 'CMContact
forall a. a -> a
id (Either String (ConnectionLink 'CMContact)
 -> ConnectionLink 'CMContact)
-> (Text -> Either String (ConnectionLink 'CMContact))
-> Text
-> ConnectionLink 'CMContact
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (ConnectionLink 'CMContact)
-> ByteString -> Either String (ConnectionLink 'CMContact)
forall a. Parser a -> ByteString -> Either String a
parseAll Parser (ConnectionLink 'CMContact)
linkP (ByteString -> Either String (ConnectionLink 'CMContact))
-> (Text -> ByteString)
-> Text
-> Either String (ConnectionLink 'CMContact)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ConnectionLink 'CMContact)
-> Maybe Text -> Maybe (ConnectionLink 'CMContact)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Either String Text -> Maybe Text
forall a b. Either a b -> Maybe b
eitherToMaybe (Text -> Text -> Ini -> Either String Text
lookupValue Text
"INFORMATION" Text
simplexField Ini
ini)
          linkP :: Parser (ConnectionLink 'CMContact)
linkP = ConnectionRequestUri 'CMContact -> ConnectionLink 'CMContact
forall (m :: ConnectionMode).
ConnectionRequestUri m -> ConnectionLink m
CLFull (ConnectionRequestUri 'CMContact -> ConnectionLink 'CMContact)
-> Parser ByteString (ConnectionRequestUri 'CMContact)
-> Parser (ConnectionLink 'CMContact)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ServiceScheme
-> Parser ByteString (ConnectionRequestUri 'CMContact)
forall (m :: ConnectionMode).
ConnectionModeI m =>
Maybe ServiceScheme -> Parser (ConnectionRequestUri m)
connReqUriP' Maybe ServiceScheme
forall a. Maybe a
Nothing Parser (ConnectionLink 'CMContact)
-> Parser (ConnectionLink 'CMContact)
-> Parser (ConnectionLink 'CMContact)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ConnShortLink 'CMContact -> ConnectionLink 'CMContact
forall (m :: ConnectionMode). ConnShortLink m -> ConnectionLink m
CLShort (ConnShortLink 'CMContact -> ConnectionLink 'CMContact)
-> Parser ByteString (ConnShortLink 'CMContact)
-> Parser (ConnectionLink 'CMContact)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (ConnShortLink 'CMContact)
forall a. StrEncoding a => Parser a
strP
          email :: Maybe Text
email = Text -> Maybe Text
infoValue Text
emailField
          pkURI_ :: Maybe Text
pkURI_ = Text -> Maybe Text
infoValue Text
pgpKeyUriField
          pkFingerprint_ :: Maybe Text
pkFingerprint_ = Text -> Maybe Text
infoValue Text
pgpKeyFingerprintField
       in case (Maybe (ConnectionLink 'CMContact)
simplex, Maybe Text
email, Maybe Text
pkURI_, Maybe Text
pkFingerprint_) of
            (Maybe (ConnectionLink 'CMContact)
Nothing, Maybe Text
Nothing, Maybe Text
Nothing, Maybe Text
_) -> Maybe ServerContactAddress
forall a. Maybe a
Nothing
            (Maybe (ConnectionLink 'CMContact)
Nothing, Maybe Text
Nothing, Maybe Text
_, Maybe Text
Nothing) -> Maybe ServerContactAddress
forall a. Maybe a
Nothing
            (Maybe (ConnectionLink 'CMContact)
_, Maybe Text
_, Maybe Text
pkURI, Maybe Text
pkFingerprint) -> ServerContactAddress -> Maybe ServerContactAddress
forall a. a -> Maybe a
Just ServerContactAddress {Maybe (ConnectionLink 'CMContact)
simplex :: Maybe (ConnectionLink 'CMContact)
$sel:simplex:ServerContactAddress :: Maybe (ConnectionLink 'CMContact)
simplex, Maybe Text
email :: Maybe Text
$sel:email:ServerContactAddress :: Maybe Text
email, $sel:pgp:ServerContactAddress :: Maybe PGPKey
pgp = Text -> Text -> PGPKey
PGPKey (Text -> Text -> PGPKey) -> Maybe Text -> Maybe (Text -> PGPKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
pkURI Maybe (Text -> PGPKey) -> Maybe Text -> Maybe PGPKey
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
pkFingerprint}

validCountryValue :: String -> String -> Either String Text
validCountryValue :: String -> String -> Either String Text
validCountryValue String
field String
s
  | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
c) String
s = Text -> Either String Text
forall a b. b -> Either a b
Right (Text -> Either String Text) -> Text -> Either String Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
s
  | Bool
otherwise = String -> Either String Text
forall a b. a -> Either a b
Left (String -> Either String Text) -> String -> Either String Text
forall a b. (a -> b) -> a -> b
$ String
"Use ISO3166 2-letter code for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
field

printSourceCode :: Maybe Text -> IO ()
printSourceCode :: Maybe Text -> IO ()
printSourceCode = \case
  Just Text
sourceCode -> Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Server source code: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sourceCode
  Maybe Text
Nothing -> do
    String -> IO ()
putStrLn String
"Warning: server source code is not specified."
    String -> IO ()
putStrLn String
"Add 'source_code' property to [INFORMATION] section of INI file."

data CliCommand
  = Init InitOptions
  | OnlineCert CertOptions
  | Start StartOptions
  | Delete
  | Journal StoreCmd
  | Database StoreCmd DatabaseTable DBOpts

data StoreCmd = SCImport | SCExport | SCDelete

data DatabaseTable = DTQueues | DTMessages | DTAll

instance StrEncoding DatabaseTable where
  strEncode :: DatabaseTable -> ByteString
strEncode = \case
    DatabaseTable
DTQueues -> ByteString
"queues"
    DatabaseTable
DTMessages -> ByteString
"messages"
    DatabaseTable
DTAll -> ByteString
"all"
  strP :: Parser DatabaseTable
strP =
    (Char -> Bool) -> Parser ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString
-> (ByteString -> Parser DatabaseTable) -> Parser DatabaseTable
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"queues" -> DatabaseTable -> Parser DatabaseTable
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseTable
DTQueues
      ByteString
"messages" -> DatabaseTable -> Parser DatabaseTable
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseTable
DTMessages
      ByteString
"all" -> DatabaseTable -> Parser DatabaseTable
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseTable
DTAll
      ByteString
_ -> String -> Parser DatabaseTable
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"DatabaseTable"

cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand
cliCommandP :: String -> String -> String -> Parser CliCommand
cliCommandP String
cfgPath String
logPath String
iniFile =
  Mod CommandFields CliCommand -> Parser CliCommand
forall a. Mod CommandFields a -> Parser a
hsubparser
    ( String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"init" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (InitOptions -> CliCommand
Init (InitOptions -> CliCommand)
-> Parser InitOptions -> Parser CliCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser InitOptions
initP) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc (String -> InfoMod CliCommand) -> String -> InfoMod CliCommand
forall a b. (a -> b) -> a -> b
$ String
"Initialize server - creates " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cfgPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" and " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
logPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" directories and configuration files"))
        Mod CommandFields CliCommand
-> Mod CommandFields CliCommand -> Mod CommandFields CliCommand
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"cert" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (CertOptions -> CliCommand
OnlineCert (CertOptions -> CliCommand)
-> Parser CertOptions -> Parser CliCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser CertOptions
certOptionsP) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc (String -> InfoMod CliCommand) -> String -> InfoMod CliCommand
forall a b. (a -> b) -> a -> b
$ String
"Generate new online TLS server credentials (configuration: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
iniFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"))
        Mod CommandFields CliCommand
-> Mod CommandFields CliCommand -> Mod CommandFields CliCommand
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"start" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (StartOptions -> CliCommand
Start (StartOptions -> CliCommand)
-> Parser StartOptions -> Parser CliCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser StartOptions
startOptionsP) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc (String -> InfoMod CliCommand) -> String -> InfoMod CliCommand
forall a b. (a -> b) -> a -> b
$ String
"Start server (configuration: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
iniFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"))
        Mod CommandFields CliCommand
-> Mod CommandFields CliCommand -> Mod CommandFields CliCommand
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"delete" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (CliCommand -> Parser CliCommand
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CliCommand
Delete) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc String
"Delete configuration and log files"))
        Mod CommandFields CliCommand
-> Mod CommandFields CliCommand -> Mod CommandFields CliCommand
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"journal" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (StoreCmd -> CliCommand
Journal (StoreCmd -> CliCommand) -> Parser StoreCmd -> Parser CliCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser StoreCmd
journalCmdP) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc String
"Import/export messages to/from journal storage"))
        Mod CommandFields CliCommand
-> Mod CommandFields CliCommand -> Mod CommandFields CliCommand
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo CliCommand -> Mod CommandFields CliCommand
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"database" (Parser CliCommand -> InfoMod CliCommand -> ParserInfo CliCommand
forall a. Parser a -> InfoMod a -> ParserInfo a
info (StoreCmd -> DatabaseTable -> DBOpts -> CliCommand
Database (StoreCmd -> DatabaseTable -> DBOpts -> CliCommand)
-> Parser StoreCmd
-> Parser (DatabaseTable -> DBOpts -> CliCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser StoreCmd
databaseCmdP Parser (DatabaseTable -> DBOpts -> CliCommand)
-> Parser DatabaseTable -> Parser (DBOpts -> CliCommand)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser DatabaseTable
dbTableP Parser (DBOpts -> CliCommand) -> Parser DBOpts -> Parser CliCommand
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DBOpts -> Parser DBOpts
dbOptsP DBOpts
defaultDBOpts) (String -> InfoMod CliCommand
forall a. String -> InfoMod a
progDesc String
"Import/export queues to/from PostgreSQL database storage"))
    )
  where
    initP :: Parser InitOptions
    initP :: Parser InitOptions
initP = do
      Bool
enableStoreLog <-
        Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> Mod FlagFields a -> Parser a
flag' Bool
False
          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"disable-store-log"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Disable store log for persistence (enabled by default)"
          )
          Parser Bool -> Parser Bool -> Parser Bool
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
True
            ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"store-log"
                Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'l'
                Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Enable store log for persistence (DEPRECATED, enabled by default)"
            )
      DBOpts
dbOptions <- DBOpts -> Parser DBOpts
dbOptsP DBOpts
defaultDBOpts
      Bool
logStats <-
        Mod FlagFields Bool -> Parser Bool
switch
          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"daily-stats"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
's'
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Enable logging daily server statistics"
          )
      SignAlgorithm
signAlgorithm <-
        ReadM SignAlgorithm
-> Mod OptionFields SignAlgorithm -> Parser SignAlgorithm
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
          ((String -> Maybe SignAlgorithm) -> ReadM SignAlgorithm
forall a. (String -> Maybe a) -> ReadM a
maybeReader String -> Maybe SignAlgorithm
forall a. Read a => String -> Maybe a
readMaybe)
          ( String -> Mod OptionFields SignAlgorithm
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"sign-algorithm"
              Mod OptionFields SignAlgorithm
-> Mod OptionFields SignAlgorithm -> Mod OptionFields SignAlgorithm
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields SignAlgorithm
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'a'
              Mod OptionFields SignAlgorithm
-> Mod OptionFields SignAlgorithm -> Mod OptionFields SignAlgorithm
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields SignAlgorithm
forall (f :: * -> *) a. String -> Mod f a
help String
"Signature algorithm used for TLS certificates: ED25519, ED448"
              Mod OptionFields SignAlgorithm
-> Mod OptionFields SignAlgorithm -> Mod OptionFields SignAlgorithm
forall a. Semigroup a => a -> a -> a
<> SignAlgorithm -> Mod OptionFields SignAlgorithm
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value SignAlgorithm
ED25519
              Mod OptionFields SignAlgorithm
-> Mod OptionFields SignAlgorithm -> Mod OptionFields SignAlgorithm
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields SignAlgorithm
forall a (f :: * -> *). Show a => Mod f a
showDefault
              Mod OptionFields SignAlgorithm
-> Mod OptionFields SignAlgorithm -> Mod OptionFields SignAlgorithm
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields SignAlgorithm
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"ALG"
          )
      String
ip <-
        Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
          ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"ip"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help
                String
"Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value String
"127.0.0.1"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields String
forall a (f :: * -> *). Show a => Mod f a
showDefault
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"IP"
          )
      Maybe String
fqdn <-
        (Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> (Mod OptionFields String -> Parser String)
-> Mod OptionFields String
-> Parser (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
          ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"fqdn"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'n'
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Server FQDN used as Common Name for TLS online certificate"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FQDN"
          )
      Maybe ServerPassword
password <-
        Maybe ServerPassword
-> Mod FlagFields (Maybe ServerPassword)
-> Parser (Maybe ServerPassword)
forall a. a -> Mod FlagFields a -> Parser a
flag' Maybe ServerPassword
forall a. Maybe a
Nothing (String -> Mod FlagFields (Maybe ServerPassword)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-password" Mod FlagFields (Maybe ServerPassword)
-> Mod FlagFields (Maybe ServerPassword)
-> Mod FlagFields (Maybe ServerPassword)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Maybe ServerPassword)
forall (f :: * -> *) a. String -> Mod f a
help String
"Allow creating new queues without password")
          Parser (Maybe ServerPassword)
-> Parser (Maybe ServerPassword) -> Parser (Maybe ServerPassword)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ServerPassword -> Maybe ServerPassword
forall a. a -> Maybe a
Just
            (ServerPassword -> Maybe ServerPassword)
-> Parser ServerPassword -> Parser (Maybe ServerPassword)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM ServerPassword
-> Mod OptionFields ServerPassword -> Parser ServerPassword
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
              ReadM ServerPassword
parseBasicAuth
              ( String -> Mod OptionFields ServerPassword
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"password"
                  Mod OptionFields ServerPassword
-> Mod OptionFields ServerPassword
-> Mod OptionFields ServerPassword
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields ServerPassword
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PASSWORD"
                  Mod OptionFields ServerPassword
-> Mod OptionFields ServerPassword
-> Mod OptionFields ServerPassword
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields ServerPassword
forall (f :: * -> *) a. String -> Mod f a
help String
"Set password to create new messaging queues"
                  Mod OptionFields ServerPassword
-> Mod OptionFields ServerPassword
-> Mod OptionFields ServerPassword
forall a. Semigroup a => a -> a -> a
<> ServerPassword -> Mod OptionFields ServerPassword
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ServerPassword
SPRandom
              )
      Maybe Int
controlPort <-
        Maybe Int -> Mod FlagFields (Maybe Int) -> Parser (Maybe Int)
forall a. a -> Mod FlagFields a -> Parser a
flag' (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
defaultControlPort) (String -> Mod FlagFields (Maybe Int)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"control-port" Mod FlagFields (Maybe Int)
-> Mod FlagFields (Maybe Int) -> Mod FlagFields (Maybe Int)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Maybe Int)
forall (f :: * -> *) a. String -> Mod f a
help (String
"Enable control port on " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
defaultControlPort))
          Parser (Maybe Int) -> Parser (Maybe Int) -> Parser (Maybe Int)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadM (Maybe Int)
-> Mod OptionFields (Maybe Int) -> Parser (Maybe Int)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM (Maybe Int)
forall a. StrEncoding a => ReadM a
strParse (String -> Mod OptionFields (Maybe Int)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"control-port" Mod OptionFields (Maybe Int)
-> Mod OptionFields (Maybe Int) -> Mod OptionFields (Maybe Int)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Maybe Int)
forall (f :: * -> *) a. String -> Mod f a
help String
"Enable control port" Mod OptionFields (Maybe Int)
-> Mod OptionFields (Maybe Int) -> Mod OptionFields (Maybe Int)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Maybe Int)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PORT" Mod OptionFields (Maybe Int)
-> Mod OptionFields (Maybe Int) -> Mod OptionFields (Maybe Int)
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Mod OptionFields (Maybe Int)
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Maybe Int
forall a. Maybe a
Nothing)
      Maybe SocksProxy
socksProxy <-
        Maybe SocksProxy
-> Mod FlagFields (Maybe SocksProxy) -> Parser (Maybe SocksProxy)
forall a. a -> Mod FlagFields a -> Parser a
flag' (SocksProxy -> Maybe SocksProxy
forall a. a -> Maybe a
Just SocksProxy
defaultSocksProxy) (String -> Mod FlagFields (Maybe SocksProxy)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"socks-proxy" Mod FlagFields (Maybe SocksProxy)
-> Mod FlagFields (Maybe SocksProxy)
-> Mod FlagFields (Maybe SocksProxy)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Maybe SocksProxy)
forall (f :: * -> *) a. String -> Mod f a
help String
"Outgoing SOCKS proxy on port 9050")
          Parser (Maybe SocksProxy)
-> Parser (Maybe SocksProxy) -> Parser (Maybe SocksProxy)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadM (Maybe SocksProxy)
-> Mod OptionFields (Maybe SocksProxy) -> Parser (Maybe SocksProxy)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
            ReadM (Maybe SocksProxy)
forall a. StrEncoding a => ReadM a
strParse
            ( String -> Mod OptionFields (Maybe SocksProxy)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"socks-proxy"
                Mod OptionFields (Maybe SocksProxy)
-> Mod OptionFields (Maybe SocksProxy)
-> Mod OptionFields (Maybe SocksProxy)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Maybe SocksProxy)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PROXY"
                Mod OptionFields (Maybe SocksProxy)
-> Mod OptionFields (Maybe SocksProxy)
-> Mod OptionFields (Maybe SocksProxy)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Maybe SocksProxy)
forall (f :: * -> *) a. String -> Mod f a
help String
"Outgoing SOCKS proxy to forward messages to onion-only servers"
                Mod OptionFields (Maybe SocksProxy)
-> Mod OptionFields (Maybe SocksProxy)
-> Mod OptionFields (Maybe SocksProxy)
forall a. Semigroup a => a -> a -> a
<> Maybe SocksProxy -> Mod OptionFields (Maybe SocksProxy)
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Maybe SocksProxy
forall a. Maybe a
Nothing
            )
      Maybe (NonEmpty TransportHost)
ownDomains :: Maybe (L.NonEmpty TransportHost) <-
        ReadM (Maybe (NonEmpty TransportHost))
-> Mod OptionFields (Maybe (NonEmpty TransportHost))
-> Parser (Maybe (NonEmpty TransportHost))
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
          ReadM (Maybe (NonEmpty TransportHost))
forall a. StrEncoding a => ReadM a
strParse
          ( String -> Mod OptionFields (Maybe (NonEmpty TransportHost))
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"own-domains"
              Mod OptionFields (Maybe (NonEmpty TransportHost))
-> Mod OptionFields (Maybe (NonEmpty TransportHost))
-> Mod OptionFields (Maybe (NonEmpty TransportHost))
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Maybe (NonEmpty TransportHost))
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"DOMAINS"
              Mod OptionFields (Maybe (NonEmpty TransportHost))
-> Mod OptionFields (Maybe (NonEmpty TransportHost))
-> Mod OptionFields (Maybe (NonEmpty TransportHost))
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Maybe (NonEmpty TransportHost))
forall (f :: * -> *) a. String -> Mod f a
help String
"Own server domain names (comma-separated)"
              Mod OptionFields (Maybe (NonEmpty TransportHost))
-> Mod OptionFields (Maybe (NonEmpty TransportHost))
-> Mod OptionFields (Maybe (NonEmpty TransportHost))
forall a. Semigroup a => a -> a -> a
<> Maybe (NonEmpty TransportHost)
-> Mod OptionFields (Maybe (NonEmpty TransportHost))
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Maybe (NonEmpty TransportHost)
forall a. Maybe a
Nothing
          )
      Maybe String
sourceCode <-
        Maybe String
-> Mod FlagFields (Maybe String) -> Parser (Maybe String)
forall a. a -> Mod FlagFields a -> Parser a
flag' (String -> Maybe String
forall a. a -> Maybe a
Just String
simplexmqSource) (String -> Mod FlagFields (Maybe String)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"source-code" Mod FlagFields (Maybe String)
-> Mod FlagFields (Maybe String) -> Mod FlagFields (Maybe String)
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields (Maybe String)
forall (f :: * -> *) a. String -> Mod f a
help (String
"Server source code (default: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
simplexmqSource String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"))
          Parser (Maybe String)
-> Parser (Maybe String) -> Parser (Maybe String)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> (Mod OptionFields String -> Parser String)
-> Mod OptionFields String
-> Parser (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption) (String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"source-code" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"URI" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Server source code")
      (Maybe Entity, Maybe Text)
operator_ <- String -> String -> String -> Parser (Maybe Entity, Maybe Text)
entityP String
"operator" String
"OPERATOR" String
"Server operator"
      (Maybe Entity, Maybe Text)
hosting_ <- String -> String -> String -> Parser (Maybe Entity, Maybe Text)
entityP String
"hosting" String
"HOSTING" String
"Hosting provider"
      Maybe HostingType
hostingType <-
        ReadM (Maybe HostingType)
-> Mod OptionFields (Maybe HostingType)
-> Parser (Maybe HostingType)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
          ReadM (Maybe HostingType)
forall a. StrEncoding a => ReadM a
strParse
          ( String -> Mod OptionFields (Maybe HostingType)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hosting-type"
              Mod OptionFields (Maybe HostingType)
-> Mod OptionFields (Maybe HostingType)
-> Mod OptionFields (Maybe HostingType)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Maybe HostingType)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"HOSTING_TYPE"
              Mod OptionFields (Maybe HostingType)
-> Mod OptionFields (Maybe HostingType)
-> Mod OptionFields (Maybe HostingType)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Maybe HostingType)
forall (f :: * -> *) a. String -> Mod f a
help String
"Hosting type: virtual, dedicated, colocation, owned"
              Mod OptionFields (Maybe HostingType)
-> Mod OptionFields (Maybe HostingType)
-> Mod OptionFields (Maybe HostingType)
forall a. Semigroup a => a -> a -> a
<> Maybe HostingType -> Mod OptionFields (Maybe HostingType)
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Maybe HostingType
forall a. Maybe a
Nothing
          )
      Maybe Text
serverCountry <- String -> String -> String -> Parser (Maybe Text)
countryP String
"server" String
"SERVER" String
"Server datacenter"
      Maybe Text
website <-
        (Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text -> Parser (Maybe Text))
-> (Mod OptionFields Text -> Parser Text)
-> Mod OptionFields Text
-> Parser (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
          ( String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"operator-website"
              Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. String -> Mod f a
help String
"Operator public website"
              Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"WEBSITE"
          )
      Maybe String
webStaticPath <-
        (Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> (Mod OptionFields String -> Parser String)
-> Mod OptionFields String
-> Parser (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
          ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"web-path"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Directory to store generated static site with server information"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PATH"
          )
      Bool
disableWeb <-
        Mod FlagFields Bool -> Parser Bool
switch
          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"disable-web"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Disable starting static web server with server information"
          )
      Bool
scripted <-
        Mod FlagFields Bool -> Parser Bool
switch
          ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"yes"
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'y'
              Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Non-interactive initialization using command-line options"
          )
      pure
        InitOptions
          { Bool
enableStoreLog :: Bool
$sel:enableStoreLog:InitOptions :: Bool
enableStoreLog,
            DBOpts
dbOptions :: DBOpts
$sel:dbOptions:InitOptions :: DBOpts
dbOptions,
            Bool
$sel:logStats:InitOptions :: Bool
logStats :: Bool
logStats,
            SignAlgorithm
$sel:signAlgorithm:InitOptions :: SignAlgorithm
signAlgorithm :: SignAlgorithm
signAlgorithm,
            String
$sel:ip:InitOptions :: String
ip :: String
ip,
            Maybe String
$sel:fqdn:InitOptions :: Maybe String
fqdn :: Maybe String
fqdn,
            Maybe ServerPassword
$sel:password:InitOptions :: Maybe ServerPassword
password :: Maybe ServerPassword
password,
            Maybe Int
$sel:controlPort:InitOptions :: Maybe Int
controlPort :: Maybe Int
controlPort,
            Maybe SocksProxy
socksProxy :: Maybe SocksProxy
$sel:socksProxy:InitOptions :: Maybe SocksProxy
socksProxy,
            Maybe (NonEmpty TransportHost)
ownDomains :: Maybe (NonEmpty TransportHost)
$sel:ownDomains:InitOptions :: Maybe (NonEmpty TransportHost)
ownDomains,
            $sel:sourceCode:InitOptions :: Maybe Text
sourceCode = String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
sourceCode,
            $sel:serverInfo:InitOptions :: ServerPublicInfo
serverInfo =
              ServerPublicInfo
                { $sel:sourceCode:ServerPublicInfo :: Text
sourceCode = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
simplexmqSource Maybe String
sourceCode,
                  $sel:usageConditions:ServerPublicInfo :: Maybe ServerConditions
usageConditions = Maybe ServerConditions
forall a. Maybe a
Nothing,
                  $sel:operator:ServerPublicInfo :: Maybe Entity
operator = (Maybe Entity, Maybe Text) -> Maybe Entity
forall a b. (a, b) -> a
fst (Maybe Entity, Maybe Text)
operator_,
                  Maybe Text
$sel:website:ServerPublicInfo :: Maybe Text
website :: Maybe Text
website,
                  $sel:adminContacts:ServerPublicInfo :: Maybe ServerContactAddress
adminContacts = Maybe ServerContactAddress
forall a. Maybe a
Nothing,
                  $sel:complaintsContacts:ServerPublicInfo :: Maybe ServerContactAddress
complaintsContacts = Maybe ServerContactAddress
forall a. Maybe a
Nothing,
                  $sel:hosting:ServerPublicInfo :: Maybe Entity
hosting = (Maybe Entity, Maybe Text) -> Maybe Entity
forall a b. (a, b) -> a
fst (Maybe Entity, Maybe Text)
hosting_,
                  Maybe HostingType
$sel:hostingType:ServerPublicInfo :: Maybe HostingType
hostingType :: Maybe HostingType
hostingType,
                  Maybe Text
$sel:serverCountry:ServerPublicInfo :: Maybe Text
serverCountry :: Maybe Text
serverCountry
                },
            $sel:operatorCountry:InitOptions :: Maybe Text
operatorCountry = (Maybe Entity, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd (Maybe Entity, Maybe Text)
operator_,
            $sel:hostingCountry:InitOptions :: Maybe Text
hostingCountry = (Maybe Entity, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd (Maybe Entity, Maybe Text)
hosting_,
            Maybe String
$sel:webStaticPath:InitOptions :: Maybe String
webStaticPath :: Maybe String
webStaticPath,
            Bool
$sel:disableWeb:InitOptions :: Bool
disableWeb :: Bool
disableWeb,
            Bool
$sel:scripted:InitOptions :: Bool
scripted :: Bool
scripted
          }
    journalCmdP :: Parser StoreCmd
journalCmdP = String -> String -> Parser StoreCmd
storeCmdP String
"message log file" String
"journal storage"
    databaseCmdP :: Parser StoreCmd
databaseCmdP = String -> String -> Parser StoreCmd
storeCmdP String
"queue store log file" String
"PostgreSQL database schema"
    storeCmdP :: String -> String -> Parser StoreCmd
storeCmdP String
src String
dest =
      Mod CommandFields StoreCmd -> Parser StoreCmd
forall a. Mod CommandFields a -> Parser a
hsubparser
        ( String -> ParserInfo StoreCmd -> Mod CommandFields StoreCmd
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"import" (Parser StoreCmd -> InfoMod StoreCmd -> ParserInfo StoreCmd
forall a. Parser a -> InfoMod a -> ParserInfo a
info (StoreCmd -> Parser StoreCmd
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StoreCmd
SCImport) (String -> InfoMod StoreCmd
forall a. String -> InfoMod a
progDesc (String -> InfoMod StoreCmd) -> String -> InfoMod StoreCmd
forall a b. (a -> b) -> a -> b
$ String
"Import " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
src String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" into a new " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dest))
            Mod CommandFields StoreCmd
-> Mod CommandFields StoreCmd -> Mod CommandFields StoreCmd
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo StoreCmd -> Mod CommandFields StoreCmd
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"export" (Parser StoreCmd -> InfoMod StoreCmd -> ParserInfo StoreCmd
forall a. Parser a -> InfoMod a -> ParserInfo a
info (StoreCmd -> Parser StoreCmd
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StoreCmd
SCExport) (String -> InfoMod StoreCmd
forall a. String -> InfoMod a
progDesc (String -> InfoMod StoreCmd) -> String -> InfoMod StoreCmd
forall a b. (a -> b) -> a -> b
$ String
"Export " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dest String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
src))
            Mod CommandFields StoreCmd
-> Mod CommandFields StoreCmd -> Mod CommandFields StoreCmd
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo StoreCmd -> Mod CommandFields StoreCmd
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"delete" (Parser StoreCmd -> InfoMod StoreCmd -> ParserInfo StoreCmd
forall a. Parser a -> InfoMod a -> ParserInfo a
info (StoreCmd -> Parser StoreCmd
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StoreCmd
SCDelete) (String -> InfoMod StoreCmd
forall a. String -> InfoMod a
progDesc (String -> InfoMod StoreCmd) -> String -> InfoMod StoreCmd
forall a b. (a -> b) -> a -> b
$ String
"Delete " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dest))
        )
    dbTableP :: Parser DatabaseTable
dbTableP =
      ReadM DatabaseTable
-> Mod OptionFields DatabaseTable -> Parser DatabaseTable
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
        ReadM DatabaseTable
forall a. StrEncoding a => ReadM a
strParse
        ( String -> Mod OptionFields DatabaseTable
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"table"
            Mod OptionFields DatabaseTable
-> Mod OptionFields DatabaseTable -> Mod OptionFields DatabaseTable
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields DatabaseTable
forall (f :: * -> *) a. String -> Mod f a
help String
"Database tables: queues/messages"
            Mod OptionFields DatabaseTable
-> Mod OptionFields DatabaseTable -> Mod OptionFields DatabaseTable
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields DatabaseTable
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"TABLE"
            Mod OptionFields DatabaseTable
-> Mod OptionFields DatabaseTable -> Mod OptionFields DatabaseTable
forall a. Semigroup a => a -> a -> a
<> DatabaseTable -> Mod OptionFields DatabaseTable
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value DatabaseTable
DTAll
        )
    parseBasicAuth :: ReadM ServerPassword
    parseBasicAuth :: ReadM ServerPassword
parseBasicAuth = (String -> Either String ServerPassword) -> ReadM ServerPassword
forall a. (String -> Either String a) -> ReadM a
eitherReader ((String -> Either String ServerPassword) -> ReadM ServerPassword)
-> (String -> Either String ServerPassword) -> ReadM ServerPassword
forall a b. (a -> b) -> a -> b
$ (BasicAuth -> ServerPassword)
-> Either String BasicAuth -> Either String ServerPassword
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BasicAuth -> ServerPassword
ServerPassword (Either String BasicAuth -> Either String ServerPassword)
-> (String -> Either String BasicAuth)
-> String
-> Either String ServerPassword
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String BasicAuth
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String BasicAuth)
-> (String -> ByteString) -> String -> Either String BasicAuth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack
    entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)
    entityP :: String -> String -> String -> Parser (Maybe Entity, Maybe Text)
entityP String
opt' String
metavar' String
help' = do
      Maybe Text
name_ <-
        (Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text -> Parser (Maybe Text))
-> (Mod OptionFields Text -> Parser Text)
-> Mod OptionFields Text
-> Parser (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
strOption)
          ( String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
opt'
              Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar (String
metavar' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_NAME")
              Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. String -> Mod f a
help (String
help' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" name")
          )
      Maybe Text
country <- String -> String -> String -> Parser (Maybe Text)
countryP String
opt' String
metavar' String
help'
      pure ((\Text
name -> Entity {Text
$sel:name:Entity :: Text
name :: Text
name, Maybe Text
$sel:country:Entity :: Maybe Text
country :: Maybe Text
country}) (Text -> Entity) -> Maybe Text -> Maybe Entity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
name_, Maybe Text
country)
    countryP :: String -> String -> String -> Parser (Maybe Text)
    countryP :: String -> String -> String -> Parser (Maybe Text)
countryP String
opt' String
metavar' String
help' =
      (Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text -> Parser (Maybe Text))
-> (Mod OptionFields Text -> Parser Text)
-> Mod OptionFields Text
-> Parser (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadM Text -> Mod OptionFields Text -> Parser Text
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Either String Text) -> ReadM Text
forall a. (String -> Either String a) -> ReadM a
eitherReader ((String -> Either String Text) -> ReadM Text)
-> (String -> Either String Text) -> ReadM Text
forall a b. (a -> b) -> a -> b
$ String -> String -> Either String Text
validCountryValue String
opt'))
        ( String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (String
opt' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-country")
            Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar (String
metavar' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_COUNTRY")
            Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. String -> Mod f a
help (String
help' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" country")
        )

strParse :: StrEncoding a => ReadM a
strParse :: forall a. StrEncoding a => ReadM a
strParse = (String -> Either String a) -> ReadM a
forall a. (String -> Either String a) -> ReadM a
eitherReader ((String -> Either String a) -> ReadM a)
-> (String -> Either String a) -> ReadM a
forall a b. (a -> b) -> a -> b
$ Parser a -> ByteString -> Either String a
forall a. Parser a -> ByteString -> Either String a
parseAll Parser a
forall a. StrEncoding a => Parser a
strP (ByteString -> Either String a)
-> (String -> ByteString) -> String -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack