{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

module Simplex.Messaging.Server.CLI
  ( SignAlgorithm (..),
    X509Config (..),
    CertOptions (..),
    IniOptions (..),
    exitError,
    confirmOrExit,
    defaultX509Config,
    getCliCommand',
    simplexmqVersionCommit,
    simplexmqCommit,
    createServerX509,
    createServerX509_,
    certOptionsP,
    dbOptsP,
    startOptionsP,
    parseConfirmMigrations,
    parseLogLevel,
    genOnline,
    warnCAPrivateKeyFile,
    mkIniOptions,
    strictIni,
    readStrictIni,
    readIniDefault,
    iniOnOff,
    strDecodeIni,
    withPrompt,
    onOffPrompt,
    onOff,
    settingIsOn,
    checkSavedFingerprint,
    iniTransports,
    iniDBOptions,
    printServerConfig,
    printServerTransports,
    printSMPServerConfig,
    deleteDirIfExists,
    printServiceInfo,
    clearDirIfExists,
    getEnvPath,
  ) where

import Control.Logger.Simple (LogLevel (..))
import Control.Monad
import Data.ASN1.Types (asn1CharacterToString)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight)
import Data.Ini (Ini, lookupValue)
import Data.List ((\\))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.X509 as X
import qualified Data.X509.File as XF
import Data.X509.Validation (Fingerprint (..))
import Network.Socket (HostName, ServiceName)
import Options.Applicative
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), dbStoreCfg, storeLogFile')
import Simplex.Messaging.Server.Main.GitCommit
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..), simplexMQVersion)
import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (eitherToMaybe, whenM)
import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
import System.FilePath (combine)
import System.IO (IOMode (..), hFlush, hGetLine, stdout, withFile)
import System.Process (readCreateProcess, shell)
import Text.Read (readMaybe)

exitError :: String -> IO a
exitError :: forall a. FilePath -> IO a
exitError FilePath
msg = FilePath -> IO ()
putStrLn FilePath
msg IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
forall a. IO a
exitFailure

confirmOrExit :: String -> String -> IO ()
confirmOrExit :: FilePath -> FilePath -> IO ()
confirmOrExit FilePath
s FilePath
no =
  FilePath -> IO () -> IO ()
forall a. FilePath -> IO a -> IO a
withPrompt (FilePath
s FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\nContinue (Y/n): ") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath
ok <- IO FilePath
getLine
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
ok FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"Y") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn FilePath
no IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure

data SignAlgorithm = ED448 | ED25519
  deriving (ReadPrec [SignAlgorithm]
ReadPrec SignAlgorithm
Int -> ReadS SignAlgorithm
ReadS [SignAlgorithm]
(Int -> ReadS SignAlgorithm)
-> ReadS [SignAlgorithm]
-> ReadPrec SignAlgorithm
-> ReadPrec [SignAlgorithm]
-> Read SignAlgorithm
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SignAlgorithm
readsPrec :: Int -> ReadS SignAlgorithm
$creadList :: ReadS [SignAlgorithm]
readList :: ReadS [SignAlgorithm]
$creadPrec :: ReadPrec SignAlgorithm
readPrec :: ReadPrec SignAlgorithm
$creadListPrec :: ReadPrec [SignAlgorithm]
readListPrec :: ReadPrec [SignAlgorithm]
Read, Int -> SignAlgorithm -> FilePath -> FilePath
[SignAlgorithm] -> FilePath -> FilePath
SignAlgorithm -> FilePath
(Int -> SignAlgorithm -> FilePath -> FilePath)
-> (SignAlgorithm -> FilePath)
-> ([SignAlgorithm] -> FilePath -> FilePath)
-> Show SignAlgorithm
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> SignAlgorithm -> FilePath -> FilePath
showsPrec :: Int -> SignAlgorithm -> FilePath -> FilePath
$cshow :: SignAlgorithm -> FilePath
show :: SignAlgorithm -> FilePath
$cshowList :: [SignAlgorithm] -> FilePath -> FilePath
showList :: [SignAlgorithm] -> FilePath -> FilePath
Show)

data X509Config = X509Config
  { X509Config -> FilePath
commonName :: HostName,
    X509Config -> SignAlgorithm
signAlgorithm :: SignAlgorithm,
    X509Config -> FilePath
caKeyFile :: FilePath,
    X509Config -> FilePath
caCrtFile :: FilePath,
    X509Config -> FilePath
serverKeyFile :: FilePath,
    X509Config -> FilePath
serverCrtFile :: FilePath,
    X509Config -> FilePath
fingerprintFile :: FilePath,
    X509Config -> FilePath
opensslCaConfFile :: FilePath,
    X509Config -> FilePath
opensslServerConfFile :: FilePath,
    X509Config -> FilePath
serverCsrFile :: FilePath
  }

defaultX509Config :: X509Config
defaultX509Config :: X509Config
defaultX509Config =
  X509Config
    { $sel:commonName:X509Config :: FilePath
commonName = FilePath
"127.0.0.1",
      $sel:signAlgorithm:X509Config :: SignAlgorithm
signAlgorithm = SignAlgorithm
ED448,
      $sel:caKeyFile:X509Config :: FilePath
caKeyFile = FilePath
"ca.key",
      $sel:caCrtFile:X509Config :: FilePath
caCrtFile = FilePath
"ca.crt",
      $sel:serverKeyFile:X509Config :: FilePath
serverKeyFile = FilePath
"server.key",
      $sel:serverCrtFile:X509Config :: FilePath
serverCrtFile = FilePath
"server.crt",
      $sel:fingerprintFile:X509Config :: FilePath
fingerprintFile = FilePath
"fingerprint",
      $sel:opensslCaConfFile:X509Config :: FilePath
opensslCaConfFile = FilePath
"openssl_ca.conf",
      $sel:opensslServerConfFile:X509Config :: FilePath
opensslServerConfFile = FilePath
"openssl_server.conf",
      $sel:serverCsrFile:X509Config :: FilePath
serverCsrFile = FilePath
"server.csr"
    }

