{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Etc.Internal.Spec.Parser where
import RIO
import qualified RIO.HashMap as HashMap
import qualified RIO.Text as Text
import Prelude (fail)
import qualified RIO.Vector.Partial as Vector (head)
import Data.Aeson ((.:), (.:?))
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON (Parser, typeMismatch)
import System.Etc.Internal.Errors
import System.Etc.Internal.Spec.Types
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
<$> ( CliArgMetadata
<$> (object .:? "metavar")
<*> (object .:? "help")
<*> (fromMaybe True <$> (object .:? "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
<$> ( CliOptMetadata
<$> pure long
<*> pure short
<*> (object .:? "metavar")
<*> (object .:? "help")
<*> (fromMaybe True <$> (object .:? "required"))
)
cliSwitchParser :: JSON.Object -> JSON.Parser CliEntryMetadata
cliSwitchParser object =
Switch <$> (CliSwitchMetadata <$> (object .: "long") <*> (object .:? "help"))
cliArgKeys :: [Text]
cliArgKeys = ["input", "commands", "metavar", "required"]
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
| inputName == "switch" -> do
forM_ (HashMap.keys object) $ \key ->
when (not (key `elem` cliOptKeys))
(fail $ "cli option contains invalid key " ++ show key)
optParseEntryCtor <$> cliSwitchParser object
| otherwise ->
JSON.typeMismatch "Invalid input (option, argument, switch)" value
_ ->
JSON.typeMismatch "Invalid input (option, argument, switch)" value
_ ->
JSON.typeMismatch "Invalid input (option, argument, switch)" json
instance JSON.FromJSON ConfigValueType where
parseJSON = JSON.withText "ConfigValueType (string, number, bool)" $ \tyText ->
case Text.toLower tyText of
"string" -> pure $ CVTSingle CVTString
"number" -> pure $ CVTSingle CVTNumber
"bool" -> pure $ CVTSingle CVTBool
"[string]" -> pure $ CVTArray CVTString
"[number]" -> pure $ CVTArray CVTNumber
"[bool]" -> pure $ CVTArray CVTBool
"[object]" -> pure $ CVTArray CVTObject
_ -> JSON.typeMismatch "ConfigValueType (string, number, bool)" (JSON.String tyText)
inferErrorMsg :: String
inferErrorMsg = "could not infer type from given default value"
parseBytesToConfigValueJSON :: ConfigValueType -> Text -> Maybe JSON.Value
parseBytesToConfigValueJSON cvType content =
case JSON.eitherDecodeStrict' (Text.encodeUtf8 content) of
Right value | matchesConfigValueType value cvType -> return value
| otherwise -> Nothing
Left _err
| matchesConfigValueType (JSON.String content) cvType -> return (JSON.String content)
| otherwise -> Nothing
jsonToConfigValueType :: JSON.Value -> Either String ConfigValueType
jsonToConfigValueType json = case json of
JSON.String{} -> Right $ CVTSingle CVTString
JSON.Number{} -> Right $ CVTSingle CVTNumber
JSON.Bool{} -> Right $ CVTSingle CVTBool
JSON.Array arr
| null arr -> Left inferErrorMsg
| otherwise -> case jsonToConfigValueType (Vector.head arr) of
Right CVTArray{} -> Left "nested arrays values are not supported"
Right (CVTSingle ty) -> Right $ CVTArray ty
Left err -> Left err
_ -> Left inferErrorMsg
coerceConfigValueType :: Text -> JSON.Value -> ConfigValueType -> Maybe JSON.Value
coerceConfigValueType rawValue json cvType = case (json, cvType) of
(JSON.Null , CVTSingle _ ) -> Just JSON.Null
(JSON.String{}, CVTSingle CVTString) -> Just json
(JSON.Number{}, CVTSingle CVTNumber) -> Just json
(JSON.Bool{} , CVTSingle CVTBool ) -> Just json
(JSON.Object{}, CVTSingle CVTObject) -> Just json
(JSON.Array{} , CVTArray{} ) -> Just json
(JSON.Number{}, CVTSingle CVTString) -> Just (JSON.String rawValue)
(JSON.Bool{} , CVTSingle CVTString) -> Just (JSON.String rawValue)
_ -> Nothing
matchesConfigValueType :: JSON.Value -> ConfigValueType -> Bool
matchesConfigValueType json cvType = case (json, cvType) of
(JSON.Null , CVTSingle _ ) -> True
(JSON.String{}, CVTSingle CVTString) -> True
(JSON.Number{}, CVTSingle CVTNumber) -> True
(JSON.Bool{} , CVTSingle CVTBool ) -> True
(JSON.Object{}, CVTSingle CVTObject) -> True
(JSON.Array arr, CVTArray inner) ->
if null arr then True else all (`matchesConfigValueType` CVTSingle inner) arr
_ -> False
assertMatchingConfigValueType :: JSON.Value -> ConfigValueType -> Either SomeException ()
assertMatchingConfigValueType json cvType
| matchesConfigValueType json cvType = Right ()
| otherwise = Left $ toException $ ConfigValueTypeMismatchFound "" json cvType
getConfigValueType
:: Maybe JSON.Value -> Maybe ConfigValueType -> JSON.Parser ConfigValueType
getConfigValueType mdefValue mCvType = case (mdefValue, mCvType) of
(Just JSON.Null, Just cvType) -> pure cvType
(Just defValue , Just cvType) -> do
either (fail . show) return $ assertMatchingConfigValueType defValue cvType
return cvType
(Nothing , Just cvType) -> pure cvType
(Just defValue, Nothing ) -> either fail pure $ jsonToConfigValueType defValue
(Nothing , Nothing ) -> fail inferErrorMsg
instance JSON.FromJSON cmd => JSON.FromJSON (ConfigValue cmd) where
parseJSON json =
case json of
JSON.Object object ->
case HashMap.lookup "etc/spec" object of
Nothing -> do
subConfigMap <- foldM
(\subConfigMap (key, value) -> do
innerValue <- JSON.parseJSON value
return $ HashMap.insert key innerValue subConfigMap)
HashMap.empty
(HashMap.toList object)
if HashMap.null subConfigMap then
fail "Entries cannot have empty maps as values"
else
return (SubConfig subConfigMap)
Just (JSON.Object fieldSpec) ->
if HashMap.size object == 1 then do
let mDefaultValue = maybe Nothing Just $ HashMap.lookup "default" fieldSpec
mSensitive <- fieldSpec .:? "sensitive"
mCvType <- fieldSpec .:? "type"
let sensitive = fromMaybe False mSensitive
ConfigValue
<$> pure mDefaultValue
<*> getConfigValueType mDefaultValue mCvType
<*> pure sensitive
<*> (ConfigSources <$> fieldSpec .:? "env"
<*> fieldSpec .:? "cli")
else
fail "etc/spec object can only contain one key"
Just _ ->
fail "etc/spec value must be a JSON object"
_ -> do
cvType <- either fail pure $ jsonToConfigValueType json
return
ConfigValue
{
defaultValue = Just json
, configValueType = cvType
, isSensitive = False
, configSources = ConfigSources Nothing Nothing
}
parseFiles :: JSON.Value -> JSON.Parser FilesSpec
parseFiles = JSON.withObject "FilesSpec" $ \object -> do
files <- object .: "etc/files"
mEnv <- files .:? "env"
mPaths <- files .:? "paths"
if isNothing mEnv && isNothing mPaths
then fail "either `env` or a `paths` keys are required when using `etc/files`"
else return $ FilesSpec mEnv (fromMaybe [] mPaths)
parseFilePaths :: JSON.Value -> JSON.Parser FilesSpec
parseFilePaths =
JSON.withObject "FilesSpec" $ \object -> FilePathsSpec <$> object .: "etc/filepaths"
parseFileSpec :: JSON.Value -> JSON.Parser (Maybe FilesSpec)
parseFileSpec json@(JSON.Object object) = do
mFiles <- object .:? "etc/files"
mFilePaths <- object .:? "etc/filepaths"
if isJust (mFiles :: Maybe JSON.Value) && isJust (mFilePaths :: Maybe JSON.Value)
then fail "either the `etc/files` or `etc/filepaths` key can be used; not both"
else if isJust mFiles
then Just <$> parseFiles json
else if isJust mFilePaths then Just <$> parseFilePaths json else pure Nothing
parseFileSpec _ = pure Nothing
instance JSON.FromJSON cmd => JSON.FromJSON (ConfigSpec cmd) where
parseJSON json =
case json of
JSON.Object object ->
ConfigSpec
<$> parseFileSpec json
<*> (object .:? "etc/cli")
<*> (fromMaybe HashMap.empty <$> (object .:? "etc/entries"))
_ ->
JSON.typeMismatch "ConfigSpec" json