module ProjectM36.Server.ParseArgs where
import ProjectM36.Base
import ProjectM36.Client
import Options.Applicative
import ProjectM36.Server.Config
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif

parseArgsWithDefaults :: ServerConfig -> Parser ServerConfig
parseArgsWithDefaults :: ServerConfig -> Parser ServerConfig
parseArgsWithDefaults ServerConfig
defaults = PersistenceStrategy
-> Bool
-> DatabaseName
-> DatabaseName
-> Port
-> [DatabaseName]
-> Int
-> Bool
-> ServerConfig
ServerConfig (PersistenceStrategy
 -> Bool
 -> DatabaseName
 -> DatabaseName
 -> Port
 -> [DatabaseName]
 -> Int
 -> Bool
 -> ServerConfig)
-> Parser PersistenceStrategy
-> Parser
     (Bool
      -> DatabaseName
      -> DatabaseName
      -> Port
      -> [DatabaseName]
      -> Int
      -> Bool
      -> ServerConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                 Parser PersistenceStrategy
parsePersistenceStrategy Parser
  (Bool
   -> DatabaseName
   -> DatabaseName
   -> Port
   -> [DatabaseName]
   -> Int
   -> Bool
   -> ServerConfig)
-> Parser Bool
-> Parser
     (DatabaseName
      -> DatabaseName
      -> Port
      -> [DatabaseName]
      -> Int
      -> Bool
      -> ServerConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                 Parser Bool
parseCheckFS Parser
  (DatabaseName
   -> DatabaseName
   -> Port
   -> [DatabaseName]
   -> Int
   -> Bool
   -> ServerConfig)
-> Parser DatabaseName
-> Parser
     (DatabaseName
      -> Port -> [DatabaseName] -> Int -> Bool -> ServerConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                 Parser DatabaseName
parseDatabaseName Parser
  (DatabaseName
   -> Port -> [DatabaseName] -> Int -> Bool -> ServerConfig)
-> Parser DatabaseName
-> Parser (Port -> [DatabaseName] -> Int -> Bool -> ServerConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                 DatabaseName -> Parser DatabaseName
parseHostname (ServerConfig -> DatabaseName
bindHost ServerConfig
defaults) Parser (Port -> [DatabaseName] -> Int -> Bool -> ServerConfig)
-> Parser Port
-> Parser ([DatabaseName] -> Int -> Bool -> ServerConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                 Port -> Parser Port
parsePort (ServerConfig -> Port
bindPort ServerConfig
defaults) Parser ([DatabaseName] -> Int -> Bool -> ServerConfig)
-> Parser [DatabaseName] -> Parser (Int -> Bool -> ServerConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                 Parser DatabaseName -> Parser [DatabaseName]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser DatabaseName
parseGhcPkgPath Parser (Int -> Bool -> ServerConfig)
-> Parser Int -> Parser (Bool -> ServerConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                 Int -> Parser Int
parseTimeout (ServerConfig -> Int
perRequestTimeout ServerConfig
defaults) Parser (Bool -> ServerConfig) -> Parser Bool -> Parser ServerConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                 Parser Bool
parseTestMode

parsePersistenceStrategy :: Parser PersistenceStrategy
parsePersistenceStrategy :: Parser PersistenceStrategy
parsePersistenceStrategy = DatabaseName -> PersistenceStrategy
CrashSafePersistence (DatabaseName -> PersistenceStrategy)
-> Parser DatabaseName -> Parser PersistenceStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser DatabaseName
dbdirOpt Parser DatabaseName -> Parser Bool -> Parser DatabaseName
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Bool
fsyncOpt) Parser PersistenceStrategy
-> Parser PersistenceStrategy -> Parser PersistenceStrategy
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                           DatabaseName -> PersistenceStrategy
MinimalPersistence (DatabaseName -> PersistenceStrategy)
-> Parser DatabaseName -> Parser PersistenceStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser DatabaseName
dbdirOpt Parser PersistenceStrategy
-> Parser PersistenceStrategy -> Parser PersistenceStrategy
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                           PersistenceStrategy -> Parser PersistenceStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure PersistenceStrategy
NoPersistence
  where
    dbdirOpt :: Parser DatabaseName
dbdirOpt = Mod OptionFields DatabaseName -> Parser DatabaseName
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Char -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'd' Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                          DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"database-directory" Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                          DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasMetavar f => DatabaseName -> Mod f a
metavar DatabaseName
"DIRECTORY" Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                          (DatabaseName -> DatabaseName) -> Mod OptionFields DatabaseName
forall a (f :: * -> *). (a -> DatabaseName) -> Mod f a
showDefaultWith DatabaseName -> DatabaseName
forall a. Show a => a -> DatabaseName
show
                         )
    fsyncOpt :: Parser Bool
fsyncOpt = Mod FlagFields Bool -> Parser Bool
switch (Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'f' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<>
                    DatabaseName -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"fsync" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<>
                    DatabaseName -> Mod FlagFields Bool
forall (f :: * -> *) a. DatabaseName -> Mod f a
help DatabaseName
"Fsync all new transactions.")

parseTestMode :: Parser Bool
parseTestMode :: Parser Bool
parseTestMode = Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (DatabaseName -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"test-mode" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Mod FlagFields Bool
forall (f :: * -> *) a. Mod f a
hidden)

parseCheckFS :: Parser Bool
parseCheckFS :: Parser Bool
parseCheckFS = Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (DatabaseName -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"disable-fscheck" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<>
                                DatabaseName -> Mod FlagFields Bool
forall (f :: * -> *) a. DatabaseName -> Mod f a
help DatabaseName
"Disable filesystem check for journaling.")

parseDatabaseName :: Parser DatabaseName
parseDatabaseName :: Parser DatabaseName
parseDatabaseName = Mod OptionFields DatabaseName -> Parser DatabaseName
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Char -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'n' Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                               DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"database" Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                               DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasMetavar f => DatabaseName -> Mod f a
metavar DatabaseName
"DATABASE_NAME")

parseHostname :: Hostname -> Parser Hostname
parseHostname :: DatabaseName -> Parser DatabaseName
parseHostname DatabaseName
defHostname = Mod OptionFields DatabaseName -> Parser DatabaseName
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (Char -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'h' Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                           DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"hostname" Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                           DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasMetavar f => DatabaseName -> Mod f a
metavar DatabaseName
"HOST_NAME" Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                           DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value DatabaseName
defHostname)

parsePort :: Port -> Parser Port
parsePort :: Port -> Parser Port
parsePort Port
defPort = ReadM Port -> Mod OptionFields Port -> Parser Port
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Port
forall a. Read a => ReadM a
auto (Char -> Mod OptionFields Port
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'p' Mod OptionFields Port
-> Mod OptionFields Port -> Mod OptionFields Port
forall a. Semigroup a => a -> a -> a
<>
                         DatabaseName -> Mod OptionFields Port
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"port" Mod OptionFields Port
-> Mod OptionFields Port -> Mod OptionFields Port
forall a. Semigroup a => a -> a -> a
<>
                         DatabaseName -> Mod OptionFields Port
forall (f :: * -> *) a. HasMetavar f => DatabaseName -> Mod f a
metavar DatabaseName
"PORT_NUMBER" Mod OptionFields Port
-> Mod OptionFields Port -> Mod OptionFields Port
forall a. Semigroup a => a -> a -> a
<>
                         Port -> Mod OptionFields Port
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Port
defPort)

parseGhcPkgPath :: Parser String
parseGhcPkgPath :: Parser DatabaseName
parseGhcPkgPath = Mod OptionFields DatabaseName -> Parser DatabaseName
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"ghc-pkg-dir" Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                              DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasMetavar f => DatabaseName -> Mod f a
metavar DatabaseName
"GHC_PACKAGE_DIRECTORY")

parseTimeout :: Int -> Parser Int
parseTimeout :: Int -> Parser Int
parseTimeout Int
defTimeout = ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto (DatabaseName -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"timeout" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<>
                            DatabaseName -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => DatabaseName -> Mod f a
metavar DatabaseName
"MICROSECONDS" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<>
                            Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
defTimeout)

parseConfig :: IO ServerConfig
parseConfig :: IO ServerConfig
parseConfig = ServerConfig -> IO ServerConfig
parseConfigWithDefaults ServerConfig
defaultServerConfig

parseConfigWithDefaults :: ServerConfig -> IO ServerConfig
parseConfigWithDefaults :: ServerConfig -> IO ServerConfig
parseConfigWithDefaults ServerConfig
defaults = ParserInfo ServerConfig -> IO ServerConfig
forall a. ParserInfo a -> IO a
execParser (Parser ServerConfig
-> InfoMod ServerConfig -> ParserInfo ServerConfig
forall a. Parser a -> InfoMod a -> ParserInfo a
info (ServerConfig -> Parser ServerConfig
parseArgsWithDefaults ServerConfig
defaults Parser ServerConfig
-> Parser (ServerConfig -> ServerConfig) -> Parser ServerConfig
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (ServerConfig -> ServerConfig)
forall a. Parser (a -> a)
helpOption) InfoMod ServerConfig
forall m. Monoid m => m
idm)

parseWSConfigWithDefaults :: ServerConfig -> IO WebsocketServerConfig
parseWSConfigWithDefaults :: ServerConfig -> IO WebsocketServerConfig
parseWSConfigWithDefaults ServerConfig
defaults = ParserInfo WebsocketServerConfig -> IO WebsocketServerConfig
forall a. ParserInfo a -> IO a
execParser (Parser WebsocketServerConfig
-> InfoMod WebsocketServerConfig
-> ParserInfo WebsocketServerConfig
forall a. Parser a -> InfoMod a -> ParserInfo a
info (ServerConfig -> Parser WebsocketServerConfig
parseWSArgsWithDefaults ServerConfig
defaults Parser WebsocketServerConfig
-> Parser (WebsocketServerConfig -> WebsocketServerConfig)
-> Parser WebsocketServerConfig
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (WebsocketServerConfig -> WebsocketServerConfig)
forall a. Parser (a -> a)
helpOption) InfoMod WebsocketServerConfig
forall m. Monoid m => m
idm)

parseWSArgsWithDefaults :: ServerConfig -> Parser WebsocketServerConfig
parseWSArgsWithDefaults :: ServerConfig -> Parser WebsocketServerConfig
parseWSArgsWithDefaults ServerConfig
defaults = ServerConfig
-> Maybe DatabaseName
-> Maybe DatabaseName
-> WebsocketServerConfig
WebsocketServerConfig (ServerConfig
 -> Maybe DatabaseName
 -> Maybe DatabaseName
 -> WebsocketServerConfig)
-> Parser ServerConfig
-> Parser
     (Maybe DatabaseName -> Maybe DatabaseName -> WebsocketServerConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                 ServerConfig -> Parser ServerConfig
parseArgsWithDefaults ServerConfig
defaults Parser
  (Maybe DatabaseName -> Maybe DatabaseName -> WebsocketServerConfig)
-> Parser (Maybe DatabaseName)
-> Parser (Maybe DatabaseName -> WebsocketServerConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                 Parser (Maybe DatabaseName)
parseTlsCertificatePath Parser (Maybe DatabaseName -> WebsocketServerConfig)
-> Parser (Maybe DatabaseName) -> Parser WebsocketServerConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                 Parser (Maybe DatabaseName)
parseTlsKeyPath


parseTlsCertificatePath :: Parser (Maybe String)
parseTlsCertificatePath :: Parser (Maybe DatabaseName)
parseTlsCertificatePath = Parser DatabaseName -> Parser (Maybe DatabaseName)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser DatabaseName -> Parser (Maybe DatabaseName))
-> Parser DatabaseName -> Parser (Maybe DatabaseName)
forall a b. (a -> b) -> a -> b
$ Mod OptionFields DatabaseName -> Parser DatabaseName
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"tls-certificate-path" Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                              DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasMetavar f => DatabaseName -> Mod f a
metavar DatabaseName
"TLS_CERTIFICATE_PATH")

parseTlsKeyPath :: Parser (Maybe String)
parseTlsKeyPath :: Parser (Maybe DatabaseName)
parseTlsKeyPath = Parser DatabaseName -> Parser (Maybe DatabaseName)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser DatabaseName -> Parser (Maybe DatabaseName))
-> Parser DatabaseName -> Parser (Maybe DatabaseName)
forall a b. (a -> b) -> a -> b
$ Mod OptionFields DatabaseName -> Parser DatabaseName
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"tls-key-path" Mod OptionFields DatabaseName
-> Mod OptionFields DatabaseName -> Mod OptionFields DatabaseName
forall a. Semigroup a => a -> a -> a
<>
                              DatabaseName -> Mod OptionFields DatabaseName
forall (f :: * -> *) a. HasMetavar f => DatabaseName -> Mod f a
metavar DatabaseName
"TLS_KEY_PATH")

helpOption :: Parser (a -> a)
helpOption :: Parser (a -> a)
helpOption = ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption ParseError
helpText (Mod OptionFields (a -> a) -> Parser (a -> a))
-> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$ [Mod OptionFields (a -> a)] -> Mod OptionFields (a -> a)
forall a. Monoid a => [a] -> a
mconcat
  [ DatabaseName -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => DatabaseName -> Mod f a
long DatabaseName
"help"
  , DatabaseName -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. DatabaseName -> Mod f a
help DatabaseName
"Show this help text"
  , Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
hidden ]
  where
#if MIN_VERSION_optparse_applicative(0,16,0)
    helpText :: ParseError
helpText = Maybe DatabaseName -> ParseError
ShowHelpText Maybe DatabaseName
forall a. Maybe a
Nothing
#else
    helpText = ShowHelpText
#endif