getCliCommand' :: Parser cmd -> String -> IO cmd
getCliCommand' :: forall cmd. Parser cmd -> FilePath -> IO cmd
getCliCommand' Parser cmd
cmdP FilePath
version =
  ParserPrefs -> ParserInfo cmd -> IO cmd
forall a. ParserPrefs -> ParserInfo a -> IO a
customExecParser
    (PrefsMod -> ParserPrefs
prefs PrefsMod
showHelpOnEmpty)
    ( Parser cmd -> InfoMod cmd -> ParserInfo cmd
forall a. Parser a -> InfoMod a -> ParserInfo a
info
        (Parser ((cmd -> cmd) -> cmd -> cmd)
forall a. Parser (a -> a)
helper Parser ((cmd -> cmd) -> cmd -> cmd)
-> Parser (cmd -> cmd) -> Parser (cmd -> cmd)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (cmd -> cmd)
versionOption Parser (cmd -> cmd) -> Parser cmd -> Parser cmd
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser cmd
cmdP)
        (FilePath -> InfoMod cmd
forall a. FilePath -> InfoMod a
header FilePath
version InfoMod cmd -> InfoMod cmd -> InfoMod cmd
forall a. Semigroup a => a -> a -> a
<> InfoMod cmd
forall a. InfoMod a
fullDesc)
    )
  where
    versionOption :: Parser (cmd -> cmd)
