configuration-tools 0.7.0 → 0.7.1
raw patch · 10 files changed
+165/−88 lines, 10 filessetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Configuration.Utils: data ProgramInfoValidate a f
- Configuration.Utils: type ConfigValidation a f = forall m. (MonadIO m, Functor m, Applicative m, MonadError Text m, MonadWriter (f Text) m) => a -> m ()
+ Configuration.Utils: instance GHC.Base.Functor Configuration.Utils.AppConfiguration
+ Configuration.Utils: type ConfigValidation a f = ConfigValidation' a f ()
+ Configuration.Utils: type ProgramInfoValidate a f = ProgramInfoValidate' a f a
+ Configuration.Utils.Internal: type Setter s t a b = (a -> Identity b) -> s -> Identity t
+ Configuration.Utils.Internal: type Setter' s a = Setter s s a a
+ Configuration.Utils.Validation: type ConfigValidation a f = ConfigValidation' a f ()
- Configuration.Utils: ConfigValidationFunction :: ConfigValidation a f -> ConfigValidationFunction a f
+ Configuration.Utils: ConfigValidationFunction :: ConfigValidation' a f r -> ConfigValidationFunction a f r
- Configuration.Utils: [runConfigValidation] :: ConfigValidationFunction a f -> ConfigValidation a f
+ Configuration.Utils: [runConfigValidation] :: ConfigValidationFunction a f r -> ConfigValidation' a f r
- Configuration.Utils: newtype ConfigValidationFunction a f
+ Configuration.Utils: newtype ConfigValidationFunction a f r
- Configuration.Utils: parseConfiguration :: (Applicative m, MonadIO m, MonadError Text m, FromJSON (a -> a), ToJSON a, Foldable f, Monoid (f Text)) => Text -> ProgramInfoValidate a f -> [String] -> m a
+ Configuration.Utils: parseConfiguration :: (Applicative m, MonadIO m, MonadError Text m, FromJSON (a -> a), ToJSON a, Foldable f, Monoid (f Text)) => Text -> ProgramInfoValidate' a f r -> [String] -> m a
- Configuration.Utils: piDefaultConfiguration :: Lens' (ProgramInfoValidate a f) a
+ Configuration.Utils: piDefaultConfiguration :: Lens' (ProgramInfoValidate' a f r) a
- Configuration.Utils: piDescription :: Lens' (ProgramInfoValidate a f) String
+ Configuration.Utils: piDescription :: Lens' (ProgramInfoValidate' a f r) String
- Configuration.Utils: piHelpFooter :: Lens' (ProgramInfoValidate a f) (Maybe String)
+ Configuration.Utils: piHelpFooter :: Lens' (ProgramInfoValidate' a f r) (Maybe String)
- Configuration.Utils: piHelpHeader :: Lens' (ProgramInfoValidate a f) (Maybe String)
+ Configuration.Utils: piHelpHeader :: Lens' (ProgramInfoValidate' a f r) (Maybe String)
- Configuration.Utils: piOptionParser :: Lens' (ProgramInfoValidate a f) (MParser a)
+ Configuration.Utils: piOptionParser :: Lens' (ProgramInfoValidate' a f r) (MParser a)
- Configuration.Utils: piOptionParserAndDefaultConfiguration :: Lens (ProgramInfoValidate a b) (ProgramInfoValidate c d) (MParser a, a, ConfigValidationFunction a b) (MParser c, c, ConfigValidationFunction c d)
+ Configuration.Utils: piOptionParserAndDefaultConfiguration :: Lens (ProgramInfoValidate' a b r) (ProgramInfoValidate' c d r') (MParser a, a, ConfigValidationFunction a b r) (MParser c, c, ConfigValidationFunction c d r')
- Configuration.Utils: piValidateConfiguration :: Lens' (ProgramInfoValidate a f) (ConfigValidationFunction a f)
+ Configuration.Utils: piValidateConfiguration :: Lens' (ProgramInfoValidate' a f r) (ConfigValidationFunction a f r)
- Configuration.Utils: runWithConfiguration :: (FromJSON (a -> a), ToJSON a, Foldable f, Monoid (f Text)) => ProgramInfoValidate a f -> (a -> IO ()) -> IO ()
+ Configuration.Utils: runWithConfiguration :: (FromJSON (a -> a), ToJSON a, Foldable f, Monoid (f Text)) => ProgramInfoValidate' a f r -> (r -> IO ()) -> IO ()
- Configuration.Utils.CommandLine: class HasCompleter (f :: Type -> Type)
+ Configuration.Utils.CommandLine: class () => HasCompleter (f :: Type -> Type)
- Configuration.Utils.CommandLine: class HasMetavar (f :: Type -> Type)
+ Configuration.Utils.CommandLine: class () => HasMetavar (f :: Type -> Type)
- Configuration.Utils.CommandLine: class HasName (f :: Type -> Type)
+ Configuration.Utils.CommandLine: class () => HasName (f :: Type -> Type)
- Configuration.Utils.CommandLine: class HasValue (f :: Type -> Type)
+ Configuration.Utils.CommandLine: class () => HasValue (f :: Type -> Type)
- Configuration.Utils.CommandLine: data ArgumentFields a
+ Configuration.Utils.CommandLine: data () => ArgumentFields a
- Configuration.Utils.CommandLine: data CommandFields a
+ Configuration.Utils.CommandLine: data () => CommandFields a
- Configuration.Utils.CommandLine: data Completer
+ Configuration.Utils.CommandLine: data () => Completer
- Configuration.Utils.CommandLine: data FlagFields a
+ Configuration.Utils.CommandLine: data () => FlagFields a
- Configuration.Utils.CommandLine: data InfoMod a
+ Configuration.Utils.CommandLine: data () => InfoMod a
- Configuration.Utils.CommandLine: data Mod (f :: Type -> Type) a
+ Configuration.Utils.CommandLine: data () => Mod (f :: Type -> Type) a
- Configuration.Utils.CommandLine: data OptionFields a
+ Configuration.Utils.CommandLine: data () => OptionFields a
- Configuration.Utils.CommandLine: data ParseError
+ Configuration.Utils.CommandLine: data () => ParseError
- Configuration.Utils.CommandLine: data ParserHelp
+ Configuration.Utils.CommandLine: data () => ParserHelp
- Configuration.Utils.CommandLine: data ParserInfo a
+ Configuration.Utils.CommandLine: data () => ParserInfo a
- Configuration.Utils.CommandLine: data ParserPrefs
+ Configuration.Utils.CommandLine: data () => ParserPrefs
- Configuration.Utils.CommandLine: data ParserResult a
+ Configuration.Utils.CommandLine: data () => ParserResult a
- Configuration.Utils.CommandLine: data PrefsMod
+ Configuration.Utils.CommandLine: data () => PrefsMod
- Configuration.Utils.CommandLine: data ReadM a
+ Configuration.Utils.CommandLine: data () => ReadM a
- Configuration.Utils.CommandLine: newtype CompletionResult
+ Configuration.Utils.CommandLine: newtype () => CompletionResult
- Configuration.Utils.CommandLine: newtype Const a (b :: k)
+ Configuration.Utils.CommandLine: newtype () => Const a (b :: k)
- Configuration.Utils.CommandLine: newtype ParserFailure h
+ Configuration.Utils.CommandLine: newtype () => ParserFailure h
- Configuration.Utils.CommandLine: newtype WrappedArrow (a :: Type -> Type -> Type) b c
+ Configuration.Utils.CommandLine: newtype () => WrappedArrow (a :: Type -> Type -> Type) b c
- Configuration.Utils.CommandLine: newtype WrappedMonad (m :: Type -> Type) a
+ Configuration.Utils.CommandLine: newtype () => WrappedMonad (m :: Type -> Type) a
- Configuration.Utils.CommandLine: newtype ZipList a
+ Configuration.Utils.CommandLine: newtype () => ZipList a
- Configuration.Utils.ConfigFile: (%.:) :: FromJSON (b -> b) => Lens' a b -> Text -> Object -> Parser (a -> a)
+ Configuration.Utils.ConfigFile: (%.:) :: FromJSON (b -> b) => Setter' a b -> Text -> Object -> Parser (a -> a)
- Configuration.Utils.ConfigFile: (..:) :: FromJSON b => Lens' a b -> Text -> Object -> Parser (a -> a)
+ Configuration.Utils.ConfigFile: (..:) :: FromJSON b => Setter' a b -> Text -> Object -> Parser (a -> a)
- Configuration.Utils.ConfigFile: setProperty :: Lens' a b -> Text -> (Value -> Parser b) -> Object -> Parser (a -> a)
+ Configuration.Utils.ConfigFile: setProperty :: Setter' a b -> Text -> (Value -> Parser b) -> Object -> Parser (a -> a)
- Configuration.Utils.ConfigFile: updateProperty :: Lens' a b -> Text -> (Value -> Parser (b -> b)) -> Object -> Parser (a -> a)
+ Configuration.Utils.ConfigFile: updateProperty :: Setter' a b -> Text -> (Value -> Parser (b -> b)) -> Object -> Parser (a -> a)
- Configuration.Utils.Internal: over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
+ Configuration.Utils.Internal: over :: Setter s t a b -> (a -> b) -> s -> t
- Configuration.Utils.Internal: set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
+ Configuration.Utils.Internal: set :: Setter s t a b -> b -> s -> t
- Configuration.Utils.Validation: type ConfigValidation a f = forall m. (MonadIO m, Functor m, Applicative m, MonadError Text m, MonadWriter (f Text) m) => a -> m ()
+ Configuration.Utils.Validation: type ConfigValidation' a f r = forall m. (MonadIO m, Functor m, Applicative m, MonadError Text m, MonadWriter (f Text) m) => a -> m r
Files
- CHANGELOG.md +6/−0
- Setup.hs +35/−14
- configuration-tools.cabal +7/−6
- src/Configuration/Utils.hs +49/−31
- src/Configuration/Utils/ConfigFile.hs +6/−7
- src/Configuration/Utils/Internal.hs +18/−3
- src/Configuration/Utils/Internal/ConfigFileReader.hs +1/−2
- src/Configuration/Utils/Internal/HttpsCertPolicy.hs +3/−4
- src/Configuration/Utils/Setup.hs +37/−19
- src/Configuration/Utils/Validation.hs +3/−2
CHANGELOG.md view
@@ -1,5 +1,11 @@ # configuration-tools +## 0.7.1 (2025-03-04)++* Support lastest GHC (9.12)+* Use setters instead of lenses in ..: and %.:+* Allow validation functions to return new values+ ## 0.7.0 (2022-06-22) The version bump is due to the update of the dependency on optparse-applicative,
Setup.hs view
@@ -110,6 +110,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex import Distribution.Simple.Setup+import Distribution.Simple.Utils (createDirectoryIfMissingVerbose) import Distribution.Text import Distribution.Utils.Path import Distribution.Utils.ShortText@@ -128,10 +129,17 @@ import Prelude hiding (readFile, writeFile) import System.Directory- (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist,- doesFileExist, getCurrentDirectory)+ ( canonicalizePath+ , doesDirectoryExist+ , doesFileExist+ , getCurrentDirectory+ ) import System.Exit (ExitCode(ExitSuccess))+#if MIN_VERSION_Cabal(3,14,0)+import System.FilePath (isDrive, takeDirectory)+#else import System.FilePath (isDrive, takeDirectory, (</>))+#endif -- | Include this function when your setup doesn't contain any -- extra functionality.@@ -162,6 +170,11 @@ prettyLicense :: I.InstalledPackageInfo -> String prettyLicense = either prettyShow prettyShow . I.license +#if !MIN_VERSION_Cabal(3,14,0)+interpretSymbolicPath :: Maybe () -> FilePath -> FilePath+interpretSymbolicPath _ p = p+#endif+ -- -------------------------------------------------------------------------- -- -- Cabal 2.0 @@ -173,28 +186,31 @@ -> LocalBuildInfo -> IO () mkPkgInfoModulesPostConf hook args flags pkgDesc bInfo = do- mapM_ (updatePkgInfoModule pkgDesc bInfo) $ Graph.toList $ componentGraph bInfo+ mapM_ (updatePkgInfoModule pkgDesc bInfo flags) $ Graph.toList $ componentGraph bInfo hook args flags pkgDesc bInfo -updatePkgInfoModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO ()-updatePkgInfoModule pkgDesc bInfo clbInfo = do- createDirectoryIfMissing True dirName+updatePkgInfoModule+ :: PackageDescription+ -> LocalBuildInfo+ -> ConfigFlags+ -> ComponentLocalBuildInfo+ -> IO ()+updatePkgInfoModule pkgDesc bInfo flags clbInfo = do+ createDirectoryIfMissingVerbose verbosity True dirName moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo updateFile fileName moduleBytes -- legacy module legacyModuleBytes <- pkgInfoModule legacyModuleName cName pkgDesc bInfo updateFile legacyFileName legacyModuleBytes- where- dirName = autogenComponentModulesDir bInfo clbInfo+ verbosity = fromFlag $ configVerbosity flags+ dirName = interpretSymbolicPath Nothing $ autogenComponentModulesDir bInfo clbInfo cName = unUnqualComponentName <$> componentNameString (componentLocalName clbInfo)- moduleName = pkgInfoModuleName- fileName = dirName ++ "/" ++ moduleName ++ ".hs"-+ fileName = dirName </> moduleName <> ".hs" legacyModuleName = legacyPkgInfoModuleName cName- legacyFileName = dirName ++ "/" ++ legacyModuleName ++ ".hs"+ legacyFileName = dirName </> legacyModuleName <> ".hs" -- -------------------------------------------------------------------------- -- -- Generate PkgInfo Module@@ -214,7 +230,7 @@ legacyPkgInfoModuleName :: Maybe String -> String legacyPkgInfoModuleName Nothing = "PkgInfo"-legacyPkgInfoModuleName (Just cn) = "PkgInfo_" ++ map tr cn+legacyPkgInfoModuleName (Just cn) = "PkgInfo_" <> map tr cn where tr '-' = '_' tr c = c@@ -236,7 +252,12 @@ then return Nothing else getVcsOfDir (takeDirectory canonicDir) -pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString+pkgInfoModule+ :: String+ -> Maybe String+ -> PackageDescription+ -> LocalBuildInfo+ -> IO B.ByteString pkgInfoModule moduleName cName pkgDesc bInfo = do (tag, revision, branch) <- getVCS >>= \case Just Mercurial -> hgInfo
configuration-tools.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: configuration-tools-version: 0.7.0+version: 0.7.1 synopsis: Tools for specifying and parsing configurations description: Tools for specifying and parsing configurations@@ -30,19 +30,20 @@ license: MIT license-file: LICENSE author: Lars Kuhtz <lakuhtz@gmail.com>-maintainer: Lars Kuhtz <lakuhtz@gmail.com>+maintainer: Lars Kuhtz <lakuhtz@gmail.com>, Edmund Noble <edmundnoble@gmail.com> copyright:+ (c) 2024-2025 Edmund Noble <edmundnoble@gmail.com>, (c) 2019-2020 Colin Woodbury <colin@fosskers.ca>,- (c) 2015-2023 Lars Kuhtz <lakuhtz@gmail.com>,+ (c) 2015-2025 Lars Kuhtz <lakuhtz@gmail.com>, (c) 2014-2015 AlephCloud, Inc. category: Configuration, Console build-type: Custom tested-with:+ , GHC==9.12+ , GHC==9.10+ , GHC==9.8 , GHC==9.6 , GHC==9.4- , GHC==9.2- , GHC==9.0.1- , GHC==8.10.7 extra-doc-files: README.md,
src/Configuration/Utils.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -135,7 +136,7 @@ import Control.Monad (void, when) import Control.Monad.Except (MonadError, throwError)-import Control.Monad.Writer (execWriterT, runWriterT)+import Control.Monad.Writer (runWriterT) import Control.Monad.IO.Class (MonadIO) import qualified Data.ByteString.Char8 as B8@@ -170,13 +171,13 @@ -- this type is to avoid @ImpredicativeTypes@ when storing the function -- in the 'ProgramInfoValidate' record. ---newtype ConfigValidationFunction a f = ConfigValidationFunction- { runConfigValidation ∷ ConfigValidation a f+newtype ConfigValidationFunction a f r = ConfigValidationFunction+ { runConfigValidation ∷ ConfigValidation' a f r } type ProgramInfo a = ProgramInfoValidate a [] -data ProgramInfoValidate a f = ProgramInfo+data ProgramInfoValidate' a f r = ProgramInfo { _piDescription ∷ !String -- ^ Program Description , _piHelpHeader ∷ !(Maybe String)@@ -187,7 +188,7 @@ -- ^ options parser for configuration , _piDefaultConfiguration ∷ !a -- ^ default configuration- , _piValidateConfiguration ∷ !(ConfigValidationFunction a f)+ , _piValidateConfiguration ∷ !(ConfigValidationFunction a f r) -- ^ a validation function. The 'Right' result is interpreted as a 'Foldable' -- structure of warnings. , _piConfigurationFiles ∷ ![ConfigFile]@@ -195,33 +196,35 @@ -- before any command line argument is evaluated. } +type ProgramInfoValidate a f = ProgramInfoValidate' a f a+ -- | Program Description ---piDescription ∷ Lens' (ProgramInfoValidate a f) String+piDescription ∷ Lens' (ProgramInfoValidate' a f r) String piDescription = lens _piDescription $ \s a → s { _piDescription = a } {-# INLINE piDescription #-} -- | Help header ---piHelpHeader ∷ Lens' (ProgramInfoValidate a f) (Maybe String)+piHelpHeader ∷ Lens' (ProgramInfoValidate' a f r) (Maybe String) piHelpHeader = lens _piHelpHeader $ \s a → s { _piHelpHeader = a } {-# INLINE piHelpHeader #-} -- | Help footer ---piHelpFooter ∷ Lens' (ProgramInfoValidate a f) (Maybe String)+piHelpFooter ∷ Lens' (ProgramInfoValidate' a f r) (Maybe String) piHelpFooter = lens _piHelpFooter $ \s a → s { _piHelpFooter = a } {-# INLINE piHelpFooter #-} -- | Options parser for configuration ---piOptionParser ∷ Lens' (ProgramInfoValidate a f) (MParser a)+piOptionParser ∷ Lens' (ProgramInfoValidate' a f r) (MParser a) piOptionParser = lens _piOptionParser $ \s a → s { _piOptionParser = a } {-# INLINE piOptionParser #-} -- | Default configuration ---piDefaultConfiguration ∷ Lens' (ProgramInfoValidate a f) a+piDefaultConfiguration ∷ Lens' (ProgramInfoValidate' a f r) a piDefaultConfiguration = lens _piDefaultConfiguration $ \s a → s { _piDefaultConfiguration = a } {-# INLINE piDefaultConfiguration #-} @@ -229,7 +232,7 @@ -- -- The 'Right' result is interpreted as a 'Foldable' structure of warnings. ---piValidateConfiguration ∷ Lens' (ProgramInfoValidate a f) (ConfigValidationFunction a f)+piValidateConfiguration ∷ Lens' (ProgramInfoValidate' a f r) (ConfigValidationFunction a f r) piValidateConfiguration = lens _piValidateConfiguration $ \s a → s { _piValidateConfiguration = a } {-# INLINE piValidateConfiguration #-} @@ -246,10 +249,10 @@ -- piOptionParserAndDefaultConfiguration ∷ Lens- (ProgramInfoValidate a b)- (ProgramInfoValidate c d)- (MParser a, a, ConfigValidationFunction a b)- (MParser c, c, ConfigValidationFunction c d)+ (ProgramInfoValidate' a b r)+ (ProgramInfoValidate' c d r')+ (MParser a, a, ConfigValidationFunction a b r)+ (MParser c, c, ConfigValidationFunction c d r') piOptionParserAndDefaultConfiguration = lens g $ \s (a,b,c) → ProgramInfo { _piDescription = _piDescription s , _piHelpHeader = _piHelpHeader s@@ -283,13 +286,13 @@ -- -- 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'. ---programInfoValidate+programInfoValidate' ∷ String → MParser a → a- → ConfigValidation a f- → ProgramInfoValidate a f-programInfoValidate desc parser defaultConfig valFunc = ProgramInfo+ → ConfigValidation' a f r+ → ProgramInfoValidate' a f r+programInfoValidate' desc parser defaultConfig valFunc = ProgramInfo { _piDescription = desc , _piHelpHeader = Nothing , _piHelpFooter = Nothing@@ -299,6 +302,19 @@ , _piConfigurationFiles = [] } +-- | Smart constructor for 'ProgramInfo'.+--+-- 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'.+--+programInfoValidate+ ∷ String+ → MParser a+ → a+ → ConfigValidation a f+ → ProgramInfoValidate a f+programInfoValidate desc parser defaultConfig valFunc =+ programInfoValidate' desc parser defaultConfig $ \c -> valFunc c >> return c+ -- -------------------------------------------------------------------------- -- -- AppConfiguration @@ -343,6 +359,7 @@ , _configFiles ∷ ![ConfigFile] , _mainConfig ∷ !a }+ deriving Functor -- | A list of configuration file locations. Configuration file locations are -- set either statically in the code or are provided dynamically on the command@@ -446,10 +463,10 @@ -- runWithConfiguration ∷ (FromJSON (a → a), ToJSON a, Foldable f, Monoid (f T.Text))- ⇒ ProgramInfoValidate a f+ ⇒ ProgramInfoValidate' a f r -- ^ program info value; use 'programInfo' to construct a value of this -- type- → (a → IO ())+ → (r → IO ()) -- ^ computation that is given the configuration that is parsed from -- the command line. → IO ()@@ -574,8 +591,8 @@ -- Internal main function mainOptions- ∷ ∀ a f . FromJSON (a → a)- ⇒ ProgramInfoValidate a f+ ∷ ∀ a f r . FromJSON (a → a)+ ⇒ ProgramInfoValidate' a f r -- ^ Program Info value which may include a validation function → (∀ b . Maybe (MParser b))@@ -646,7 +663,7 @@ -- runInternal ∷ (FromJSON (a → a), ToJSON a, Foldable f, Monoid (f T.Text))- ⇒ ProgramInfoValidate a f+ ⇒ ProgramInfoValidate' a f r -- ^ program info value; use 'programInfo' to construct a value of this -- type → (∀ b . Maybe (MParser b))@@ -655,7 +672,7 @@ -- See the documentation of "Configuration.Utils.Setup" for a way -- how to generate this information automatically from the package -- description during the build process.- → (a → IO ())+ → (r → IO ()) -- ^ computation that is given the configuration that is parsed from -- the command line. → IO ()@@ -672,10 +689,10 @@ (_configFiles cliAppConf) -- Validate final configuration- validateConfig appInfo $ _mainConfig appConf+ validatedConf ← validateConfig appInfo $ _mainConfig appConf case _printConfig appConf of- Nothing → mainFunction ∘ _mainConfig $ appConf+ Nothing → mainFunction ∘ _mainConfig $ validatedConf <$ appConf Just Full → B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ appConf Just Minimal → B8.putStrLn ∘ Yaml.encode@@ -714,7 +731,7 @@ ) ⇒ T.Text -- ^ program name (used in error messages)- → ProgramInfoValidate a f+ → ProgramInfoValidate' a f r -- ^ program info value; use 'programInfo' to construct a value of this -- type → [String]@@ -752,12 +769,13 @@ -- validateConfig ∷ (Foldable f, Monoid (f T.Text))- ⇒ ProgramInfoValidate a f+ ⇒ ProgramInfoValidate' a f r → a- → IO ()+ → IO r validateConfig appInfo conf = do- warnings ← execWriterT ∘ exceptT (error ∘ T.unpack) return $+ (r, warnings) ← runWriterT ∘ exceptT (error ∘ T.unpack) return $ runConfigValidation (view piValidateConfiguration appInfo) conf when (any (const True) warnings) $ do T.hPutStrLn stderr "WARNINGS:" mapM_ (\w → T.hPutStrLn stderr $ "warning: " ⊕ w) warnings+ return r
src/Configuration/Utils/ConfigFile.hs view
@@ -78,7 +78,6 @@ import Data.Monoid.Unicode import Data.String import qualified Data.Text as T-import Data.Typeable import Prelude hiding (any, concatMap, mapM_) @@ -126,7 +125,7 @@ -- > e → fail $ "unrecognized user " ⊕ e -- setProperty- ∷ Lens' a b -- ^ a lens into the target that is updated by the parser+ ∷ Setter' a b -- ^ a lens into the target that is updated by the parser → T.Text -- ^ the JSON property name → (Value → Parser b) -- ^ the JSON 'Value' parser that is used to parse the value of the property → Object -- ^ the parsed JSON 'Value' 'Object'@@ -158,7 +157,7 @@ -- > <$< user ..: "user" % o -- > <*< pwd ..: "pwd" % o ---(..:) ∷ FromJSON b ⇒ Lens' a b → T.Text → Object → Parser (a → a)+(..:) ∷ FromJSON b ⇒ Setter' a b → T.Text → Object → Parser (a → a) (..:) s k = setProperty s k parseJSON infix 6 ..: {-# INLINE (..:) #-}@@ -194,7 +193,7 @@ -- > <*< setProperty domain "domain" parseJSON o -- updateProperty- ∷ Lens' a b+ ∷ Setter' a b → T.Text → (Value → Parser (b → b)) → Object@@ -230,7 +229,7 @@ -- > <$< auth %.: "auth" % o -- > <*< domain ..: "domain" % o ---(%.:) ∷ FromJSON (b → b) ⇒ Lens' a b → T.Text → Object → Parser (a → a)+(%.:) ∷ FromJSON (b → b) ⇒ Setter' a b → T.Text → Object → Parser (a → a) (%.:) s k = updateProperty s k parseJSON infix 6 %.: {-# INLINE (%.:) #-}@@ -254,7 +253,7 @@ data ConfigFile = ConfigFileRequired { getConfigFile ∷ !T.Text } | ConfigFileOptional { getConfigFile ∷ !T.Text }- deriving (Show, Read, Eq, Ord, Typeable)+ deriving (Show, Read, Eq, Ord) -- | An /internal/ type for the meta configuration that specifies how the -- configuration files are loaded and parsed.@@ -263,7 +262,7 @@ data ConfigFilesConfig = ConfigFilesConfig { _cfcHttpsPolicy ∷ !HttpsCertPolicy }- deriving (Show, Eq, Typeable)+ deriving (Show, Eq) cfcHttpsPolicy ∷ Lens' ConfigFilesConfig HttpsCertPolicy cfcHttpsPolicy = lens _cfcHttpsPolicy $ \a b → a { _cfcHttpsPolicy = b }
src/Configuration/Utils/Internal.hs view
@@ -21,6 +21,8 @@ , view , Lens' , Lens+, Setter'+, Setter , Iso' , Iso , iso@@ -70,15 +72,29 @@ -- type Lens' s a = Lens s s a a +-- | This is almost the same type as the type from the lens library with the same name.+--+-- In case it is already import from the lens package this should be hidden+-- from the import.+--+type Setter s t a b = (a -> Identity b) -> s -> Identity t++-- | This is almost the same type as the type from the lens library with the same name.+--+-- In case it is already import from the lens package this should be hidden+-- from the import.+--+type Setter' s a = Setter s s a a+ lens ∷ (s → a) → (s → b → t) → Lens s t a b lens getter setter lGetter s = setter s `fmap` lGetter (getter s) {-# INLINE lens #-} -over ∷ ((a → Identity b) → s → Identity t) → (a → b) → s → t+over ∷ Setter s t a b → (a → b) → s → t over s f = runIdentity . s (Identity . f) {-# INLINE over #-} -set ∷ ((a → Identity b) → s → Identity t) → b → s → t+set ∷ Setter s t a b → b → s → t set s a = runIdentity . s (const $ Identity a) {-# INLINE set #-} @@ -123,4 +139,3 @@ → m a errorT = exceptT (\e → error ∘ T.unpack $ "Error: " ⊕ e) return {-# INLINE errorT #-}-
src/Configuration/Utils/Internal/ConfigFileReader.hs view
@@ -50,7 +50,6 @@ import qualified Data.ByteString.Char8 as B8 import Data.Monoid.Unicode import qualified Data.Text as T-import Data.Typeable import qualified Data.Yaml as Yaml import GHC.Generics@@ -155,7 +154,7 @@ = Yaml | Json | Other- deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) instance NFData ConfigFileFormat
src/Configuration/Utils/Internal/HttpsCertPolicy.hs view
@@ -52,7 +52,6 @@ import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as T-import Data.Typeable import qualified Data.X509 as TLS import qualified Data.X509.Validation as TLS @@ -80,7 +79,7 @@ , _certPolicyHostFingerprints ∷ !(HM.HashMap TLS.ServiceID TLS.Fingerprint) -- ^ a whitelist for services with trusted certificates }- deriving (Show, Eq, Typeable)+ deriving (Show, Eq) certPolicyInsecure ∷ Lens' HttpsCertPolicy Bool certPolicyInsecure = lens _certPolicyInsecure $ \s a → s { _certPolicyInsecure = a }@@ -177,7 +176,7 @@ -- In particular exceptions should include rejected certificates. -- newtype VerboseTlsException = VerboseTlsException T.Text- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance Show VerboseTlsException where show (VerboseTlsException msg) = "TLS exception: " ⊕ T.unpack msg@@ -189,7 +188,7 @@ → Maybe (TLS.SignedExact TLS.Certificate) → TLS.TLSException → IO a-handleTlsException request cert e@(TLS.HandshakeFailed (TLS.Error_Protocol (msg, _b, _alert)))+handleTlsException request cert e@(TLS.HandshakeFailed (TLS.Error_Protocol msg _)) | "certificate rejected: [SelfSigned]" `L.isPrefixOf` msg = throwIO ∘ VerboseTlsException $ "The server uses a self-signed certificate. If you are sure that no-one" ⊕ " is intercepting the connection and this is the correct certificate you"
src/Configuration/Utils/Setup.hs view
@@ -110,6 +110,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex import Distribution.Simple.Setup+import Distribution.Simple.Utils (createDirectoryIfMissingVerbose) import Distribution.Text import Distribution.Utils.Path import Distribution.Utils.ShortText@@ -128,10 +129,17 @@ import Prelude hiding (readFile, writeFile) import System.Directory- (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist,- doesFileExist, getCurrentDirectory)+ ( canonicalizePath+ , doesDirectoryExist+ , doesFileExist+ , getCurrentDirectory+ ) import System.Exit (ExitCode(ExitSuccess))+#if MIN_VERSION_Cabal(3,14,0)+import System.FilePath (isDrive, takeDirectory)+#else import System.FilePath (isDrive, takeDirectory, (</>))+#endif -- | Include this function when your setup doesn't contain any -- extra functionality.@@ -162,8 +170,10 @@ prettyLicense :: I.InstalledPackageInfo -> String prettyLicense = either prettyShow prettyShow . I.license -ft :: ShortText -> String-ft = fromShortText+#if !MIN_VERSION_Cabal(3,14,0)+interpretSymbolicPath :: Maybe () -> FilePath -> FilePath+interpretSymbolicPath _ p = p+#endif -- -------------------------------------------------------------------------- -- -- Cabal 2.0@@ -176,28 +186,31 @@ -> LocalBuildInfo -> IO () mkPkgInfoModulesPostConf hook args flags pkgDesc bInfo = do- mapM_ (updatePkgInfoModule pkgDesc bInfo) $ Graph.toList $ componentGraph bInfo+ mapM_ (updatePkgInfoModule pkgDesc bInfo flags) $ Graph.toList $ componentGraph bInfo hook args flags pkgDesc bInfo -updatePkgInfoModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO ()-updatePkgInfoModule pkgDesc bInfo clbInfo = do- createDirectoryIfMissing True dirName+updatePkgInfoModule+ :: PackageDescription+ -> LocalBuildInfo+ -> ConfigFlags+ -> ComponentLocalBuildInfo+ -> IO ()+updatePkgInfoModule pkgDesc bInfo flags clbInfo = do+ createDirectoryIfMissingVerbose verbosity True dirName moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo updateFile fileName moduleBytes -- legacy module legacyModuleBytes <- pkgInfoModule legacyModuleName cName pkgDesc bInfo updateFile legacyFileName legacyModuleBytes- where- dirName = autogenComponentModulesDir bInfo clbInfo+ verbosity = fromFlag $ configVerbosity flags+ dirName = interpretSymbolicPath Nothing $ autogenComponentModulesDir bInfo clbInfo cName = unUnqualComponentName <$> componentNameString (componentLocalName clbInfo)- moduleName = pkgInfoModuleName- fileName = dirName ++ "/" ++ moduleName ++ ".hs"-+ fileName = dirName </> moduleName <> ".hs" legacyModuleName = legacyPkgInfoModuleName cName- legacyFileName = dirName ++ "/" ++ legacyModuleName ++ ".hs"+ legacyFileName = dirName </> legacyModuleName <> ".hs" -- -------------------------------------------------------------------------- -- -- Generate PkgInfo Module@@ -217,7 +230,7 @@ legacyPkgInfoModuleName :: Maybe String -> String legacyPkgInfoModuleName Nothing = "PkgInfo"-legacyPkgInfoModuleName (Just cn) = "PkgInfo_" ++ map tr cn+legacyPkgInfoModuleName (Just cn) = "PkgInfo_" <> map tr cn where tr '-' = '_' tr c = c@@ -239,7 +252,12 @@ then return Nothing else getVcsOfDir (takeDirectory canonicDir) -pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString+pkgInfoModule+ :: String+ -> Maybe String+ -> PackageDescription+ -> LocalBuildInfo+ -> IO B.ByteString pkgInfoModule moduleName cName pkgDesc bInfo = do (tag, revision, branch) <- getVCS >>= \case Just Mercurial -> hgInfo@@ -302,10 +320,10 @@ , " copyright = " <> (pack . show . copyright) pkgDesc , "" , " author :: IsString a => a"- , " author = \"" <> (pack . ft . author) pkgDesc <> "\""+ , " author = \"" <> (pack . fromShortText . author) pkgDesc <> "\"" , "" , " homepage :: IsString a => a"- , " homepage = \"" <> (pack . ft . homepage) pkgDesc <> "\""+ , " homepage = \"" <> (pack . fromShortText . homepage) pkgDesc <> "\"" , "" , " package :: IsString a => a" , " package = \"" <> (pack . display . package) pkgDesc <> "\""@@ -397,4 +415,4 @@ ++ (if cr /= "" then ", " ++ cr else "") ++ "]" where- cr = (unwords . words . ft . I.copyright) a+ cr = (unwords . words . fromShortText . I.copyright) a
src/Configuration/Utils/Validation.hs view
@@ -17,6 +17,7 @@ -- module Configuration.Utils.Validation ( ConfigValidation+, ConfigValidation' -- * Networking , validateHttpOrHttpsUrl@@ -85,7 +86,8 @@ -- | A validation function. The type in the 'MonadWriter' is excpected to -- be a 'Foldable' structure for collecting warnings. ---type ConfigValidation a f = ∀ m . (MonadIO m, Functor m, Applicative m, MonadError T.Text m, MonadWriter (f T.Text) m) ⇒ a → m ()+type ConfigValidation a f = ConfigValidation' a f ()+type ConfigValidation' a f r = ∀ m . (MonadIO m, Functor m, Applicative m, MonadError T.Text m, MonadWriter (f T.Text) m) ⇒ a → m r -- -------------------------------------------------------------------------- -- -- Networking@@ -506,4 +508,3 @@ → m () 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-