diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,17 @@ +0.2.8 +===== + +* Added validation funcitons for Boolean values, numberic values and + orders. + +* Added operator `!..:` for parsing of configuration values that are + required to be present in a configuration file, thus preventing + the default value from being used. + +* More consistent usage of case in metavar values. + +* Drop support for optparse-applicative < 0.10. + 0.2.7 ===== diff --git a/configuration-tools.cabal b/configuration-tools.cabal --- a/configuration-tools.cabal +++ b/configuration-tools.cabal @@ -3,7 +3,7 @@ -- ------------------------------------------------------ -- Name: configuration-tools -Version: 0.2.7 +Version: 0.2.8 Synopsis: Tools for specifying and parsing configurations description: Tools for specifying and parsing configurations @@ -54,7 +54,7 @@ source-repository this type: git location: https://github.com/alephcloud/hs-configuration-tools.git - tag: 0.2.7 + tag: 0.2.8 Library hs-source-dirs: src @@ -83,7 +83,7 @@ errors >= 1.4.3, mtl >= 2.2, network-uri >= 2.6.0.1, - optparse-applicative >= 0.8.1, + optparse-applicative >= 0.10, process >= 1.2.0.0, text >= 1.0, transformers >= 0.3.0.0, diff --git a/constraints b/constraints --- a/constraints +++ b/constraints @@ -1,37 +1,39 @@ -constraints: Cabal ==1.20.0.2, +constraints: Cabal ==1.22.0.0, MonadRandom ==0.3, - aeson ==0.8.0.0, - ansi-terminal ==0.6.1.1, + aeson ==0.8.0.2, + ansi-terminal ==0.6.2.1, ansi-wl-pprint ==0.6.7.1, array ==0.5.0.0, - attoparsec ==0.12.1.0, + async ==2.0.1.6, + attoparsec ==0.12.1.2, base ==4.7.0.1, base-unicode-symbols ==0.2.2.4, bifunctors ==4.1.1.1, + binary ==0.7.1.0, bytestring ==0.10.4.0, - case-insensitive ==1.2.0.0, + case-insensitive ==1.2.0.3, comonad ==4.2.2, - conduit ==1.2.0.2, - configuration-tools ==0.2.7, + conduit ==1.2.3.1, containers ==0.5.5.1, - contravariant ==1.2, + contravariant ==1.2.0.1, deepseq ==1.3.0.2, directory ==1.2.1.0, distributive ==0.4.4, dlist ==0.7.1, - either ==4.3.1, + either ==4.3.2.1, + enclosed-exceptions ==1.0.1, errors ==1.4.7, exceptions ==0.6.1, filepath ==1.3.0.2, - free ==4.9, + free ==4.10.0.1, ghc-prim ==0.3.1.0, - hashable ==1.2.2.0, + hashable ==1.2.3.1, integer-gmp ==0.5.1.0, - lifted-base ==0.2.3.0, + lifted-base ==0.2.3.3, mmorph ==1.0.4, - monad-control ==0.3.3.0, + monad-control ==1.0.0.1, mtl ==2.2.1, - nats ==0.2, + nats ==1, network-uri ==2.6.0.1, old-locale ==1.0.0.6, optparse-applicative ==0.11.0.1, @@ -40,25 +42,25 @@ pretty ==1.1.1.1, primitive ==0.5.3.0, process ==1.2.0.0, - profunctors ==4.2.0.1, + profunctors ==4.3.2, random ==1.0.1.1, - resourcet ==1.1.2.3, + resourcet ==1.1.3.3, rts ==1.0, safe ==0.3.6, - scientific ==0.3.3.0, + scientific ==0.3.3.5, semigroupoids ==4.2, - semigroups ==0.15.3, + semigroups ==0.16.0.1, stm ==2.4.3, syb ==0.4.2, tagged ==0.7.2, template-haskell ==2.9.0.0, - text ==1.1.1.3, + text ==1.2.0.3, time ==1.4.2, transformers ==0.4.1.0, transformers-base ==0.4.3, transformers-compat ==0.3.3.4, unix ==2.7.0.1, - unordered-containers ==0.2.5.0, + unordered-containers ==0.2.5.1, vector ==0.10.11.0, - void ==0.6.1, - yaml ==0.8.9.1 + void ==0.7, + yaml ==0.8.10.1 diff --git a/src/Configuration/Utils.hs b/src/Configuration/Utils.hs --- a/src/Configuration/Utils.hs +++ b/src/Configuration/Utils.hs @@ -9,7 +9,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK show-extensions #-} @@ -75,6 +74,7 @@ , runWithConfiguration , PkgInfo , runWithPkgInfoConfiguration +, parseConfiguration -- * Applicative Option Parsing with Default Values , MParser @@ -89,6 +89,7 @@ -- * Parsing of Configuration Files with Default Values , setProperty , (..:) +, (!..:) , (%.:) , module Data.Aeson @@ -136,11 +137,7 @@ import qualified Data.Text.IO as T import qualified Data.Yaml as Yaml -#if MIN_VERSION_optparse_applicative(0,10,0) import Options.Applicative hiding (Parser, Success) -#else -import Options.Applicative hiding (Parser, Success, (&)) -#endif import qualified Options.Applicative as O @@ -155,9 +152,9 @@ -- -------------------------------------------------------------------------- -- -- Useful Operators --- | This operator is an alternative for '$' with a higher precedence which --- makes it suitable for usage within Applicative style funtors without the need --- to add parenthesis. +-- | This operator is an alternative for '$' with a higher precedence. It is +-- suitable for usage within applicative style code without the need to add +-- parenthesis. -- (%) ∷ (α → β) → α → β (%) = ($) @@ -165,8 +162,8 @@ {-# INLINE (%) #-} -- | This operator is a UTF-8 version of '%' which is an alternative for '$' --- with a higher precedence which makes it suitable for usage within Applicative --- style funtors without the need to add parenthesis. +-- with a higher precedence. It is suitable for usage within applicative style +-- code without the need to add parenthesis. -- -- The hex value of the UTF-8 character × is 0x00d7. -- @@ -420,6 +417,19 @@ infix 6 %.: {-# INLINE (%.:) #-} +-- | This operator requires that a value is explicitly provided in a +-- configuration file, thus preventing the default value from being used. +-- Otherwise this operator does the same as '(..:)'. +-- +(!..:) + ∷ FromJSON β + ⇒ Lens' α β + → T.Text + → Object + → Parser (α → α) +(!..:) l property o = set l <$> (o .: property) +{-# INLINE (!..:) #-} + -- -------------------------------------------------------------------------- -- -- Command Line Option Parsing @@ -433,21 +443,24 @@ _ → Left $ "failed to read Boolean value " <> fromString (show x) <> ". Expected either \"true\" or \"false\"" +-- | The 'boolOption' is an alternative to 'O.switch'. +-- +-- Using 'O.switch' with command line parsers that overwrite settings +-- from a configuration file is problematic: the absence of the 'switch' +-- is interpreted as setting the respective configuration value to 'False'. +-- So there is no way to specify on the command line that the value from +-- the configuration file shall be used. Some command line UIs use two +-- different options for those values, for instance @--enable-feature@ and +-- @--disable-feature@. This option instead expects a Boolean value. Beside +-- that it behaves like any other option. +-- boolOption ∷ O.Mod O.OptionFields Bool → O.Parser Bool -#if MIN_VERSION_optparse_applicative(0,10,0) boolOption mods = O.option (O.eitherReader boolReader) - % O.metavar "TRUE|FALSE" + % O.metavar "true|false" <> O.completeWith ["true", "false", "TRUE", "FALSE", "True", "False"] <> mods -#else -boolOption mods = O.nullOption - % metavar "TRUE|FALSE" - <> O.completeWith ["true", "false", "TRUE", "FALSE", "True", "False"] - <> O.eitherReader boolReader - <> mods -#endif fileOption ∷ O.Mod O.OptionFields String @@ -477,7 +490,7 @@ type ConfigValidation α λ = (MonadIO μ, Functor μ, Applicative μ, MonadError T.Text μ, MonadWriter (λ T.Text) μ) ⇒ α → μ () -- | A newtype wrapper around a validation function. The only purpose of --- this type is to avoid ImpredicativeTypes when storing the function +-- this type is to avoid @ImpredicativeTypes@ when storing the function -- in the 'ProgramInfoValidate' record. -- newtype ConfigValidationFunction α λ = ConfigValidationFunction @@ -494,7 +507,7 @@ , _piHelpFooter ∷ !(Maybe String) -- ^ Help footer , _piOptionParser ∷ !(MParser α) - -- ^ options parser for configuration (TODO consider using a typeclass for this) + -- ^ options parser for configuration , _piDefaultConfiguration ∷ !α -- ^ default configuration , _piValidateConfiguration ∷ !(ConfigValidationFunction α λ) @@ -520,13 +533,13 @@ piHelpFooter = lens _piHelpFooter $ \s a → s { _piHelpFooter = a } {-# INLINE piHelpFooter #-} --- | options parser for configuration (TODO consider using a typeclass for this) +-- | Options parser for configuration -- piOptionParser ∷ Lens' (ProgramInfoValidate α λ) (MParser α) piOptionParser = lens _piOptionParser $ \s a → s { _piOptionParser = a } {-# INLINE piOptionParser #-} --- | default configuration +-- | Default configuration -- piDefaultConfiguration ∷ Lens' (ProgramInfoValidate α λ) α piDefaultConfiguration = lens _piDefaultConfiguration $ \s a → s { _piDefaultConfiguration = a } @@ -569,8 +582,11 @@ -- programInfo ∷ String + -- ^ program description → MParser α + -- ^ parser for updating the default configuration → α + -- ^ default configuration → ProgramInfo α programInfo desc parser defaultConfig = programInfoValidate desc parser defaultConfig $ const (return ()) @@ -618,22 +634,12 @@ ⊕ O.short 'p' ⊕ O.help "Print the parsed configuration to standard out and exit" ⊕ O.showDefault -#if MIN_VERSION_optparse_applicative(0,10,0) <*> O.option (O.eitherReader $ \file → fileReader file <*> pure d) × O.long "config-file" ⊕ O.short 'c' ⊕ O.metavar "FILE" ⊕ O.help "Configuration file in YAML format" ⊕ O.value d -#else - <*> O.nullOption - × O.long "config-file" - ⊕ O.short 'c' - ⊕ O.metavar "FILE" - ⊕ O.help "Configuration file in YAML format" - ⊕ O.eitherReader (\file → fileReader file <*> pure d) - ⊕ O.value d -#endif where fileReader file = fmapL (\e → "failed to parse configuration file " ⊕ file ⊕ ": " ⊕ show e) $ unsafePerformIO (Yaml.decodeFileEither file) @@ -681,7 +687,11 @@ runWithConfiguration ∷ (FromJSON (α → α), ToJSON α, Foldable λ, Monoid (λ T.Text)) ⇒ ProgramInfoValidate α λ + -- ^ program info value; use 'programInfo' to construct a value of this + -- type → (α → IO ()) + -- ^ computation that is given the configuration that is parsed from + -- the command line. → IO () runWithConfiguration appInfo mainFunction = do conf ← O.customExecParser parserPrefs mainOpts @@ -693,6 +703,43 @@ mainOpts = mainOptions appInfo Nothing parserPrefs = O.prefs O.disambiguate +-- | Parse the command line arguments. +-- +-- Any warnings from the configuration function are discarded. +-- The options @--print-config@ and @--help@ are just ignored. +-- +-- NOTE this that this function may call 'unsafePerformIO' for +-- reading configuration files. +-- +parseConfiguration + ∷ + ( Applicative m + , MonadIO m + , MonadError T.Text m + , FromJSON (α → α) + , ToJSON α + , Foldable λ + , Monoid (λ T.Text) + ) + ⇒ T.Text + -- ^ program name (used in error messages) + → ProgramInfoValidate α λ + -- ^ program info value; use 'programInfo' to construct a value of this + -- type + → [String] + -- ^ command line arguments + → m α +parseConfiguration appName appInfo args = do + case O.execParserPure parserPrefs mainOpts args of + O.Success a → validate (_mainConfig a) >> return (_mainConfig a) + O.Failure e → throwError ∘ T.pack ∘ fst $ renderFailure e (T.unpack appName) + O.CompletionInvoked _ → throwError "command line parser returned completion result" + where + mainOpts = mainOptions appInfo Nothing + parserPrefs = O.prefs O.disambiguate + validate conf = runWriterT $ do + runConfigValidation (view piValidateConfiguration appInfo) conf + -- | Validates a configuration value. Throws an user error -- if there is an error. If there are warnings they are -- printed to 'stderr'. @@ -703,7 +750,7 @@ → α → IO () validateConfig appInfo conf = do - warnings ← execWriterT . exceptT (error . T.unpack) return $ do + warnings ← execWriterT ∘ exceptT (error ∘ T.unpack) return $ do runConfigValidation (view piValidateConfiguration appInfo) conf when (any (const True) warnings) $ do T.hPutStrLn stderr "WARNINGS:" @@ -793,8 +840,17 @@ runWithPkgInfoConfiguration ∷ (FromJSON (α → α), ToJSON α, Foldable λ, Monoid (λ T.Text)) ⇒ ProgramInfoValidate α λ + -- ^ program info value; use 'programInfo' to construct a value of this + -- type → PkgInfo + -- 'PkgInfo' value that contain information about the package. + -- + -- See the documentation of "Configuration.Utils.Setup" for a way + -- how to generate this information automatically from the package + -- description during the build process. → (α → IO ()) + -- ^ computation that is given the configuration that is parsed from + -- the command line. → IO () runWithPkgInfoConfiguration appInfo pkgInfo mainFunction = do conf ← O.customExecParser parserPrefs mainOpts diff --git a/src/Configuration/Utils/Http.hs b/src/Configuration/Utils/Http.hs --- a/src/Configuration/Utils/Http.hs +++ b/src/Configuration/Utils/Http.hs @@ -200,18 +200,10 @@ <$< hscHost ∘ bs .:: strOption × long (prefix ⊕ "host") ⊕ help "Hostname of the service" -#if MIN_VERSION_optparse_applicative(0,10,0) <*< hscPort .:: option auto -#else - <*< hscPort .:: option -#endif × long (prefix ⊕ "port") ⊕ help "Port of the service" -#if MIN_VERSION_optparse_applicative(0,10,0) <*< hscInterface ∘ bs .:: option auto -#else - <*< hscInterface ∘ bs .:: option -#endif × long (prefix ⊕ "interface") ⊕ help "Interface of the service" <*< (hscUseTLS %:: (fmap <$> pHttpServiceTLSConfiguration prefix)) @@ -271,11 +263,7 @@ <$< hccHost ∘ bs .:: strOption × long (serviceName ⊕ "-host") ⊕ help ("Hostname of " ⊕ serviceName) -#if MIN_VERSION_optparse_applicative(0,10,0) <*< hccPort .:: option auto -#else - <*< hccPort .:: option -#endif × long (serviceName ⊕ "-port") ⊕ help ("Port of " ⊕ serviceName) <*< hccUseTLS .:: switch diff --git a/src/Configuration/Utils/Validation.hs b/src/Configuration/Utils/Validation.hs --- a/src/Configuration/Utils/Validation.hs +++ b/src/Configuration/Utils/Validation.hs @@ -41,6 +41,25 @@ , validateFileWritable , validateExecutable , validateDirectory + +-- * Boolean Values +, validateFalse +, validateTrue +, validateBool + +-- * Numeric Values +, validateNonNegative +, validatePositive +, validateNonPositive +, validateNegative +, validateNonNull + +-- * Orders +, validateLess +, validateLessEq +, validateGreater +, validateGreaterEq +, validateRange ) where import Configuration.Utils @@ -299,4 +318,134 @@ ⊕ " you may check your SearchPath and PATH variable settings" Just f → return f validateFileExecutable configName execFile + +-- -------------------------------------------------------------------------- -- +-- Boolean Values + +validateFalse + ∷ (MonadError T.Text m) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → Bool + → m () +validateFalse configName = validateBool configName False + +validateTrue + ∷ (MonadError T.Text m) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → Bool + → m () +validateTrue configName = validateBool configName True + +validateBool + ∷ (MonadError T.Text m) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → Bool + -- ^ expected value + → Bool + → m () +validateBool configName expected x = unless (x ≡ expected) ∘ throwError $ + "expected " ⊕ configName ⊕ " to be " ⊕ sshow expected ⊕ ", but was " ⊕ sshow x + +-- -------------------------------------------------------------------------- -- +-- Numeric Values + +validateNonNegative + ∷ (Ord α, Num α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → ConfigValidation α λ +validateNonNegative configName x = + when (x < 0) ∘ throwError $ + "value for " ⊕ configName ⊕ " must not be negative" + +validatePositive + ∷ (Ord α, Num α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → ConfigValidation α λ +validatePositive configName x = + when (x ≤ 0) ∘ throwError $ + "value for " ⊕ configName ⊕ " must be positive" + +validateNonPositive + ∷ (Ord α, Num α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → ConfigValidation α λ +validateNonPositive configName x = + when (x > 0) ∘ throwError $ + "value for " ⊕ configName ⊕ " must not be positive" + +validateNegative + ∷ (Ord α, Num α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → ConfigValidation α λ +validateNegative configName x = + when (x ≥ 0) ∘ throwError $ + "value for " ⊕ configName ⊕ " must be negative" + +validateNonNull + ∷ (Eq α, Num α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → ConfigValidation α λ +validateNonNull configName x = when (x ≡ 0) ∘ throwError $ + "value for " ⊕ configName ⊕ " must not be zero" + +-- -------------------------------------------------------------------------- -- +-- Orders + +validateLess + ∷ (Ord α, Show α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → α + -- ^ a strict upper bound for the configuration value + → ConfigValidation α λ +validateLess configName upper x = unless (x < upper) ∘ throwError $ + "value for " ⊕ configName ⊕ " must be strictly less than " ⊕ sshow upper ⊕ ", but was " ⊕ sshow x + +validateLessEq + ∷ (Ord α, Show α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → α + -- ^ a upper bound for the configuration value + → ConfigValidation α λ +validateLessEq configName upper x = unless (x ≤ upper) ∘ throwError $ + "value for " ⊕ configName ⊕ " must be less or equal than " ⊕ sshow upper ⊕ ", but was " ⊕ sshow x + +validateGreater + ∷ (Ord α, Show α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → α + -- ^ a strict lower bound for the configuration value + → ConfigValidation α λ +validateGreater configName lower x = unless (x > lower) ∘ throwError $ + "value for " ⊕ configName ⊕ " must be strictly greater than " ⊕ sshow lower ⊕ ", but was " ⊕ sshow x + +validateGreaterEq + ∷ (Ord α, Show α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → α + -- ^ a lower bound for the configuration value + → ConfigValidation α λ +validateGreaterEq configName lower x = unless (x ≥ lower) ∘ throwError $ + "value for " ⊕ configName ⊕ " must be greater or equal than " ⊕ sshow lower ⊕ ", but was " ⊕ sshow x + +validateRange + ∷ (Ord α, Show α) + ⇒ T.Text + -- ^ configuration property name that is used in the error message + → (α, α) + -- ^ the valid range for the configuration value + → ConfigValidation α λ +validateRange configName (lower,upper) x = unless (x ≥ lower ∧ x ≤ upper) ∘ throwError $ + "value for " ⊕ configName ⊕ " must be within the range of (" ⊕ sshow lower ⊕ ", " ⊕ sshow upper ⊕ "), but was " ⊕ sshow x