versionOption = FilePath -> Mod OptionFields (cmd -> cmd) -> Parser (cmd -> cmd)
forall a. FilePath -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption FilePath
version (FilePath -> Mod OptionFields (cmd -> cmd)
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"version" Mod OptionFields (cmd -> cmd)
-> Mod OptionFields (cmd -> cmd) -> Mod OptionFields (cmd -> cmd)
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields (cmd -> cmd)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'v' Mod OptionFields (cmd -> cmd)
-> Mod OptionFields (cmd -> cmd) -> Mod OptionFields (cmd -> cmd)
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields (cmd -> cmd)
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Show version")

simplexmqVersionCommit :: String
simplexmqVersionCommit :: FilePath
simplexmqVersionCommit = FilePath
simplexMQVersion FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" / " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
7 FilePath
simplexmqCommit

simplexmqCommit :: String
simplexmqCommit :: FilePath
simplexmqCommit = FilePath
"858fac7f4f821a2df6fbea03a1bfbb82ea9717c5"

createServerX509 :: FilePath -> X509Config -> IO ByteString
createServerX509 :: FilePath -> X509Config -> IO ByteString
createServerX509 = Bool -> FilePath -> X509Config -> IO ByteString
createServerX509_ Bool
True

createServerX509_ :: Bool -> FilePath -> X509Config -> IO ByteString
createServerX509_ :: Bool -> FilePath -> X509Config -> IO ByteString
createServerX509_ Bool
createCA FilePath
cfgPath X509Config
x509cfg = do
  let alg :: FilePath
alg = SignAlgorithm -> FilePath
forall a. Show a => a -> FilePath
show (SignAlgorithm -> FilePath) -> SignAlgorithm -> FilePath
forall a b. (a -> b) -> a -> b
$ X509Config -> SignAlgorithm
signAlgorithm (X509Config
x509cfg :: X509Config)
  -- CA certificate (identity/offline)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
createCA (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO ()
createOpensslCaConf
    FilePath -> IO ()
run (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"openssl genpkey -algorithm " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
alg FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -out " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
caKeyFile
    FilePath -> IO ()
run (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"openssl req -new -x509 -days 999999 -config " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
opensslCaConfFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -extensions v3 -key " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
caKeyFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -out " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
caCrtFile
  -- server certificate (online)
  IO ()
createOpensslServerConf
  FilePath -> IO ()
run (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"openssl genpkey -algorithm " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
alg FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -out " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
serverKeyFile
  FilePath -> IO ()
run (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"openssl req -new -config " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
opensslServerConfFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -reqexts v3 -key " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
serverKeyFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -out " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
serverCsrFile
  FilePath -> IO ()
run (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"openssl x509 -req -days 999999 -extfile " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
opensslServerConfFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -extensions v3 -in " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
serverCsrFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -CA " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
caCrtFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -CAkey " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
caKeyFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" -CAcreateserial -out " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
serverCrtFile
  IO ByteString
saveFingerprint
  where
    run :: FilePath -> IO ()
run FilePath
cmd = IO FilePath -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FilePath -> IO ()) -> IO FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ CreateProcess -> FilePath -> IO FilePath
readCreateProcess (FilePath -> CreateProcess
shell FilePath
cmd) FilePath
""
    c :: (X509Config -> FilePath) -> FilePath
c = FilePath -> FilePath -> FilePath
combine FilePath
cfgPath (FilePath -> FilePath)
-> ((X509Config -> FilePath) -> FilePath)
-> (X509Config -> FilePath)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((X509Config -> FilePath) -> X509Config -> FilePath
forall a b. (a -> b) -> a -> b
$ X509Config
x509cfg)
    createOpensslCaConf :: IO ()
createOpensslCaConf =
      FilePath -> FilePath -> IO ()
writeFile
        ((X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
opensslCaConfFile)
        FilePath
"[req]\n\
        \distinguished_name = req_distinguished_name\n\
        \prompt = no\n\n\
        \[req_distinguished_name]\n\
        \CN = SMP server CA\n\
        \O = SimpleX\n\n\
        \[v3]\n\
        \subjectKeyIdentifier = hash\n\
        \authorityKeyIdentifier = keyid:always\n\
        \basicConstraints = critical,CA:true\n"
    createOpensslServerConf :: IO ()
createOpensslServerConf =
      FilePath -> FilePath -> IO ()
writeFile
        ((X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
opensslServerConfFile)
        ( FilePath
"[req]\n\
          \distinguished_name = req_distinguished_name\n\
          \prompt = no\n\n\
          \[req_distinguished_name]\n"
            FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (FilePath
"CN = " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> X509Config -> FilePath
commonName X509Config
x509cfg FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n\n")
            FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"[v3]\n\
               \basicConstraints = CA:FALSE\n\
               \keyUsage = digitalSignature, nonRepudiation, keyAgreement\n\
               \extendedKeyUsage = serverAuth\n"
        )

    saveFingerprint :: IO ByteString
saveFingerprint = do
      Fingerprint ByteString
fp <- FilePath -> IO Fingerprint
loadFileFingerprint (FilePath -> IO Fingerprint) -> FilePath -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ (X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
caCrtFile
      FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile ((X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
fingerprintFile) IOMode
WriteMode (Handle -> ByteString -> IO ()
`B.hPutStrLn` ByteString -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ByteString
fp)
      pure ByteString
fp

data CertOptions = CertOptions
  { CertOptions -> Maybe SignAlgorithm
signAlgorithm_ :: Maybe SignAlgorithm,
    CertOptions -> Maybe FilePath
commonName_ :: Maybe HostName
  }
  deriving (Int -> CertOptions -> FilePath -> FilePath
[CertOptions] -> FilePath -> FilePath
CertOptions -> FilePath
(Int -> CertOptions -> FilePath -> FilePath)
-> (CertOptions -> FilePath)
-> ([CertOptions] -> FilePath -> FilePath)
-> Show CertOptions
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> CertOptions -> FilePath -> FilePath
showsPrec :: Int -> CertOptions -> FilePath -> FilePath
$cshow :: CertOptions -> FilePath
show :: CertOptions -> FilePath
$cshowList :: [CertOptions] -> FilePath -> FilePath
showList :: [CertOptions] -> FilePath -> FilePath
Show)

certOptionsP :: Parser CertOptions
certOptionsP :: Parser CertOptions
certOptionsP = do
  Maybe SignAlgorithm
signAlgorithm_ <-
    Parser SignAlgorithm -> Parser (Maybe SignAlgorithm)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser SignAlgorithm -> Parser (Maybe SignAlgorithm))
-> Parser SignAlgorithm -> Parser (Maybe SignAlgorithm)
forall a b. (a -> b) -> a -> b
$
      ReadM SignAlgorithm
-> Mod OptionFields SignAlgorithm -> Parser SignAlgorithm
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
        ((FilePath -> Maybe SignAlgorithm) -> ReadM SignAlgorithm
forall a. (FilePath -> Maybe a) -> ReadM a
maybeReader FilePath -> Maybe SignAlgorithm
forall a. Read a => FilePath -> Maybe a
readMaybe)
        ( FilePath -> Mod OptionFields SignAlgorithm
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"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
<> FilePath -> Mod OptionFields SignAlgorithm
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Set new signature algorithm used for TLS certificates: ED25519, ED448"
            Mod OptionFields SignAlgorithm
-> Mod OptionFields SignAlgorithm -> Mod OptionFields SignAlgorithm
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields SignAlgorithm
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"ALG"
        )
  Maybe FilePath
commonName_ <-
    Parser FilePath -> Parser (Maybe FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser FilePath -> Parser (Maybe FilePath))
-> Parser FilePath -> Parser (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$
      Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"cn"
            Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help
              FilePath
"Set new Common Name for TLS online certificate"
            Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FQDN"
        )
  pure CertOptions {Maybe SignAlgorithm
$sel:signAlgorithm_:CertOptions :: Maybe SignAlgorithm
signAlgorithm_ :: Maybe SignAlgorithm
signAlgorithm_, Maybe FilePath
$sel:commonName_:CertOptions :: Maybe FilePath
commonName_ :: Maybe FilePath
commonName_}

dbOptsP :: DBOpts -> Parser DBOpts
dbOptsP :: DBOpts -> Parser DBOpts
dbOptsP DBOpts {connstr :: DBOpts -> ByteString
connstr = ByteString
defDBConnStr, schema :: DBOpts -> ByteString
schema = ByteString
defDBSchema, poolSize :: DBOpts -> Natural
poolSize = Natural
defDBPoolSize} = do
  ByteString
connstr <-
    Mod OptionFields ByteString -> Parser ByteString
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      ( FilePath -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"database"
          Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'd'
          Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"DB_CONN"
          Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields ByteString
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Database connection string"
          Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ByteString
defDBConnStr
          Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields ByteString
forall a (f :: * -> *). Show a => Mod f a
showDefault
      )
  ByteString
schema <-
    Mod OptionFields ByteString -> Parser ByteString
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      ( FilePath -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"schema"
          Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"DB_SCHEMA"
          Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields ByteString
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Database schema"
          Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ByteString
defDBSchema
          Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields ByteString
forall a (f :: * -> *). Show a => Mod f a
showDefault
      )
  Natural
poolSize <-
    ReadM Natural -> Mod OptionFields Natural -> Parser Natural
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
      ReadM Natural
forall a. Read a => ReadM a
auto
      ( FilePath -> Mod OptionFields Natural
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"pool-size"
          Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Natural
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"POOL_SIZE"
          Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Natural
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Database pool size"
          Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall a. Semigroup a => a -> a -> a
<> Natural -> Mod OptionFields Natural
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Natural
defDBPoolSize
          Mod OptionFields Natural
-> Mod OptionFields Natural -> Mod OptionFields Natural
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Natural
forall a (f :: * -> *). Show a => Mod f a
showDefault
      )
  pure DBOpts {ByteString
connstr :: ByteString
connstr :: ByteString
connstr, ByteString
schema :: ByteString
schema :: ByteString
schema, Natural
poolSize :: Natural
poolSize :: Natural
poolSize, createSchema :: Bool
createSchema = Bool
False}

startOptionsP :: Parser StartOptions
startOptionsP :: Parser StartOptions
startOptionsP = do
  Bool
maintenance <-
    Mod FlagFields Bool -> Parser Bool
switch
      ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"maintenance"
          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
'm'
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Do not start the server, only perform start and stop tasks"
      )
  Bool
compactLog <-
    Mod FlagFields Bool -> Parser Bool
switch
      ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"compact-log"
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Compact store log (always enabled with `memory` storage for queues)"
      )
  LogLevel
logLevel <-
    ReadM LogLevel -> Mod OptionFields LogLevel -> Parser LogLevel
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
      ReadM LogLevel
parseLogLevel
      ( FilePath -> Mod OptionFields LogLevel
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"log-level"
          Mod OptionFields LogLevel
-> Mod OptionFields LogLevel -> Mod OptionFields LogLevel
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields LogLevel
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"LOG_LEVEL"
          Mod OptionFields LogLevel
-> Mod OptionFields LogLevel -> Mod OptionFields LogLevel
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields LogLevel
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Logging level"
          Mod OptionFields LogLevel
-> Mod OptionFields LogLevel -> Mod OptionFields LogLevel
forall a. Semigroup a => a -> a -> a
<> LogLevel -> Mod OptionFields LogLevel
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value LogLevel
LogInfo
      )
  Bool
skipWarnings <-
    Mod FlagFields Bool -> Parser Bool
switch
      ( FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"skip-warnings"
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Start the server with non-critical start warnings"
      )
  MigrationConfirmation
confirmMigrations <-
    ReadM MigrationConfirmation
-> Mod OptionFields MigrationConfirmation
-> Parser MigrationConfirmation
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
      ReadM MigrationConfirmation
parseConfirmMigrations
      ( FilePath -> Mod OptionFields MigrationConfirmation
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"confirm-migrations"
          Mod OptionFields MigrationConfirmation
-> Mod OptionFields MigrationConfirmation
-> Mod OptionFields MigrationConfirmation
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields MigrationConfirmation
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"CONFIRM_MIGRATIONS"
          Mod OptionFields MigrationConfirmation
-> Mod OptionFields MigrationConfirmation
-> Mod OptionFields MigrationConfirmation
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields MigrationConfirmation
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Confirm PostgreSQL database migration: up, down (default is manual confirmation)"
          Mod OptionFields MigrationConfirmation
-> Mod OptionFields MigrationConfirmation
-> Mod OptionFields MigrationConfirmation
forall a. Semigroup a => a -> a -> a
<> MigrationConfirmation -> Mod OptionFields MigrationConfirmation
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value MigrationConfirmation
MCConsole
      )
  pure StartOptions {Bool
maintenance :: Bool
$sel:maintenance:StartOptions :: Bool
maintenance, Bool
compactLog :: Bool
$sel:compactLog:StartOptions :: Bool
compactLog, LogLevel
logLevel :: LogLevel
$sel:logLevel:StartOptions :: LogLevel
logLevel, Bool
skipWarnings :: Bool
$sel:skipWarnings:StartOptions :: Bool
skipWarnings, MigrationConfirmation
confirmMigrations :: MigrationConfirmation
$sel:confirmMigrations:StartOptions :: MigrationConfirmation
confirmMigrations}

parseConfirmMigrations :: ReadM MigrationConfirmation
parseConfirmMigrations :: ReadM MigrationConfirmation
parseConfirmMigrations = (FilePath -> Either FilePath MigrationConfirmation)
-> ReadM MigrationConfirmation
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader ((FilePath -> Either FilePath MigrationConfirmation)
 -> ReadM MigrationConfirmation)
-> (FilePath -> Either FilePath MigrationConfirmation)
-> ReadM MigrationConfirmation
forall a b. (a -> b) -> a -> b
$ \case
  FilePath
"up" -> MigrationConfirmation -> Either FilePath MigrationConfirmation
forall a b. b -> Either a b
Right MigrationConfirmation
MCYesUp
  FilePath
"down" -> MigrationConfirmation -> Either FilePath MigrationConfirmation
forall a b. b -> Either a b
Right MigrationConfirmation
MCYesUpDown
  FilePath
_ -> FilePath -> Either FilePath MigrationConfirmation
forall a b. a -> Either a b
Left FilePath
"invalid migration confirmation, pass 'up' or 'down'"

parseLogLevel :: ReadM LogLevel
parseLogLevel :: ReadM LogLevel
parseLogLevel = (FilePath -> Either FilePath LogLevel) -> ReadM LogLevel
forall a. (FilePath -> Either FilePath a) -> ReadM a
eitherReader ((FilePath -> Either FilePath LogLevel) -> ReadM LogLevel)
-> (FilePath -> Either FilePath LogLevel) -> ReadM LogLevel
forall a b. (a -> b) -> a -> b
$ \case
  FilePath
"trace" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LogTrace
  FilePath
"debug" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LogDebug
  FilePath
"info" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LogInfo
  FilePath
"note" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LogNote
  FilePath
"warn" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LogWarn
  FilePath
"error" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LogError
  FilePath
_ -> FilePath -> Either FilePath LogLevel
forall a b. a -> Either a b
Left FilePath
"Invalid log level"

genOnline :: FilePath -> CertOptions -> IO ()
genOnline :: FilePath -> CertOptions -> IO ()
genOnline FilePath
cfgPath CertOptions {Maybe SignAlgorithm
$sel:signAlgorithm_:CertOptions :: CertOptions -> Maybe SignAlgorithm
signAlgorithm_ :: Maybe SignAlgorithm
signAlgorithm_, Maybe FilePath
$sel:commonName_:CertOptions :: CertOptions -> Maybe FilePath
commonName_ :: Maybe FilePath
commonName_} = do
  (SignAlgorithm
signAlgorithm, FilePath
commonName) <-
    case (Maybe SignAlgorithm
signAlgorithm_, Maybe FilePath
commonName_) of
      (Just SignAlgorithm
alg, Just FilePath
cn) -> (SignAlgorithm, FilePath) -> IO (SignAlgorithm, FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignAlgorithm
alg, FilePath
cn)
      (Maybe SignAlgorithm, Maybe FilePath)
_ ->
        FilePath -> IO [SignedExact Certificate]
forall a.
(ASN1Object a, Eq a, Show a) =>
FilePath -> IO [SignedExact a]
XF.readSignedObject FilePath
certPath IO [SignedExact Certificate]
-> ([SignedExact Certificate] -> IO (SignAlgorithm, FilePath))
-> IO (SignAlgorithm, FilePath)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          [SignedExact Certificate
old] -> (FilePath -> IO (SignAlgorithm, FilePath))
-> ((SignAlgorithm, FilePath) -> IO (SignAlgorithm, FilePath))
-> Either FilePath (SignAlgorithm, FilePath)
-> IO (SignAlgorithm, FilePath)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO (SignAlgorithm, FilePath)
forall a. FilePath -> IO a
exitError (SignAlgorithm, FilePath) -> IO (SignAlgorithm, FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath (SignAlgorithm, FilePath)
 -> IO (SignAlgorithm, FilePath))
-> (Signed Certificate
    -> Either FilePath (SignAlgorithm, FilePath))
-> Signed Certificate
-> IO (SignAlgorithm, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Certificate -> Either FilePath (SignAlgorithm, FilePath)
fromX509 (Certificate -> Either FilePath (SignAlgorithm, FilePath))
-> (Signed Certificate -> Certificate)
-> Signed Certificate
-> Either FilePath (SignAlgorithm, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signed Certificate -> Certificate
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
X.signedObject (Signed Certificate -> IO (SignAlgorithm, FilePath))
-> Signed Certificate -> IO (SignAlgorithm, FilePath)
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
X.getSigned SignedExact Certificate
old
          [] -> FilePath -> IO (SignAlgorithm, FilePath)
forall a. FilePath -> IO a
exitError (FilePath -> IO (SignAlgorithm, FilePath))
-> FilePath -> IO (SignAlgorithm, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath
"No certificate found at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
certPath
          [SignedExact Certificate]
_ -> FilePath -> IO (SignAlgorithm, FilePath)
forall a. FilePath -> IO a
exitError (FilePath -> IO (SignAlgorithm, FilePath))
-> FilePath -> IO (SignAlgorithm, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath
"Too many certificates at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
certPath
  let x509cfg :: X509Config
x509cfg = X509Config
defaultX509Config {signAlgorithm, commonName}
  IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> X509Config -> IO ByteString
createServerX509_ Bool
False FilePath
cfgPath X509Config
x509cfg
  FilePath -> IO ()
putStrLn FilePath
"Generated new server credentials"
  FilePath -> X509Config -> IO ()
warnCAPrivateKeyFile FilePath
cfgPath X509Config
x509cfg
  where
    certPath :: FilePath
certPath = FilePath -> FilePath -> FilePath
combine FilePath
cfgPath (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ X509Config -> FilePath
serverCrtFile X509Config
defaultX509Config
    fromX509 :: Certificate -> Either FilePath (SignAlgorithm, FilePath)
fromX509 X.Certificate {SignatureALG
certSignatureAlg :: SignatureALG
certSignatureAlg :: Certificate -> SignatureALG
certSignatureAlg, DistinguishedName
certSubjectDN :: DistinguishedName
certSubjectDN :: Certificate -> DistinguishedName
certSubjectDN} = (,) (SignAlgorithm -> FilePath -> (SignAlgorithm, FilePath))
-> Either FilePath SignAlgorithm
-> Either FilePath (FilePath -> (SignAlgorithm, FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either FilePath SignAlgorithm
-> (SignAlgorithm -> Either FilePath SignAlgorithm)
-> Maybe SignAlgorithm
-> Either FilePath SignAlgorithm
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either FilePath SignAlgorithm
oldAlg SignAlgorithm -> Either FilePath SignAlgorithm
forall a b. b -> Either a b
Right Maybe SignAlgorithm
signAlgorithm_ Either FilePath (FilePath -> (SignAlgorithm, FilePath))
-> Either FilePath FilePath
-> Either FilePath (SignAlgorithm, FilePath)
forall a b.
Either FilePath (a -> b) -> Either FilePath a -> Either FilePath b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either FilePath FilePath
-> (FilePath -> Either FilePath FilePath)
-> Maybe FilePath
-> Either FilePath FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either FilePath FilePath
oldCN FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right Maybe FilePath
commonName_
      where
        oldAlg :: Either FilePath SignAlgorithm
oldAlg = case SignatureALG
certSignatureAlg of
          X.SignatureALG_IntrinsicHash PubKeyALG
X.PubKeyALG_Ed448 -> SignAlgorithm -> Either FilePath SignAlgorithm
forall a b. b -> Either a b
Right SignAlgorithm
ED448
          X.SignatureALG_IntrinsicHash PubKeyALG
X.PubKeyALG_Ed25519 -> SignAlgorithm -> Either FilePath SignAlgorithm
forall a b. b -> Either a b
Right SignAlgorithm
ED25519
          SignatureALG
alg -> FilePath -> Either FilePath SignAlgorithm
forall a b. a -> Either a b
Left (FilePath -> Either FilePath SignAlgorithm)
-> FilePath -> Either FilePath SignAlgorithm
forall a b. (a -> b) -> a -> b
$ FilePath
"Unexpected signature algorithm " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SignatureALG -> FilePath
forall a. Show a => a -> FilePath
show SignatureALG
alg
        oldCN :: Either FilePath FilePath
oldCN = case DnElement -> DistinguishedName -> Maybe ASN1CharacterString
X.getDnElement DnElement
X.DnCommonName DistinguishedName
certSubjectDN of
          Maybe ASN1CharacterString
Nothing -> FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left FilePath
"Certificate subject has no CN element"
          Just ASN1CharacterString
cn -> Either FilePath FilePath
-> (FilePath -> Either FilePath FilePath)
-> Maybe FilePath
-> Either FilePath FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left FilePath
"Certificate subject CN decoding failed") FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right (Maybe FilePath -> Either FilePath FilePath)
-> Maybe FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$ ASN1CharacterString -> Maybe FilePath
asn1CharacterToString ASN1CharacterString
cn

warnCAPrivateKeyFile :: FilePath -> X509Config -> IO ()
warnCAPrivateKeyFile :: FilePath -> X509Config -> IO ()
warnCAPrivateKeyFile FilePath
cfgPath X509Config {FilePath
$sel:caKeyFile:X509Config :: X509Config -> FilePath
caKeyFile :: FilePath
caKeyFile} =
  FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath
"----------\n\
    \You should store CA private key securely and delete it from the server.\n\
    \If server TLS credential is compromised this key can be used to sign a new one, \
    \keeping the same server identity and established connections.\n\
    \CA private key location:\n"
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath -> FilePath
combine FilePath
cfgPath FilePath
caKeyFile
      FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n----------"

data IniOptions = IniOptions
  { IniOptions -> Bool
enableStoreLog :: Bool,
    IniOptions -> FilePath
port :: ServiceName,
    IniOptions -> Bool
enableWebsockets :: Bool
  }

mkIniOptions :: Ini -> IniOptions
mkIniOptions :: Ini -> IniOptions
mkIniOptions Ini
ini =
  IniOptions
    { $sel:enableStoreLog:IniOptions :: Bool
enableStoreLog = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"on") (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Text
strictIni Text
"STORE_LOG" Text
"enable" Ini
ini,
      $sel:port:IniOptions :: FilePath
port = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Text
strictIni Text
"TRANSPORT" Text
"port" Ini
ini,
      $sel:enableWebsockets:IniOptions :: Bool
enableWebsockets = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"on") (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Text
strictIni Text
"TRANSPORT" Text
"websockets" Ini
ini
    }

strictIni :: Text -> Text -> Ini -> Text
strictIni :: Text -> Text -> Ini -> Text
strictIni Text
section Text
key Ini
ini =
  Text -> Either FilePath Text -> Text
forall b a. b -> Either a b -> b
fromRight (FilePath -> Text
forall a. HasCallStack => FilePath -> a
error (FilePath -> Text) -> (Text -> FilePath) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"no key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in section " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
section) (Either FilePath Text -> Text) -> Either FilePath Text -> Text
forall a b. (a -> b) -> a -> b
$
    Text -> Text -> Ini -> Either FilePath Text
lookupValue Text
section Text
key Ini
ini

readStrictIni :: Read a => Text -> Text -> Ini -> a
readStrictIni :: forall a. Read a => Text -> Text -> Ini -> a
readStrictIni Text
section Text
key = FilePath -> a
forall a. Read a => FilePath -> a
read (FilePath -> a) -> (Ini -> FilePath) -> Ini -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (Ini -> Text) -> Ini -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Ini -> Text
strictIni Text
section Text
key

readIniDefault :: Read a => a -> Text -> Text -> Ini -> a
readIniDefault :: forall a. Read a => a -> Text -> Text -> Ini -> a
readIniDefault a
def Text
section Text
key = (FilePath -> a) -> (Text -> a) -> Either FilePath Text -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (a -> FilePath -> a
forall a b. a -> b -> a
const a
def) (FilePath -> a
forall a. Read a => FilePath -> a
read (FilePath -> a) -> (Text -> FilePath) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack) (Either FilePath Text -> a)
-> (Ini -> Either FilePath Text) -> Ini -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Ini -> Either FilePath Text
lookupValue Text
section Text
key

iniOnOff :: Text -> Text -> Ini -> Maybe Bool
iniOnOff :: Text -> Text -> Ini -> Maybe Bool
iniOnOff Text
section Text
name Ini
ini = case Text -> Text -> Ini -> Either FilePath Text
lookupValue Text
section Text
name Ini
ini of
  Right Text
"on" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  Right Text
"off" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
  Right Text
s -> FilePath -> Maybe Bool
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe Bool)
-> (Text -> FilePath) -> Text -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> Maybe Bool) -> Text -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Text
"invalid INI setting " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
  Either FilePath Text
_ -> Maybe Bool
forall a. Maybe a
Nothing

strDecodeIni :: StrEncoding a => Text -> Text -> Ini -> Maybe (Either String a)
strDecodeIni :: forall a.
StrEncoding a =>
Text -> Text -> Ini -> Maybe (Either FilePath a)
strDecodeIni Text
section Text
name Ini
ini = ByteString -> Either FilePath a
forall a. StrEncoding a => ByteString -> Either FilePath a
strDecode (ByteString -> Either FilePath a)
-> (Text -> ByteString) -> Text -> Either FilePath a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> Either FilePath a)
-> Maybe Text -> Maybe (Either FilePath a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either FilePath Text -> Maybe Text
forall a b. Either a b -> Maybe b
eitherToMaybe (Text -> Text -> Ini -> Either FilePath Text
lookupValue Text
section Text
name Ini
ini)

withPrompt :: String -> IO a -> IO a
withPrompt :: forall a. FilePath -> IO a -> IO a
withPrompt FilePath
s IO a
a = FilePath -> IO ()
putStr FilePath
s IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
a

onOffPrompt :: String -> Bool -> IO Bool
onOffPrompt :: FilePath -> Bool -> IO Bool
onOffPrompt FilePath
prompt Bool
def =
  FilePath -> IO Bool -> IO Bool
forall a. FilePath -> IO a -> IO a
withPrompt (FilePath
prompt FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> if Bool
def then FilePath
" (Yn): " else FilePath
" (yN): ") (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
    IO FilePath
getLine IO FilePath -> (FilePath -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FilePath
"" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
def
      FilePath
"y" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      FilePath
"Y" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      FilePath
"n" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      FilePath
"N" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      FilePath
_ -> FilePath -> IO ()
putStrLn FilePath
"Invalid input, please enter 'y' or 'n'" IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> Bool -> IO Bool
onOffPrompt FilePath
prompt Bool
def

onOff :: Bool -> Text
onOff :: Bool -> Text
onOff Bool
True = Text
"on"
onOff Bool
_ = Text
"off"

settingIsOn :: Text -> Text -> Ini -> Maybe ()
settingIsOn :: Text -> Text -> Ini -> Maybe ()
settingIsOn Text
section Text
name Ini
ini
  | Text -> Text -> Ini -> Maybe Bool
iniOnOff Text
section Text
name Ini
ini Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True = () -> Maybe ()
forall a. a -> Maybe a
Just ()
  | Bool
otherwise = Maybe ()
forall a. Maybe a
Nothing

checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString
checkSavedFingerprint :: FilePath -> X509Config -> IO ByteString
checkSavedFingerprint FilePath
cfgPath X509Config
x509cfg = do
  FilePath
savedFingerprint <- FilePath -> IOMode -> (Handle -> IO FilePath) -> IO FilePath
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile ((X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
fingerprintFile) IOMode
ReadMode Handle -> IO FilePath
hGetLine
  Fingerprint ByteString
fp <- FilePath -> IO Fingerprint
loadFileFingerprint ((X509Config -> FilePath) -> FilePath
c X509Config -> FilePath
caCrtFile)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> ByteString
B.pack FilePath
savedFingerprint ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ByteString
fp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> IO ()
forall a. FilePath -> IO a
exitError FilePath
"Stored fingerprint is invalid."
  pure ByteString
fp
  where
    c :: (X509Config -> FilePath) -> FilePath
c = FilePath -> FilePath -> FilePath
combine FilePath
cfgPath (FilePath -> FilePath)
-> ((X509Config -> FilePath) -> FilePath)
-> (X509Config -> FilePath)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((X509Config -> FilePath) -> X509Config -> FilePath
forall a b. (a -> b) -> a -> b
$ X509Config
x509cfg)

iniTransports :: Ini -> [(ServiceName, ASrvTransport, AddHTTP)]
iniTransports :: Ini -> [(FilePath, ASrvTransport, Bool)]
iniTransports Ini
ini =
  let smpPorts :: [FilePath]
smpPorts = Text -> [FilePath]
ports (Text -> [FilePath]) -> Text -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Text
strictIni Text
"TRANSPORT" Text
"port" Ini
ini
      ws :: Text
ws = Text -> Text -> Ini -> Text
strictIni Text
"TRANSPORT" Text
"websockets" Ini
ini
      wsPorts :: [FilePath]
wsPorts
        | Text
ws Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"off" = []
        | Text
ws Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"on" = [FilePath
"80"]
        | Bool
otherwise = Text -> [FilePath]
ports Text
ws [FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
\\ [FilePath]
smpPorts
   in ASrvTransport -> [FilePath] -> [(FilePath, ASrvTransport, Bool)]
ts (forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
ATransport p
transport @TLS) [FilePath]
smpPorts [(FilePath, ASrvTransport, Bool)]
-> [(FilePath, ASrvTransport, Bool)]
-> [(FilePath, ASrvTransport, Bool)]
forall a. Semigroup a => a -> a -> a
<> ASrvTransport -> [FilePath] -> [(FilePath, ASrvTransport, Bool)]
ts (forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
ATransport p
transport @WS) [FilePath]
wsPorts
  where
    ts :: ASrvTransport -> [ServiceName] -> [(ServiceName, ASrvTransport, AddHTTP)]
    ts :: ASrvTransport -> [FilePath] -> [(FilePath, ASrvTransport, Bool)]
ts ASrvTransport
t = (FilePath -> (FilePath, ASrvTransport, Bool))
-> [FilePath] -> [(FilePath, ASrvTransport, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
port -> (FilePath
port, ASrvTransport
t, Maybe FilePath
webPort Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
port))
    webPort :: Maybe FilePath
webPort = Text -> FilePath
T.unpack (Text -> FilePath) -> Maybe Text -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either FilePath Text -> Maybe Text
forall a b. Either a b -> Maybe b
eitherToMaybe (Text -> Text -> Ini -> Either FilePath Text
lookupValue Text
"WEB" Text
"https" Ini
ini)
    ports :: Text -> [FilePath]
ports = (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack ([Text] -> [FilePath]) -> (Text -> [Text]) -> Text -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
","

iniDBOptions :: Ini -> DBOpts -> DBOpts
iniDBOptions :: Ini -> DBOpts -> DBOpts
iniDBOptions Ini
ini _default :: DBOpts
_default@DBOpts {ByteString
connstr :: DBOpts -> ByteString
connstr :: ByteString
connstr, ByteString
schema :: DBOpts -> ByteString
schema :: ByteString
schema, Natural
poolSize :: DBOpts -> Natural
poolSize :: Natural
poolSize} =
  DBOpts
    { connstr :: ByteString
connstr = (FilePath -> ByteString)
-> (Text -> ByteString) -> Either FilePath Text -> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> FilePath -> ByteString
forall a b. a -> b -> a
const ByteString
connstr) Text -> ByteString
encodeUtf8 (Either FilePath Text -> ByteString)
-> Either FilePath Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Either FilePath Text
lookupValue Text
"STORE_LOG" Text
"db_connection" Ini
ini,
      schema :: ByteString
schema = (FilePath -> ByteString)
-> (Text -> ByteString) -> Either FilePath Text -> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> FilePath -> ByteString
forall a b. a -> b -> a
const ByteString
schema) Text -> ByteString
encodeUtf8 (Either FilePath Text -> ByteString)
-> Either FilePath Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Ini -> Either FilePath Text
lookupValue Text
"STORE_LOG" Text
"db_schema" Ini
ini,
      poolSize :: Natural
poolSize = Natural -> Text -> Text -> Ini -> Natural
forall a. Read a => a -> Text -> Text -> Ini -> a
readIniDefault Natural
poolSize Text
"STORE_LOG" Text
"db_pool_size" Ini
ini,
      createSchema :: Bool
createSchema = Bool
False
    }

printServerConfig :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> Maybe FilePath -> IO ()
printServerConfig :: FilePath
-> [(FilePath, ASrvTransport, Bool)] -> Maybe FilePath -> IO ()
printServerConfig FilePath
protocol [(FilePath, ASrvTransport, Bool)]
transports Maybe FilePath
logFile = do
  FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe FilePath
logFile of
    Just FilePath
f -> FilePath
"Store log: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
f
    Maybe FilePath
_ -> FilePath
"Store log disabled."
  FilePath -> [(FilePath, ASrvTransport, Bool)] -> IO ()
printServerTransports FilePath
protocol [(FilePath, ASrvTransport, Bool)]
transports

printServerTransports :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> IO ()
printServerTransports :: FilePath -> [(FilePath, ASrvTransport, Bool)] -> IO ()
printServerTransports FilePath
protocol [(FilePath, ASrvTransport, Bool)]
ts = do
  [(FilePath, ASrvTransport, Bool)]
-> ((FilePath, ASrvTransport, Bool) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(FilePath, ASrvTransport, Bool)]
ts (((FilePath, ASrvTransport, Bool) -> IO ()) -> IO ())
-> ((FilePath, ASrvTransport, Bool) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
p, ATransport TProxy c 'TServer
t, Bool
addHTTP) -> do
    let descr :: FilePath
descr = FilePath
p FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" (" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> TProxy c 'TServer -> FilePath
forall (p :: TransportPeer). TProxy c p -> FilePath
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
TProxy c p -> FilePath
transportName TProxy c 'TServer
t FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
")..."
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Serving " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
protocol FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" protocol on port " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
descr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
addHTTP (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Serving static site on port " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
descr
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (((FilePath, ASrvTransport, Bool) -> Bool)
-> [(FilePath, ASrvTransport, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(FilePath
p, ASrvTransport
_, Bool
_) -> FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"443") [(FilePath, ASrvTransport, Bool)]
ts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> IO ()
putStrLn
      FilePath
"\nWARNING: the clients will use port 443 by default soon.\n\
      \Set `port` in smp-server.ini section [TRANSPORT] to `5223,443`\n"

printSMPServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> ServerStoreCfg s -> IO ()
printSMPServerConfig :: forall s.
[(FilePath, ASrvTransport, Bool)] -> ServerStoreCfg s -> IO ()
printSMPServerConfig [(FilePath, ASrvTransport, Bool)]
transports ServerStoreCfg s
st = case ServerStoreCfg s -> Maybe PostgresStoreCfg
forall s. ServerStoreCfg s -> Maybe PostgresStoreCfg
dbStoreCfg ServerStoreCfg s
st of
  Just PostgresStoreCfg
cfg -> PostgresStoreCfg -> IO ()
printDBConfig PostgresStoreCfg
cfg
  Maybe PostgresStoreCfg
Nothing -> FilePath
-> [(FilePath, ASrvTransport, Bool)] -> Maybe FilePath -> IO ()
printServerConfig FilePath
"SMP" [(FilePath, ASrvTransport, Bool)]
transports (Maybe FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStoreCfg s -> Maybe FilePath
forall s. ServerStoreCfg s -> Maybe FilePath
storeLogFile' ServerStoreCfg s
st
  where
    printDBConfig :: PostgresStoreCfg -> IO ()
printDBConfig PostgresStoreCfg {dbOpts :: PostgresStoreCfg -> DBOpts
dbOpts = DBOpts {ByteString
connstr :: DBOpts -> ByteString
connstr :: ByteString
connstr, ByteString
schema :: DBOpts -> ByteString
schema :: ByteString
schema}} = do
      ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"PostgreSQL database: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
connstr ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
", schema: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
schema
      FilePath -> [(FilePath, ASrvTransport, Bool)] -> IO ()
printServerTransports FilePath
"SMP" [(FilePath, ASrvTransport, Bool)]
transports

deleteDirIfExists :: FilePath -> IO ()
deleteDirIfExists :: FilePath -> IO ()
deleteDirIfExists FilePath
path = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
doesDirectoryExist FilePath
path) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
path

printServiceInfo :: ProtocolTypeI p => String -> ProtoServerWithAuth p -> IO ()
printServiceInfo :: forall (p :: ProtocolType).
ProtocolTypeI p =>
FilePath -> ProtoServerWithAuth p -> IO ()
printServiceInfo FilePath
serverVersion srv :: ProtoServerWithAuth p
srv@(ProtoServerWithAuth ProtocolServer {KeyHash
keyHash :: KeyHash
$sel:keyHash:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash} Maybe BasicAuth
_) = do
  FilePath -> IO ()
putStrLn FilePath
serverVersion
  ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Fingerprint: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> KeyHash -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode KeyHash
keyHash
  ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Server address: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ProtoServerWithAuth p -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtoServerWithAuth p
srv

clearDirIfExists :: FilePath -> IO ()
clearDirIfExists :: FilePath -> IO ()
clearDirIfExists FilePath
path = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
doesDirectoryExist FilePath
path) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectory FilePath
path IO [FilePath] -> ([FilePath] -> 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
>>= (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> IO ()
removePathForcibly (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
combine FilePath
path)

getEnvPath :: String -> FilePath -> IO FilePath
getEnvPath :: FilePath -> FilePath -> IO FilePath
getEnvPath FilePath
name FilePath
def = FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
def (\case FilePath
"" -> FilePath
def; FilePath
f -> FilePath
f) (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
name