module System.Etc.Internal.Spec.Types where
import Prelude (fail)
import Protolude
import Data.Aeson ((.:), (.:?))
import Data.HashMap.Strict (HashMap)
import Data.Vector (Vector)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON (Parser, typeMismatch)
import qualified Data.HashMap.Strict as HashMap
data ConfigurationError
= InvalidConfiguration Text
| InvalidConfigKeyPath [Text]
| ConfigurationFileNotFound Text
deriving (Show)
instance Exception ConfigurationError
data CliOptValueType
= StringOpt
| NumberOpt
| SwitchOpt
deriving (Show, Eq)
data CliArgValueType
= StringArg
| NumberArg
deriving (Show, Eq)
data CliEntryMetadata
= Opt {
optLong :: Maybe Text
, optShort :: Maybe Text
, optMetavar :: Maybe Text
, optHelp :: Maybe Text
, optRequired :: Bool
, optValueType :: CliOptValueType
}
| Arg {
argMetavar :: Maybe Text
, optRequired :: Bool
, argValueType :: CliArgValueType
}
deriving (Show, Eq)
data CliEntrySpec cmd
= CmdEntry {
cliEntryCmdValue :: Vector cmd
, cliEntryMetadata :: CliEntryMetadata
}
| PlainEntry {
cliEntryMetadata :: CliEntryMetadata
}
deriving (Show, Eq)
data CliCmdSpec
= CliCmdSpec {
cliCmdDesc :: Text
, cliCmdHeader :: Text
}
deriving (Show, Eq)
data ConfigSources cmd
= ConfigSources {
envVar :: Maybe Text
, cliEntry :: Maybe (CliEntrySpec cmd)
}
deriving (Show, Eq)
data ConfigValue cmd
= ConfigValue {
defaultValue :: Maybe JSON.Value
, configSources :: ConfigSources cmd
}
| SubConfig {
subConfig :: HashMap Text (ConfigValue cmd)
}
deriving (Show, Eq)
data CliProgramSpec
= CliProgramSpec {
cliProgramDesc :: Text
, cliProgramHeader :: Text
, cliCommands :: Maybe (HashMap Text CliCmdSpec)
}
deriving (Show, Eq)
data ConfigSpec cmd
= ConfigSpec {
specConfigFilepaths :: [Text]
, specCliProgramSpec :: Maybe CliProgramSpec
, specConfigValues :: HashMap Text (ConfigValue cmd)
}
deriving (Show, Eq)
instance JSON.FromJSON CliCmdSpec where
parseJSON json =
case json of
JSON.Object object ->
CliCmdSpec
<$> object .: "desc"
<*> object .: "header"
_ ->
JSON.typeMismatch "CliCmdSpec" json
instance JSON.FromJSON CliProgramSpec where
parseJSON json =
case json of
JSON.Object object ->
CliProgramSpec
<$> object .: "desc"
<*> object .: "header"
<*> object .:? "commands"
_ ->
JSON.typeMismatch "CliProgramSpec" json
cliArgTypeParser
:: JSON.Object
-> JSON.Parser CliArgValueType
cliArgTypeParser object = do
value <- object .: "type"
case value of
JSON.String typeName
| typeName == "string" ->
return StringArg
| typeName == "number" ->
return NumberArg
| otherwise ->
JSON.typeMismatch "CliArgValueType (string, number)" value
_ ->
JSON.typeMismatch "CliArgValueType (string, number)" value
cliArgParser
:: JSON.Object
-> JSON.Parser CliEntryMetadata
cliArgParser object =
Arg
<$> (object .:? "metavar")
<*> (fromMaybe True <$> (object .:? "required"))
<*> cliArgTypeParser object
cliOptTypeParser
:: JSON.Object
-> JSON.Parser CliOptValueType
cliOptTypeParser object = do
mvalue <- object .:? "type"
case mvalue of
Just value@(JSON.String typeName)
| typeName == "string" ->
return StringOpt
| typeName == "number" ->
return NumberOpt
| typeName == "switch" ->
return SwitchOpt
| otherwise ->
JSON.typeMismatch "CliOptValueType (string, number, switch)" value
Just value ->
JSON.typeMismatch "CliOptValueType" value
Nothing ->
fail "CLI Option type is required"
cliOptParser
:: JSON.Object
-> JSON.Parser CliEntryMetadata
cliOptParser object = do
long <- object .:? "long"
short <- object .:? "short"
if isNothing long && isNothing short then
fail "'option' field input requires either 'long' or 'short' settings"
else
Opt
<$> pure long
<*> pure short
<*> (object .:? "metavar")
<*> (object .:? "help")
<*> (fromMaybe True <$> (object .:? "required"))
<*> cliOptTypeParser object
cliArgKeys :: [Text]
cliArgKeys = ["input", "commands", "metavar", "required", "type"]
cliOptKeys :: [Text]
cliOptKeys = ["short", "long", "help"] ++ cliArgKeys
instance JSON.FromJSON cmd => JSON.FromJSON (CliEntrySpec cmd) where
parseJSON json =
case json of
JSON.Object object -> do
cmdValue <- object .:? "commands"
value <- object .: "input"
let
optParseEntryCtor =
maybe PlainEntry CmdEntry cmdValue
case value of
JSON.String inputName
| inputName == "option" -> do
forM_ (HashMap.keys object) $ \key ->
when (not (key `elem` cliOptKeys))
(fail $ "cli option contains invalid key " ++ show key)
optParseEntryCtor <$> cliOptParser object
| inputName == "argument" -> do
forM_ (HashMap.keys object) $ \key ->
when (not (key `elem` cliArgKeys))
(fail $ "cli option contains invalid key " ++ show key)
optParseEntryCtor <$> cliArgParser object
| otherwise ->
JSON.typeMismatch "CliEntryMetadata (invalid input)" value
_ ->
JSON.typeMismatch "CliEntryMetadata (invalid input)" value
_ ->
JSON.typeMismatch "CliEntryMetadata" json
instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where
parseJSON json =
case json of
JSON.Array _ ->
fail "Entries cannot have arrays as values"
JSON.Object object ->
case HashMap.lookup "etc/spec" object of
Nothing -> do
result <- foldM
(\result (key, value) -> do
innerValue <- JSON.parseJSON value
return $ HashMap.insert key innerValue result)
HashMap.empty
(HashMap.toList object)
if HashMap.null result then
fail "Entries cannot have empty maps as values"
else
return (SubConfig result)
Just (JSON.Object spec) ->
if HashMap.size object == 1 then
ConfigValue
<$> spec .:? "default"
<*> (ConfigSources <$> (spec .:? "env")
<*> (spec .:? "cli"))
else
fail "etc/spec object can only contain one key"
Just _ ->
fail "etc/spec value must be a JSON object"
_ ->
return $
ConfigValue (Just json) (ConfigSources Nothing Nothing)
instance JSON.FromJSON cmd => JSON.FromJSON (ConfigSpec cmd) where
parseJSON json =
case json of
JSON.Object object ->
ConfigSpec
<$> (fromMaybe [] <$> (object .:? "etc/filepaths"))
<*> (object .:? "etc/cli")
<*> (fromMaybe HashMap.empty <$> (object .:? "etc/entries"))
_ ->
JSON.typeMismatch "ConfigSpec" json