configuration-tools 0.2.8 → 0.2.9

raw patch · 18 files changed

+3725/−1277 lines, 18 filesdep +ansi-wl-pprintdep +base64-bytestringdep +connectiondep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ansi-wl-pprint, base64-bytestring, connection, data-default, enclosed-exceptions, http-client, http-client-tls, http-types, monad-control, tls, wai, warp, warp-tls, x509, x509-system, x509-validation

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +39/−1
• README.md +83/−97
• configuration-tools.cabal +55/−9
• constraints +43/−1
• examples/Example.hs +21/−2
• src/Configuration/Utils.hs +700/−1070
• src/Configuration/Utils/CommandLine.hs +270/−0
• src/Configuration/Utils/ConfigFile.hs +397/−0
• src/Configuration/Utils/HttpsCertPolicy.hs +308/−0
• src/Configuration/Utils/Internal.hs +70/−9
• src/Configuration/Utils/Maybe.hs +240/−0
• src/Configuration/Utils/Monoid.hs +131/−0
• src/Configuration/Utils/Operators.hs +115/−0
• src/Configuration/Utils/Validation.hs +134/−74
• test/TestExample.hs +328/−14
• test/TestTools.hs +341/−0
• test/Tests/BoolOption.hs +194/−0
• test/Tests/MonoidConfig.hs +256/−0

@@ -1,3 +1,41 @@+0.2.9+=====++*   Use tight constraint for all validation functions. Previously the+    constraint where unessecarly restrictive.++*   Added `updateProperty` function that generalized `%.:` in the same+    way as `setProperty` generalizes `..:`.++*   Added validation function for config file arguments.++*   Allow usage of more than a single `--config-file` option on the+    command line.++*   Support for static configuration file locations. Configuration files+    can be marked as `required` or `optional`.++*   Support loading of configuraiton files form HTTP and HTTPS URLs+    including flags for disabling validation of SSL certificates and+    whitelisting SSL certificates based on their fingerprint.++*   Added tools for updating configurations with a monoid instance.++*   Added two new option parsers for boolean flags.++    *   The `boolOption_` parser uses the syntax `--feature` and+        `--no-feature` to enable and respectively disable a feature.++    *   The `enableDisableFlag` parser uses the syntax `--enable-feature`+        and `--disable-feature` to enable and respectively disable a feature.++*   Refactored the module layout. The API of the existing modules is+    is backward compatible, but a lot of code got moved into submodules.++*   Improved documentation.++*   Improved test suite.+ 0.2.8 ===== @@ -39,7 +77,7 @@ 0.2.5 ===== -*   `Configuration.Utils.Setup`: export `mkPkgInfoModules` function +*   `Configuration.Utils.Setup`: export `mkPkgInfoModules` function     that modifies a given `UserHooks` record to generate an `PkgInfo`     module during configuration. 

@@ -31,6 +31,34 @@ real world requirements we plan to rewrite this package such that the boilerplate is hidden behind a clean and simple DSL. +Installation+============++Assuming that you have a recent version verison of `GHC` and `Cabal`+installed in your system this package can be install from [Hackage](http://hackage.haskell.org/)+via++```bash+cabal install configuration-tools+```++If you don't need support for remote configuration files this package+can be build with a much smaller set of dependencies via++```bash+cabal install -f-remote-configs configuration-tools+```++The package can be tested via++```bash+git clone https://github.com/alephcloud/hs-configuration-tools.git+cd hs-configurationt-tools+cabal configure --enable-tests+cabal build+cabal test+```+ Configuration Management ======================== @@ -50,6 +78,9 @@ 4.  an options parser that yields a function that takes a value and updates     that value with the values provided as command line options. +Optionally, a function for validating the configuration value may be+provided.+ The package provides operators and functions that make the implmentation of these requisites easy for the common case that the configuration is encoded mainly through nested records.@@ -57,23 +88,46 @@ In addition to the user defined command line options the following options are recognized by the application: -`--config-file, -c`-:    parses the given file as a (partial) configuration in YAML format.+*   `--config-file, -c`+    parses the given file as a --possibly partial-- configuration in YAML+    format. The file location can be provided either as a local filesystem path+    or as a remote HTTP or HTTPS URL. In addition a list of static+    configuration file locations can be defined in the code. -`print-config, -p`-:    configures the application and prints the configuration in YAML format-     to standard out and exits. The printed configuration is exactly the-     configuration that otherwise would be used to run the application.+    If this option is provided more than a single time the configuration+    files are loaded in the order as the respective options appear+    on the command line, where settings that are loaded later have+    precedence over earlier settings. Files from static locations are+    loaded before files that are specified on the command line. -`--help, -h`-:   prints a help message and exits.+*   `print-config, -p`+    configures the application and prints the configuration in YAML format+    to standard out and exits. The printed configuration is exactly the+    configuration that otherwise would be used to run the application. -The operators assume that [lenses](http://hackage.haskell.org/package/lens)-are provided for field of the configuration record types.+*   `--help, -h`+    prints a help message and exits. -An complete usage example can be found in the file `example/Example.hs` of the-cabal package.+As long as the package wasn't build with `-f-remote-configs` the following+two options are availabe. They affect how configuration files+are loaded from remote URLs. +*   `--config-https-insecure=true|false`+    Bypass certificate validation for all HTTPS+    connections to all services.++*   `--config-https-allow-cert=HOSTNAME:PORT:FINGERPRINT`+    Unconditionally trust the certificate for connecting+    to the service.++The operators provided in this package assume that+[lenses](http://hackage.haskell.org/package/lens) are provided for field of the+configuration record types.++An complete usage example can be found in the file+[example/Example.hs](https://github.com/alephcloud/hs-configuration-tools/blob/master/examples/Example.hs)+of the cabal package.+ Usage Example ------------- @@ -117,8 +171,9 @@ pwd f s = (\p -> s { _pwd = p }) <$> f (_pwd s) ~~~ -(Note, that the module `Configuration.Utils` defines its own `Lens'` type synonym.-If you import `Control.Lens` you should hide `Lens'` from either module.)+(Note, that the module `Configuration.Utils` defines its own type synonyms for+lenses. If you import `Control.Lens` you should hide `Lens` and `Lens'` from+either module.)  We must provide a default value. If there is no reasonable default the respective value could, for instance, be wrapped into `Maybe`. Here we@@ -263,12 +318,9 @@  An update function for a product type can be defined pointwise as a mapping from constructor parameters to values. An update for a sum type must take the-constructor context into account. In terms of the lens library this is reflected-by using `Lens`es for product types and `Prism`s for sum types. Therefore a-configuration that defines an update function for a sum types must also specify-the constructor context. Moreover, when applied to a given default value the-function may not be applicable at all if the default value uses a different-constructor context than what the update assumes.+constructor context into account. Moreover, when applied to a given default+value the function may not be applicable at all if the default value uses a+different constructor context than what the update assumes.  For the future we plan to provide a general solution for configurations of sum types which would be based on the possibility to define default values for more@@ -278,57 +330,8 @@ and use the `..:` operator. Similarly for the option parser one has to define a parser that yields an `a` and use it with the `.::` operator. -Optional Configuration Values--------------------------------For simple `Maybe` values the standard `FromJSON` instance from the aeson-package can be used along with the `..:` operator. When defining command line-option parsers with `.::` and `%::` all options are optional. When an option is-not present on the command line the default value is used. For `Maybe` values-it is therefore enough to wrap the parsed value into `Just`.--For configuration values of type `Maybe a` where `a` is a record type we provide-an orphan[^1] `FromJSON` instance of the form--~~~{.haskell}-instance (FromJSON a, FromJSON (a -> a)) => FromJSON (Maybe a -> Maybe a)-~~~--that has the following behavior:--If the parsed configuration value is `Null` the resulting function constantly-returns `Nothing`. Otherwise--*   If the parsed configuration value is `Null` the result is `Nothing`.-*   If the parsed configuration value is not `Null` then the result is-    an update function that--    *   updates the given default value if this value is `Just x` or-    *   is a constant function that returns the value that is parsed-        from the configuration using the `FromJSON` instance for the-        configuration type.--The `FromJSON a` instance may either require that the parsed configuration fully-specifies the value of `a` (and raise a failure otherwise) or the `FromJSON a`-instance may do an pointwise update of a hardcoded default value based on-the existing `FromJSON (a -> a)` instance.--For instance, assuming that there is already an `FromJSON` instance for `MyType--> MyType` and a default value `defaultMyType` the following pattern can be-used:--~~~{.haskell}-instance FromJSON MyType where-    parseJSON v = parseJSON v <*> defaultMyType-~~~--[^1]: Using an orphan instance is generally problematic but convenient in-      this case. It's unlike that such an instance is needed elsewhere. If this-      is an issue for you, please let me know. In that case we can define a new-      type for optional configuration values.--The function `maybeOption` is provided for defining command line parser for-`Maybe` record values.+The module `Configuration.Utils.Maybe` provides tools for dealing with+`Maybe` values.  Package and Build Information =============================@@ -403,22 +406,22 @@ With that the resulting application supports the following additional command line options: -`--version, -v`-:    prints the version of the application and exits.+*   `--version, -v`+    prints the version of the application and exits. -`--info, -i`-:   prints a short info message for the application and exits.+*   `--info, -i`+    prints a short info message for the application and exits. -`--long-info`-:   print a detailed info message for the application and exits.+*   `--long-info`+    print a detailed info message for the application and exits.     Beside component name, package name, version, revision, and copyright     the message also contain information about the compiler that     was used for the build, the build architecture, build flags,     the author, the license type, and a list of all direct and     indirect dependencies along with their licenses and copyrights. -`--license`-:   prints the text of the lincense of the application and exits.+*   `--license`+    prints the text of the lincense of the application and exits.  Here is the example output of `--long-info` for the example `examples/Trivial.hs` from this package:@@ -512,9 +515,6 @@ This package is in an early stage of development and more features are planned. -*   Teach optparse-applicative to not print usage-message for-    info options.- *   Simplify specification of Configuration data types by     integrating the aeson instances and the option parser. @@ -529,31 +529,19 @@     are defined through point-wise updates can always be applied in a meaningful     way. -    We may use GHC Generics to derive the type for representing default values-    for all constructure classes. We can then define an operator that allows to-    construct the generic default value by combining values for the different-    constructors of the original sum type.--    The definition of the JSON instances and option parsers would use prisms-    that would update a value only for supported constructor contexts. In-    addition we may provide a way to configure the choice of a particular-    constructor.- *   Include help text as comments in YAML serialization of configuration     values.  *   Provide operators (or at least examples) for more scenarios     (like required options) -*   Nicer errors messages if parsing fails.+*   Nicer error messages if parsing fails.  *   Suport JSON encoded configuration files.  *   Support mode where JSON/YAML parsing fails when unexpected     properties are encountered. -*   Loading of configurations from URLs.- *   Include default values in help message.  *   Use 'helpDoc' to highlight "meta-options", like options that enable@@ -562,5 +550,3 @@  *   Add functionality optparse-applicative that allows to group options. -*   Raise parser error for sub-ordinate "maybe" options when not enabled-    the respective optional value is not enabled.

@@ -1,9 +1,9 @@ -- ------------------------------------------------------ ----- Copyright © 2014 AlephCloud Systems, Inc.+-- Copyright © 2014-2015 AlephCloud Systems, Inc. -- ------------------------------------------------------ --  Name:                configuration-tools-Version:             0.2.8+Version:             0.2.9 Synopsis:            Tools for specifying and parsing configurations description:     Tools for specifying and parsing configurations@@ -54,25 +54,36 @@ source-repository this     type: git     location: https://github.com/alephcloud/hs-configuration-tools.git-    tag: 0.2.8+    tag: 0.2.9 +flag remote-configs+    Description: enable loading of configuration files from HTTP URLs+    Default: True+    Manual: True+ Library     hs-source-dirs: src     default-language: Haskell2010      exposed-modules:-        -- Configuration.Utils.FromJsonWithDef         Configuration.Utils+        Configuration.Utils.CommandLine+        Configuration.Utils.ConfigFile         Configuration.Utils.Http+        Configuration.Utils.Internal+        Configuration.Utils.Maybe+        Configuration.Utils.Monoid+        Configuration.Utils.Operators         Configuration.Utils.Setup         Configuration.Utils.Validation--    other-modules:-        Configuration.Utils.Internal+    if flag(remote-configs)+        exposed-modules:+            Configuration.Utils.HttpsCertPolicy      build-depends:         Cabal >= 1.20,         aeson >= 0.7.0.6,+        ansi-wl-pprint >= 0.6,         attoparsec >= 0.11.3.4,         base >= 4.6 && < 5.0,         base-unicode-symbols >= 0.2.2.4,@@ -91,6 +102,23 @@         yaml >= 0.8.8.3,         profunctors >= 4.0.4 +    if flag(remote-configs)+        build-depends:+            base64-bytestring >= 1.0,+            connection >= 0.2,+            data-default >= 0.5,+            enclosed-exceptions >= 1.0,+            http-client >= 0.4,+            http-client-tls >= 0.2,+            monad-control >= 1.0,+            tls >= 1.2,+            x509 >= 1.5,+            x509-system >= 1.5,+            x509-validation >= 1.5.1++    if flag(remote-configs)+        cpp-options: -DREMOTE_CONFIGS+     ghc-options: -Wall  Test-Suite url-example-test@@ -101,16 +129,34 @@      other-modules:         Example+        TestTools+        Tests.BoolOption+        Tests.MonoidConfig      build-depends:         base >= 4.6 && < 5.0,         base-unicode-symbols >= 0.2.2.4,+        bytestring >= 0.10,+        Cabal >= 1.20,         configuration-tools,         errors >= 1.4.3,-        mtl >= 2.2+        mtl >= 2.2,+        text >= 1.0,+        unordered-containers >= 0.2.4.0,+        yaml >= 0.8.8.3 +    if flag(remote-configs)+        build-depends:+            enclosed-exceptions >= 1.0,+            http-types >= 0.8,+            monad-control >= 1.0,+            wai >= 3.0,+            warp >= 3.0,+            warp-tls >= 3.0++        cpp-options: -DREMOTE_CONFIGS+     ghc-options: -Wall-    cpp-options: -DMain=Example  Test-Suite trivial     type: exitcode-stdio-1.0

@@ -4,18 +4,42 @@              ansi-terminal ==0.6.2.1,              ansi-wl-pprint ==0.6.7.1,              array ==0.5.0.0,+             asn1-encoding ==0.9.0,+             asn1-parse ==0.9.0,+             asn1-types ==0.3.0,              async ==2.0.1.6,              attoparsec ==0.12.1.2,              base ==4.7.0.1,              base-unicode-symbols ==0.2.2.4,+             base64-bytestring ==1.0.0.1,              bifunctors ==4.1.1.1,              binary ==0.7.1.0,+             blaze-builder ==0.3.3.4,+             byteable ==0.1.1,              bytestring ==0.10.4.0,              case-insensitive ==1.2.0.3,+             cereal ==0.4.0.1,+             cipher-aes ==0.2.8,+             cipher-des ==0.0.6,+             cipher-rc4 ==0.1.4,              comonad ==4.2.2,              conduit ==1.2.3.1,+             connection ==0.2.4,              containers ==0.5.5.1,              contravariant ==1.2.0.1,+             cookie ==0.4.1.4,+             crypto-cipher-types ==0.0.9,+             crypto-numbers ==0.2.3,+             crypto-pubkey ==0.2.8,+             crypto-pubkey-types ==0.4.3,+             crypto-random ==0.0.7,+             cryptohash ==0.11.6,+             data-default ==0.5.3,+             data-default-class ==0.0.1,+             data-default-instances-base ==0.0.1,+             data-default-instances-containers ==0.0.1,+             data-default-instances-dlist ==0.0.1,+             data-default-instances-old-locale ==0.0.1,              deepseq ==1.3.0.2,              directory ==1.2.1.0,              distributive ==0.4.4,@@ -28,39 +52,57 @@              free ==4.10.0.1,              ghc-prim ==0.3.1.0,              hashable ==1.2.3.1,+             hourglass ==0.2.8,+             http-client ==0.4.7,+             http-client-tls ==0.2.2,+             http-types ==0.8.5,              integer-gmp ==0.5.1.0,              lifted-base ==0.2.3.3,+             mime-types ==0.1.0.5,              mmorph ==1.0.4,              monad-control ==1.0.0.1,              mtl ==2.2.1,              nats ==1,+             network ==2.6.0.2,              network-uri ==2.6.0.1,              old-locale ==1.0.0.6,              optparse-applicative ==0.11.0.1,              parsec ==3.1.7,+             pem ==0.2.2,              prelude-extras ==0.4,              pretty ==1.1.1.1,              primitive ==0.5.3.0,              process ==1.2.0.0,              profunctors ==4.3.2,+             publicsuffixlist ==0.1,              random ==1.0.1.1,              resourcet ==1.1.3.3,              rts ==1.0,              safe ==0.3.6,              scientific ==0.3.3.5,+             securemem ==0.1.3,              semigroupoids ==4.2,              semigroups ==0.16.0.1,+             socks ==0.5.4,              stm ==2.4.3,+             streaming-commons ==0.1.8,              syb ==0.4.2,              tagged ==0.7.2,              template-haskell ==2.9.0.0,              text ==1.2.0.3,              time ==1.4.2,+             tls ==1.2.16,              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.1,+             utf8-string ==0.3.8,              vector ==0.10.11.0,              void ==0.7,-             yaml ==0.8.10.1+             x509 ==1.5.0.1,+             x509-store ==1.5.0,+             x509-system ==1.5.0,+             x509-validation ==1.5.1,+             yaml ==0.8.10.1,+             zlib ==0.5.4.1

@@ -8,8 +8,27 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -module Main-( main+module Example+(+-- * Authentication+  Auth(..)+, user+, pwd+, defaultAuth+, validateAuth+, pAuth++-- * Http URL+, HttpURL(..)+, auth+, domain+, path+, defaultHttpURL+, validateHttpURL+, pHttpURL++-- * main functions+, main , main_ ) where 

@@ -1,1071 +1,701 @@--- ------------------------------------------------------ ----- Copyright © 2014 AlephCloud Systems, Inc.--- ------------------------------------------------------ ----{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}--{-# OPTIONS_HADDOCK show-extensions #-}---- | This module provides a collection of utils on top of the packages--- optparse-applicative, aeson, and yaml, for configuring libraries and--- applications in a composable way.------ The main feature is the integration of command line option parsing and--- configuration files.------ The purpose is to make management of configurations easy by providing an--- idiomatic style of defining and deploying configurations.------ For each data type that is used as a configuration type the following must be--- provided:------ 1. a default value,------ 2. a 'FromJSON' instance that yields a function that takes a value and---    updates that value with the parsed values,------ 3. a 'ToJSON' instance, and------ 4. an options parser that yields a function that takes a value and updates---    that value with the values provided as command line options.------ In addition to the above optionally a validation function may be provided--- that (recursively) validates a configuration value and returns either--- an error or a --possibly empty-- list-like structure of warnings.------ The module provides operators and functions that make the implmentation of--- these entities easy for the common case that the configurations are encoded--- mainly as nested records.------ The operators assume that lenses for the configuration record types are--- provided.------ An complete usage example can be found in the file @example/Example.hs@--- of the cabal package.----module Configuration.Utils-(--- * Program Configuration-  ProgramInfo-, programInfo-, piDescription-, piHelpHeader-, piHelpFooter-, piOptionParser-, piDefaultConfiguration---- * Program Configurations with Validation of Configuration Values-, ConfigValidation-, programInfoValidate---- ** Low-level Config Validation-, ProgramInfoValidate-, piValidateConfiguration-, ConfigValidationFunction-, piOptionParserAndDefaultConfiguration---- * Running an Configured Application-, runWithConfiguration-, PkgInfo-, runWithPkgInfoConfiguration-, parseConfiguration---- * Applicative Option Parsing with Default Values-, MParser-, (.::)-, (%::)-, boolReader-, boolOption-, fileOption-, eitherReadP-, module Options.Applicative---- * Parsing of Configuration Files with Default Values-, setProperty-, (..:)-, (!..:)-, (%.:)-, module Data.Aeson---- * Command Line Option Parsing--- * Misc Utils-, (%)-, (×)-, (<*<)-, (>*>)-, (<$<)-, (>$>)-, (<.>)-, (⊙)-, dropAndUncaml-, Lens'-, Lens---- * Configuration of Optional Values---- * Simple Maybe Values--- $simplemaybe---- **  Record Maybe Values--- $recordmaybe-, maybeOption-) where--import Configuration.Utils.Internal--import Control.Error (fmapL)-import Control.Monad.Except hiding (mapM_)-import Control.Monad.Writer hiding (mapM_)--import Data.Aeson-import Data.Aeson.Types (Parser)-import qualified Data.ByteString.Char8 as B8-import Data.Char-import qualified Data.CaseInsensitive as CI-import Data.Foldable-import qualified Data.HashMap.Strict as H-import Data.Maybe-import Data.Monoid.Unicode-import Data.String-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Yaml as Yaml--import Options.Applicative hiding (Parser, Success)--import qualified Options.Applicative as O--import Prelude hiding (concatMap, mapM_, any)-import Prelude.Unicode--import System.IO-import System.IO.Unsafe (unsafePerformIO)--import qualified Text.ParserCombinators.ReadP as P---- -------------------------------------------------------------------------- ----- Useful Operators---- | 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.----(%) ∷ (α → β) → α → β-(%) = ($)-infixr 5 %-{-# INLINE (%) #-}---- | This operator is a UTF-8 version of '%' which is an alternative for '$'--- 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.------ In VIM type: @Ctrl-V u 00d7@------ You may also define a key binding by adding something like the following line--- to your vim configuration file:------ > iabbrev <buffer> >< ×----(×) ∷ (α → β) → α → β-(×) = ($)-infixr 5 ×-{-# INLINE (×) #-}---- | Functional composition for applicative functors.----(<*<) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)-(<*<) a b = pure (.) <*> a <*> b-infixr 4 <*<-{-# INLINE (<*<) #-}---- | Functional composition for applicative functors with its arguments--- flipped.----(>*>) ∷ Applicative φ ⇒ φ (α → β) → φ (β → γ) → φ (α → γ)-(>*>) = flip (<*<)-infixr 4 >*>-{-# INLINE (>*>) #-}---- | Applicative functional composition between a pure function--- and an applicative function.----(<$<) ∷ Functor φ ⇒ (β → γ) → φ (α → β) → φ (α → γ)-(<$<) a b = (a .) <$> b-infixr 4 <$<-{-# INLINE (<$<) #-}---- | Applicative functional composition between a pure function--- and an applicative function with its arguments flipped.----(>$>) ∷ Functor φ ⇒ φ (α → β) → (β → γ) → φ (α → γ)-(>$>) = flip (<$<)-infixr 4 >$>-{-# INLINE (>$>) #-}---- | Functional composition for applicative functors.------ This is a rather popular operator. Due to conflicts (for instance with the--- lens package) it may have to be imported qualified.----(<.>) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)-(<.>) = (<*<)-infixr 4 <.>-{-# INLINE (<.>) #-}-{-# DEPRECATED (<.>) "use '<*<' instead" #-}---- | For people who like nicely aligned code and do not mind messing with--- editor key-maps: here a version of '<.>' that uses a unicode symbol------ The hex value of the UTF-8 character ⊙ is 0x2299.------ A convenient VIM key-map is:------ > iabbrev <buffer> ../ ⊙----(⊙) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)-(⊙) = (<.>)-infixr 4 ⊙-{-# INLINE (⊙) #-}-{-# DEPRECATED (⊙) "use '<*<' instead" #-}---- -------------------------------------------------------------------------- ----- Applicative Option Parsing with Default Values---- | An operator for applying a setter to an option parser that yields a value.------ Example usage:------ > data Auth = Auth--- >     { _user ∷ !String--- >     , _pwd ∷ !String--- >     }--- >--- > user ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth--- > user f s = (\u → s { _user = u }) <$> f (_user s)--- >--- > pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth--- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)--- >--- > -- or with lenses and TemplateHaskell just:--- > -- $(makeLenses ''Auth)--- >--- > pAuth ∷ MParser Auth--- > pAuth = id--- >    <$< user .:: strOption--- >        × long "user"--- >        ⊕ short 'u'--- >        ⊕ help "user name"--- >    <*< pwd .:: strOption--- >        × long "pwd"--- >        ⊕ help "password for user"----(.::) ∷ (Alternative φ, Applicative φ) ⇒ Lens' α β → φ β → φ (α → α)-(.::) a opt = set a <$> opt <|> pure id-infixr 5 .::-{-# INLINE (.::) #-}---- | An operator for applying a setter to an option parser that yields--- a modification function.------ Example usage:------ > data HttpURL = HttpURL--- >     { _auth ∷ !Auth--- >     , _domain ∷ !String--- >     }--- >--- > auth ∷ Functor φ ⇒ (Auth → φ Auth) → HttpURL → φ HttpURL--- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)--- >--- > domain ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL--- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)--- >--- > path ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL--- > path f s = (\u → s { _path = u }) <$> f (_path s)--- >--- > -- or with lenses and TemplateHaskell just:--- > -- $(makeLenses ''HttpURL)--- >--- > pHttpURL ∷ MParser HttpURL--- > pHttpURL = id--- >     <$< auth %:: pAuth--- >     <*< domain .:: strOption--- >         × long "domain"--- >         ⊕ short 'd'--- >         ⊕ help "HTTP domain"----(%::) ∷ (Alternative φ, Applicative φ) ⇒ Lens' α β → φ (β → β) → φ (α → α)-(%::) a opt = over a <$> opt <|> pure id-infixr 5 %::-{-# INLINE (%::) #-}---- | Type of option parsers that yield a modification function.----type MParser α = O.Parser (α → α)---- -------------------------------------------------------------------------- ----- Parsing of Configuration Files with Default Values--dropAndUncaml ∷ Int → String → String-dropAndUncaml i l-    | length l < i + 1 = l-    | otherwise = let (h:t) = drop i l-        in toLower h : concatMap (\x → if isUpper x then "-" ⊕ [toLower x] else [x]) t---- | A JSON 'Value' parser for a property of a given--- 'Object' that updates a setter with the parsed value.------ > data Auth = Auth--- >     { _userId ∷ !Int--- >     , _pwd ∷ !String--- >     }--- >--- > userId ∷ Functor φ ⇒ (Int → φ Int) → Auth → φ Auth--- > userId f s = (\u → s { _userId = u }) <$> f (_userId s)--- >--- > pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth--- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)--- >--- > -- or with lenses and TemplateHaskell just:--- > -- $(makeLenses ''Auth)--- >--- > instance FromJSON (Auth → Auth) where--- >     parseJSON = withObject "Auth" $ \o → id--- >         <$< setProperty user "user" p o--- >         <*< setProperty pwd "pwd" parseJSON o--- >       where--- >         p = withText "user" $ \case--- >             "alice" → pure (0 ∷ Int)--- >             "bob" → pure 1--- >             e → fail $ "unrecognized user " ⊕ e----setProperty-    ∷ Lens' α β -- ^ a lens into the target that is updated by the parser-    → T.Text -- ^ the JSON property name-    → (Value → Parser β) -- ^ the JSON 'Value' parser that is used to parse the value of the property-    → Object -- ^ the parsed JSON 'Value' 'Object'-    → Parser (α → α)-setProperty s k p o = case H.lookup k o of-    Nothing → pure id-    Just v → set s <$> p v---- | A variant of the 'setProperty' that uses the default 'parseJSON' method from the--- 'FromJSON' instance to parse the value of the property. Its usage pattern mimics the--- usage pattern of the '.:' operator from the aeson library.------ > data Auth = Auth--- >     { _user ∷ !String--- >     , _pwd ∷ !String--- >     }--- >--- > user ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth--- > user f s = (\u → s { _user = u }) <$> f (_user s)--- >--- > pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth--- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)--- >--- > -- or with lenses and TemplateHaskell just:--- > -- $(makeLenses ''Auth)--- >--- > instance FromJSON (Auth → Auth) where--- >     parseJSON = withObject "Auth" $ \o → id--- >         <$< user ..: "user" × o--- >         <*< pwd ..: "pwd" × o----(..:) ∷ FromJSON β ⇒ Lens' α β → T.Text → Object → Parser (α → α)-(..:) s k = setProperty s k parseJSON-infix 6 ..:-{-# INLINE (..:) #-}---- | A variant of the aeson operator '.:' that creates a parser--- that modifies a setter with a parsed function.------ > data HttpURL = HttpURL--- >     { _auth ∷ !Auth--- >     , _domain ∷ !String--- >     }--- >--- > auth ∷ Functor φ ⇒ (Auth → φ Auth) → HttpURL → φ HttpURL--- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)--- >--- > domain ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL--- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)--- >--- > path ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL--- > path f s = (\u → s { _path = u }) <$> f (_path s)--- >--- > -- or with lenses and TemplateHaskell just:--- > -- $(makeLenses ''HttpURL)--- >--- > instance FromJSON (HttpURL → HttpURL) where--- >     parseJSON = withObject "HttpURL" $ \o → id--- >         <$< auth %.: "auth" × o--- >         <*< domain ..: "domain" × o----(%.:) ∷ FromJSON (β → β) ⇒ Lens' α β → T.Text → Object → Parser (α → α)-(%.:) s k o = case H.lookup k o of-    Nothing → pure id-    Just v → over s <$> parseJSON v-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--boolReader-    ∷ (Eq a, Show a, CI.FoldCase a, IsString a, IsString e, Monoid e)-    ⇒ a-    → Either e Bool-boolReader x = case CI.mk x of-    "true" → Right True-    "false" → Right False-    _ → 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-boolOption mods = O.option (O.eitherReader boolReader)-    % O.metavar "true|false"-    <> O.completeWith ["true", "false", "TRUE", "FALSE", "True", "False"]-    <> mods--fileOption-    ∷ O.Mod O.OptionFields String-    → O.Parser FilePath-fileOption mods = O.strOption-    % O.metavar "FILE"-    <> O.action "file"-    <> mods--eitherReadP-    ∷ T.Text-    → P.ReadP a-    → T.Text-    → Either T.Text a-eitherReadP label p s =-    case [ x | (x,"") ← P.readP_to_S p (T.unpack s) ] of-        [x] → Right x-        []  → Left $ "eitherReadP: no parse for " <> label <> " of " <> s-        _  → Left $ "eitherReadP: ambigous parse for " <> label <> " of " <> s---- -------------------------------------------------------------------------- ----- Main Configuration---- | A validation function. The type in the 'MonadWriter' is excpected to--- be a 'Foldable' structure for collecting warnings.----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--- in the 'ProgramInfoValidate' record.----newtype ConfigValidationFunction α λ = ConfigValidationFunction-    { runConfigValidation ∷ ConfigValidation α λ-    }--type ProgramInfo α = ProgramInfoValidate α []--data ProgramInfoValidate α λ = ProgramInfo-    { _piDescription ∷ !String-      -- ^ Program Description-    , _piHelpHeader ∷ !(Maybe String)-      -- ^ Help header-    , _piHelpFooter ∷ !(Maybe String)-      -- ^ Help footer-    , _piOptionParser ∷ !(MParser α)-      -- ^ options parser for configuration-    , _piDefaultConfiguration ∷ !α-      -- ^ default configuration-    , _piValidateConfiguration ∷ !(ConfigValidationFunction α λ)-      -- ^ a validation function. The 'Right' result is interpreted as a 'Foldable'-      -- structure of warnings.-    }---- | Program Description----piDescription ∷ Lens' (ProgramInfoValidate α λ) String-piDescription = lens _piDescription $ \s a → s { _piDescription = a }-{-# INLINE piDescription #-}---- | Help header----piHelpHeader ∷ Lens' (ProgramInfoValidate α λ) (Maybe String)-piHelpHeader = lens _piHelpHeader $ \s a → s { _piHelpHeader = a }-{-# INLINE piHelpHeader #-}---- | Help footer----piHelpFooter ∷ Lens' (ProgramInfoValidate α λ) (Maybe String)-piHelpFooter = lens _piHelpFooter $ \s a → s { _piHelpFooter = a }-{-# INLINE piHelpFooter #-}---- | Options parser for configuration----piOptionParser ∷ Lens' (ProgramInfoValidate α λ) (MParser α)-piOptionParser = lens _piOptionParser $ \s a → s { _piOptionParser = a }-{-# INLINE piOptionParser #-}---- | Default configuration----piDefaultConfiguration ∷ Lens' (ProgramInfoValidate α λ) α-piDefaultConfiguration = lens _piDefaultConfiguration $ \s a → s { _piDefaultConfiguration = a }-{-# INLINE piDefaultConfiguration #-}---- | Validation Function------ The 'Right' result is interpreted as a 'Foldable' structure of warnings.----piValidateConfiguration ∷ Lens' (ProgramInfoValidate α λ) (ConfigValidationFunction α λ)-piValidateConfiguration = lens _piValidateConfiguration $ \s a → s { _piValidateConfiguration = a }-{-# INLINE piValidateConfiguration #-}---- | 'Lens' for simultaneous query and update of 'piOptionParser' and--- 'piDefaultConfiguration'. This supports to change the type of 'ProgramInfo'--- with 'over' and 'set'.----piOptionParserAndDefaultConfiguration-    ∷ Lens-        (ProgramInfoValidate α λ)-        (ProgramInfoValidate β γ)-        (MParser α, α, ConfigValidationFunction α λ)-        (MParser β, β, ConfigValidationFunction β γ)-piOptionParserAndDefaultConfiguration = lens g $ \s (a,b,c) → ProgramInfo-    { _piDescription = _piDescription s-    , _piHelpHeader = _piHelpHeader s-    , _piHelpFooter = _piHelpFooter s-    , _piOptionParser = a-    , _piDefaultConfiguration = b-    , _piValidateConfiguration = c-    }-  where-    g s = (_piOptionParser s, _piDefaultConfiguration s, _piValidateConfiguration s)-{-# INLINE piOptionParserAndDefaultConfiguration #-}---- | Smart constructor for 'ProgramInfo'.------ 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'.--- The function 'piValidateConfiguration' is set to @const (return [])@----programInfo-    ∷ String-        -- ^ program description-    → MParser α-        -- ^ parser for updating the default configuration-    → α-        -- ^ default configuration-    → ProgramInfo α-programInfo desc parser defaultConfig =-    programInfoValidate desc parser defaultConfig $ const (return ())---- | Smart constructor for 'ProgramInfo'.------ 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'.----programInfoValidate-    ∷ String-    → MParser α-    → α-    → ConfigValidation α λ-    → ProgramInfoValidate α λ-programInfoValidate desc parser defaultConfig valFunc = ProgramInfo-    { _piDescription = desc-    , _piHelpHeader = Nothing-    , _piHelpFooter = Nothing-    , _piOptionParser = parser-    , _piDefaultConfiguration = defaultConfig-    , _piValidateConfiguration = ConfigValidationFunction valFunc-    }--data AppConfiguration α = AppConfiguration-    { _printConfig ∷ !Bool-    , _mainConfig ∷ !α-    }---- | A flag that indicates that the application should--- output the effective configuration and exit.----printConfig ∷ Lens' (AppConfiguration α) Bool-printConfig = lens _printConfig $ \s a → s { _printConfig = a }---- | The configuration value that is given to the--- application.----mainConfig ∷ Lens' (AppConfiguration α) α-mainConfig = lens _mainConfig $ \s a → s { _mainConfig = a }--pAppConfiguration ∷ (FromJSON (α → α)) ⇒ α → O.Parser (AppConfiguration α)-pAppConfiguration d = AppConfiguration-    <$> O.switch-        × O.long "print-config"-        ⊕ O.short 'p'-        ⊕ O.help "Print the parsed configuration to standard out and exit"-        ⊕ O.showDefault-    <*> 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-  where-    fileReader file = fmapL (\e → "failed to parse configuration file " ⊕ file ⊕ ": " ⊕ show e)-        $ unsafePerformIO (Yaml.decodeFileEither file)--mainOptions-    ∷ ∀ α λ . FromJSON (α → α)-    ⇒ ProgramInfoValidate α λ-    → (∀ β . Maybe (MParser β))-    → O.ParserInfo (AppConfiguration α)-mainOptions ProgramInfo{..} pkgInfoParser = O.info optionParser-    $ O.progDesc _piDescription-    ⊕ O.fullDesc-    ⊕ maybe mempty O.header _piHelpHeader-    ⊕ maybe mempty O.footer _piHelpFooter-  where-    optionParser = fromMaybe (pure id) pkgInfoParser-        <*> nonHiddenHelper-        <*> (over mainConfig <$> _piOptionParser)-        <*> pAppConfiguration _piDefaultConfiguration--    -- the 'O.helper' option from optparse-applicative is hidden be default-    -- which seems a bit weired. This option doesn't hide the access to help.-    nonHiddenHelper = abortOption ShowHelpText-        × long "help"-        ⊕ short 'h'-        ⊕ short '?'-        ⊕ help "Show this help text"---- | Run an IO action with a configuration that is obtained by updating the--- given default configuration the values defined via command line arguments.------ In addition to the options defined by the given options parser the following--- options are recognized:------ [@--config-file, -c@]---     Parse the given file path as a (partial) configuration in YAML---     format.------ [@--print-config, -p@]---     Print the final parsed configuration to standard out and exit.------ [@--help, -h@]---     Print a help message and exit.----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-    validateConfig appInfo $ _mainConfig conf-    if _printConfig conf-        then B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ conf-        else mainFunction ∘ _mainConfig $ conf-  where-    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'.----validateConfig-    ∷ (Foldable λ, Monoid (λ T.Text))-    ⇒ ProgramInfoValidate α λ-    → α-    → IO ()-validateConfig appInfo conf = do-    warnings ← execWriterT ∘ exceptT (error ∘ T.unpack) return $ do-        runConfigValidation (view piValidateConfiguration appInfo) conf-    when (any (const True) warnings) $ do-        T.hPutStrLn stderr "WARNINGS:"-        mapM_ (\w → T.hPutStrLn stderr $ "warning: " ⊕ w) warnings--exceptT-    ∷ Monad μ-    ⇒ (ε → μ β)-    → (α → μ β)-    → ExceptT ε μ α-    → μ β-exceptT a b = runExceptT >=> either a b---- -------------------------------------------------------------------------- ----- Main Configuration with Package Info--pPkgInfo ∷ PkgInfo → MParser α-pPkgInfo (sinfo, detailedInfo, version, license) =-    infoO <*> detailedInfoO <*> versionO <*> licenseO-  where-    infoO = infoOption sinfo-        $ O.long "info"-        ⊕ O.short 'i'-        ⊕ O.help "Print program info message and exit"-        ⊕ O.value id-    detailedInfoO = infoOption detailedInfo-        $ O.long "long-info"-        ⊕ O.help "Print detailed program info message and exit"-        ⊕ O.value id-    versionO = infoOption version-        $ O.long "version"-        ⊕ O.short 'v'-        ⊕ O.help "Print version string and exit"-        ⊕ O.value id-    licenseO = infoOption license-        $ O.long "license"-        ⊕ O.help "Print license of the program and exit"-        ⊕ O.value id---- | Information about the cabal package. The format is:------ @(info message, detailed info message, version string, license text)@------ See the documentation of "Configuration.Utils.Setup" for a way--- how to generate this information automatically from the package--- description during the build process.----type PkgInfo =-    ( String-      -- info message-    , String-      -- detailed info message-    , String-      -- version string-    , String-      -- license text-    )---- | Run an IO action with a configuration that is obtained by updating the--- given default configuration the values defined via command line arguments.------ In addition to the options defined by the given options parser the following--- options are recognized:------ [@--config-file, -c@]---     Parse the given file path as a (partial) configuration in YAML---     format.------ [@--print-config, -p@]---     Print the final parsed configuration to standard out and exit.------ [@--help, -h@]---     Print a help message and exit.------ [@--version, -v@]---     Print the version of the application and exit.------ [@--info, -i@]---     Print a short info message for the application and exit.------ [@--long-info@]---     Print a detailed info message for the application and exit.------ [@--license@]---     Print the text of the lincense of the application and exit.----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-    validateConfig appInfo $ _mainConfig conf-    if _printConfig conf-        then B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ conf-        else mainFunction ∘ _mainConfig $ conf-  where-    mainOpts = mainOptions appInfo (Just $ pPkgInfo pkgInfo)-    parserPrefs = O.prefs O.disambiguate---- -------------------------------------------------------------------------- ----- Configuration of Optional Values---- $simplemaybe--- Optional configuration values are supposed to be encoded by wrapping--- the respective type with 'Maybe'.------ For simple values the standard 'FromJSON' instance from the aeson--- package can be used along with the '..:' operator.------ > data LogConfig = LogConfig--- >    { _logLevel ∷ !Int--- >    , _logFile ∷ !(Maybe String)--- >    }--- >--- > $(makeLenses ''LogConfig)--- >--- > defaultLogConfig ∷ LogConfig--- > defaultLogConfig = LogConfig--- >     { _logLevel = 1--- >     , _logFile = Nothing--- >     }--- >--- > instance FromJSON (LogConfig → LogConfig) where--- >     parseJSON = withObject "LogConfig" $ \o → id--- >         <$< logLevel ..: "LogLevel" % o--- >         <*< logFile ..: "LogConfig" % o--- >--- > instance ToJSON LogConfig where--- >     toJSON config = object--- >         [ "LogLevel" .= _logLevel config--- >         , "LogConfig" .= _logFile config--- >         ]--- >------ When defining command line option parsers with '.::' and '%::' all--- options are optional. When an option is not present on the command--- line the default value is used. For 'Maybe' values it is therefore--- enough to wrap the parsed value into 'Just'.------ > pLogConfig ∷ MParser LogConfig--- > pLogConfig = id--- > #if MIN_VERSION_optparse-applicative(0,10,0)--- >     <$< logLevel .:: option auto--- > #else--- >     <$< logLevel .:: option--- > #endif--- >         % long "log-level"--- >         % metavar "INTEGER"--- >         % help "log level"--- >     <*< logFile .:: fmap Just % strOption--- >         % long "log-file"--- >         % metavar "FILENAME"--- >         % help "log file name"------- $recordmaybe------ For product-type (record) 'Maybe' values the following orphan 'FromJSON'--- instance is provided:------ > instance (FromJSON (a → a), FromJSON a) ⇒ FromJSON (Maybe a → Maybe a)--- >     parseJSON Null = pure (const Nothing)--- >     parseJSON v = f <$> parseJSON v <*> parseJSON v--- >       where--- >         f g _ Nothing = Just g--- >         f _ g (Just x) = Just (g x)------ (Using an orphan instance is generally problematic but convenient in--- this case. It's unlikely that an instance for this type is needed elsewhere.--- If this is an issue for you, please let me know. In that case we can define a--- new type for optional configuration values.)------ The semantics are as follows:------ * If the parsed configuration value is 'Null' the result is 'Nothing'.--- * If the parsed configuration value is not 'Null' then the result is---   an update function that------     * updates the given default value if this value is @Just x@---       or---     * is a constant function that returns the value that is parsed---       from the configuration using the 'FromJSON' instance for the---       configuration type.------ Note, that this instance requires an 'FromJSON' instance for the--- configuration type itself as well as a 'FromJSON' instance for the update--- function of the configuration type. The former can be defined by means of the--- latter as follows:------ > instance FromJSON MyType where--- >     parseJSON v = parseJSON v <*> pure defaultMyType------ This instance will cause the usage of 'defaultMyType' as default value if the--- default value that is given to the configuration parser is 'Nothing' and the--- parsed configuration is not 'Null'.----instance (FromJSON (a → a), FromJSON a) ⇒ FromJSON (Maybe a → Maybe a) where--    -- | If the configuration explicitly requires 'Null' the result-    -- is 'Nothing'.-    ---    parseJSON Null = pure (const Nothing)--    -- | If the default value is @(Just x)@ and the configuration-    -- provides and update function @f@ then result is @Just f@.-    ---    -- If the default value is 'Nothing' and the configuration-    -- is parsed using a parser for a constant value (and not-    -- an update function).-    ---    parseJSON v = f <$> parseJSON v <*> parseJSON v-      where-        f g _ Nothing = Just g-        f _ g (Just x) = Just (g x)---- | Commandline parser for record 'Maybe' values------ == Example:------ > data Setting = Setting--- >     { _setA ∷ !Int--- >     , _setB ∷ !String--- >     }--- >     deriving (Show, Read, Eq, Ord, Typeable)--- >--- > $(makeLenses ''Setting)--- >--- > defaultSetting ∷ Setting--- > defaultSetting = Setting--- >     { _setA = 0--- >     , _setB = 1--- >     }--- >--- > instance ToJSON Setting where--- >     toJSON setting = object--- >        [ "a" .= _setA setting--- >        , "b" .= _setB setting--- >        ]--- >--- > instance FromJSON (Setting → Setting) where--- >     parseJSON = withObject "Setting" $ \o → id--- >         <$< setA ..: "a" % o--- >         <*< setB ..: "b" % o--- >--- > instance FromJSON Setting where--- >    parseJSON v = parseJSON v <*> pure defaultSetting--- >--- > pSetting ∷ MParser Setting--- > pSetting = id--- >     <$< setA .:: option auto--- >         % short 'a'--- >         <> metavar "INT"--- >         <> help "set a"--- >     <*< setB .:: option auto--- >         % short 'b'--- >         <> metavar "INT"--- >         <> help "set b"--- >--- > -- | Use 'Setting' as 'Maybe' in a configuration:--- > ----- > data Config = Config--- >     { _maybeSetting ∷ !(Maybe Setting)--- >     }--- >     deriving (Show, Read, Eq, Ord, Typeable)--- >--- > $(makeLenses ''Config)--- >--- > defaultConfig ∷ Config--- > defaultConfig = Config--- >     { _maybeSetting = defaultSetting--- >     }--- >--- > instance ToJSON Config where--- >     toJSON config = object--- >         [ "setting" .= maybeSetting--- >         ]--- >--- > instance FromJSON (Config → Config) where--- >     parseJSON = withObject "Config" $ \o → id--- >         <$< maybeSetting %.: "setting" % o--- >--- > pConfig ∷ MParser Config--- > pConfig = id--- >     <$< maybeSetting %:: (maybeOption defaultSetting--- >         <$> pEnableSetting--- >         <*> pSetting)--- >   where--- >     pEnableSetting = boolOption--- >         % long "setting-enable"--- >         <> value False--- >         <> help "Enable configuration flags for setting"----maybeOption-    ∷ a-        -- ^ default value that is used if base configuration is 'Nothing'-    → Bool-        -- ^ whether to enable this parser or not (usually is a boolean option parser)-    → (a → a)-        -- ^ update function (usually given as applicative 'MParser a')-    → Maybe a-        -- ^ the base value that is updated (usually the result of parsing the configuraton file)-    → Maybe a-maybeOption _ False _ Nothing = Nothing -- not enabled-maybeOption defA True update Nothing = Just $ update defA -- disabled in config file but enabled by command line-maybeOption _ _ update (Just val) = Just $ update val -- enabled by config file and possibly by command line+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module: Configuration.Utils+-- Description: Utilities for Configuring Programs+-- Copyright: Copyright © 2014-2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- This module provides a collection of utilities on top of the packages+-- optparse-applicative, aeson, and yaml, for configuring libraries and+-- applications in a composable way.+--+-- The main feature is the integration of command line option parsing and+-- configuration files.+--+-- The purpose is to make management of configurations easy by providing an+-- idiomatic style of defining and deploying configurations in a modular+-- and composable way.+--+-- = Usage+--+-- The module provides operators and functions that make the implementation of+-- these entities easy for the common case that the configurations are encoded+-- mainly as nested records.+--+-- For each data type that is used as as component in a configuration type+-- the following must be provided:+--+-- 1. a /default value/,+--+-- 2. a /'FromJSON' instance/ that yields a function that takes a value and+--    updates that value with the parsed values,+--+-- 3. a /'ToJSON' instance/, and+--+-- 4. a /command line options parser/ that yields a function that takes a value+--    and updates that value with the values provided as command line options.+--+-- In addition to the above optionally a /validation function/ may be provided+-- that (recursively) validates a configuration value and returns either+-- an error or a (possibly empty) list-like structure of warnings.+--+-- The modules+--+-- * "Configuration.Utils.CommandLine",+-- * "Configuration.Utils.ConfigFile", and+-- * "Configuration.Utils.Operators"+--+-- contain tools and examples for defining above prerequisites for using a+-- type in a configuration type.+--+-- The provided functions and operators assume that lenses for the+-- configuration record types are provided.+--+-- The module "Configuration.Utils.Monoid" provides tools for the case that+-- a /simple type/ is a container with a monoid instance, such as @List@ or+-- @HashMap@.+--+-- The module "Configuration.Utils.Maybe" explains the usage of optional+-- 'Maybe' values in configuration types.+--+-- = Usage Example+--+-- Beside the examples that are provided in the haddock documentation there is+-- a complete usage example in the file+-- <https://github.com/alephcloud/hs-configuration-tools/blob/master/examples/Example.hs example/Example.hs>+-- of the cabal package.+--+module Configuration.Utils+(+-- * Program Configuration+  ProgramInfo+, programInfo+, piDescription+, piHelpHeader+, piHelpFooter+, piOptionParser+, piDefaultConfiguration+, piConfigurationFiles++-- * Program Configuration with Validation of Configuration Values+, ConfigValidation+, programInfoValidate++-- * Running a Configured Application+, runWithConfiguration+, PkgInfo+, runWithPkgInfoConfiguration+, parseConfiguration++-- * Command Line Option Parsing with Default Values+, module Configuration.Utils.CommandLine++-- * Parsing of Configuration Files with Default Values+, module Configuration.Utils.ConfigFile++-- * Miscellaneous Utilities+, module Configuration.Utils.Operators+, Lens'+, Lens++-- * Configuration of Optional Values+, module Configuration.Utils.Maybe++-- * Configuration of Monoids+, module Configuration.Utils.Monoid++-- * Low-level Configuration Validation+, ProgramInfoValidate+, piValidateConfiguration+, ConfigValidationFunction(..)+, piOptionParserAndDefaultConfiguration+) where++import Configuration.Utils.CommandLine+import Configuration.Utils.ConfigFile hiding (parseConfigFiles)+import qualified Configuration.Utils.ConfigFile as CF (parseConfigFiles)+import Configuration.Utils.Internal+import Configuration.Utils.Maybe+import Configuration.Utils.Monoid+import Configuration.Utils.Operators+import Configuration.Utils.Validation++import Control.Monad.Except hiding (mapM_)+import Control.Monad.Writer hiding (mapM_)++import qualified Data.ByteString.Char8 as B8+import Data.Foldable+import Data.Maybe+import Data.Monoid.Unicode+import Data.String+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Yaml as Yaml++import qualified Options.Applicative.Types as O++import qualified Options.Applicative as O++import Prelude hiding (concatMap, mapM_, any)+import Prelude.Unicode++import System.IO++import qualified Text.PrettyPrint.ANSI.Leijen as P++#ifdef REMOTE_CONFIGS+import Control.Monad.Trans.Control+#endif++-- -------------------------------------------------------------------------- --+-- Main Configuration++-- | A newtype wrapper around a validation function. The only purpose of+-- this type is to avoid @ImpredicativeTypes@ when storing the function+-- in the 'ProgramInfoValidate' record.+--+newtype ConfigValidationFunction α λ = ConfigValidationFunction+    { runConfigValidation ∷ ConfigValidation α λ+    }++type ProgramInfo α = ProgramInfoValidate α []++data ProgramInfoValidate α λ = ProgramInfo+    { _piDescription ∷ !String+      -- ^ Program Description+    , _piHelpHeader ∷ !(Maybe String)+      -- ^ Help header+    , _piHelpFooter ∷ !(Maybe String)+      -- ^ Help footer+    , _piOptionParser ∷ !(MParser α)+      -- ^ options parser for configuration+    , _piDefaultConfiguration ∷ !α+      -- ^ default configuration+    , _piValidateConfiguration ∷ !(ConfigValidationFunction α λ)+      -- ^ a validation function. The 'Right' result is interpreted as a 'Foldable'+      -- structure of warnings.+    , _piConfigurationFiles ∷ ![ConfigFile]+      -- ^ a list of configuration files that are loaded in order+      -- before any command line argument is evaluated.+    }++-- | Program Description+--+piDescription ∷ Lens' (ProgramInfoValidate α λ) String+piDescription = lens _piDescription $ \s a → s { _piDescription = a }+{-# INLINE piDescription #-}++-- | Help header+--+piHelpHeader ∷ Lens' (ProgramInfoValidate α λ) (Maybe String)+piHelpHeader = lens _piHelpHeader $ \s a → s { _piHelpHeader = a }+{-# INLINE piHelpHeader #-}++-- | Help footer+--+piHelpFooter ∷ Lens' (ProgramInfoValidate α λ) (Maybe String)+piHelpFooter = lens _piHelpFooter $ \s a → s { _piHelpFooter = a }+{-# INLINE piHelpFooter #-}++-- | Options parser for configuration+--+piOptionParser ∷ Lens' (ProgramInfoValidate α λ) (MParser α)+piOptionParser = lens _piOptionParser $ \s a → s { _piOptionParser = a }+{-# INLINE piOptionParser #-}++-- | Default configuration+--+piDefaultConfiguration ∷ Lens' (ProgramInfoValidate α λ) α+piDefaultConfiguration = lens _piDefaultConfiguration $ \s a → s { _piDefaultConfiguration = a }+{-# INLINE piDefaultConfiguration #-}++-- | Validation Function+--+-- The 'Right' result is interpreted as a 'Foldable' structure of warnings.+--+piValidateConfiguration ∷ Lens' (ProgramInfoValidate α λ) (ConfigValidationFunction α λ)+piValidateConfiguration = lens _piValidateConfiguration $ \s a → s { _piValidateConfiguration = a }+{-# INLINE piValidateConfiguration #-}++-- | Configuration files that are loaded in order before any command line+-- argument is evaluated.+--+piConfigurationFiles ∷ Lens' (ProgramInfoValidate α λ) [ConfigFile]+piConfigurationFiles = lens _piConfigurationFiles $ \s a → s { _piConfigurationFiles = a }+{-# INLINE piConfigurationFiles #-}++-- | 'Lens' for simultaneous query and update of 'piOptionParser' and+-- 'piDefaultConfiguration'. This supports to change the type of 'ProgramInfo'+-- with 'over' and 'set'.+--+piOptionParserAndDefaultConfiguration+    ∷ Lens+        (ProgramInfoValidate α λ)+        (ProgramInfoValidate β γ)+        (MParser α, α, ConfigValidationFunction α λ)+        (MParser β, β, ConfigValidationFunction β γ)+piOptionParserAndDefaultConfiguration = lens g $ \s (a,b,c) → ProgramInfo+    { _piDescription = _piDescription s+    , _piHelpHeader = _piHelpHeader s+    , _piHelpFooter = _piHelpFooter s+    , _piOptionParser = a+    , _piDefaultConfiguration = b+    , _piValidateConfiguration = c+    , _piConfigurationFiles = _piConfigurationFiles s+    }+  where+    g s = (_piOptionParser s, _piDefaultConfiguration s, _piValidateConfiguration s)+{-# INLINE piOptionParserAndDefaultConfiguration #-}++-- | Smart constructor for 'ProgramInfo'.+--+-- 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'.+-- The function 'piValidateConfiguration' is set to @const (return [])@+--+programInfo+    ∷ String+        -- ^ program description+    → MParser α+        -- ^ parser for updating the default configuration+    → α+        -- ^ default configuration+    → ProgramInfo α+programInfo desc parser defaultConfig =+    programInfoValidate desc parser defaultConfig $ const (return ())++-- | Smart constructor for 'ProgramInfo'.+--+-- 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'.+--+programInfoValidate+    ∷ String+    → MParser α+    → α+    → ConfigValidation α λ+    → ProgramInfoValidate α λ+programInfoValidate desc parser defaultConfig valFunc = ProgramInfo+    { _piDescription = desc+    , _piHelpHeader = Nothing+    , _piHelpFooter = Nothing+    , _piOptionParser = parser+    , _piDefaultConfiguration = defaultConfig+    , _piValidateConfiguration = ConfigValidationFunction valFunc+    , _piConfigurationFiles = []+    }++-- -------------------------------------------------------------------------- --+-- AppConfiguration++-- | An /internal/ data type that is used during configuration parsing to+-- represent the overall application configuration which includes+--+-- 1. the /user/ configuration, which is actual configuration value that+--    is given to the application and+--+-- 2. the /meta/ configuration, which are all settings that determine how the+--    actual /user/ configuration is loaded and parsed.+--+-- NOTE that /meta/ configuration settings can only be provided via command+-- line options but not through configuration files.+--+data AppConfiguration α = AppConfiguration+    { _printConfig ∷ !Bool+    , _configFilesConfig ∷ !ConfigFilesConfig+    , _configFiles ∷ ![ConfigFile]+    , _mainConfig ∷ !α+    }++-- | A flag that indicates that the application should output the effective+-- configuration and exit.+--+printConfig ∷ Lens' (AppConfiguration α) Bool+printConfig = lens _printConfig $ \s a → s { _printConfig = a }++-- | The 'ConfigFilesConfig' collects all parameters that determine how+-- configuration files are loaded and parsed.+--+configFilesConfig ∷ Lens' (AppConfiguration α) ConfigFilesConfig+configFilesConfig = lens _configFilesConfig $ \s a → s { _configFilesConfig = a }++-- | A list of configuration file locations. Configuration file locations are+-- set either statically in the code or are provided dynamically on the command+-- line via @--config-file@ options.+--+configFiles ∷ Lens' (AppConfiguration α) [ConfigFile]+configFiles = lens _configFiles $ \s a → s { _configFiles = a }++-- | The /user/ configuration. During parsing this is represented as an update+-- function that yields a configuration value when applied to a default+-- value.+--+mainConfig ∷ Lens (AppConfiguration α) (AppConfiguration β) α β+mainConfig = lens _mainConfig $ \s a → s { _mainConfig = a }++-- | This function parsers /all/ command line options:+--+-- 1. 'ConfigFilesConfig' options that determine how configuration+--    files are loaded.+--+-- 2. 'ConfigFiles' options are all @--config-file@ options.+--+-- 3. Other /meta/ options, such as @--print-config@.+--+-- 4. Options for the actual user /configuration/. The user configuration+--    is represented as an update function that yields a configuration+--    value when applied to an default value.+--+pAppConfiguration+    ∷ O.Parser (α → α)+    → O.Parser (AppConfiguration (α → α))+pAppConfiguration mainParser = AppConfiguration+    <$> pPrintConfig+    <*> (pConfigFilesConfig <*> pure defaultConfigFilesConfig)+    <*> many pConfigFile+    <*> mainParser+  where+    pPrintConfig = O.switch+        × O.long "print-config"+        ⊕ O.short 'p'+        ⊕ O.help "Print the parsed configuration to standard out and exit"+        ⊕ O.showDefault++    pConfigFile = ConfigFileRequired ∘ T.pack <$> O.strOption+        × O.long "config-file"+        ⊕ O.short 'c'+        ⊕ O.metavar "FILE"+        ⊕ O.help "Configuration file in YAML format. If more than a single config file option is present files are loaded in the order in which they appear on the command line."++-- -------------------------------------------------------------------------- --+-- Main Configuration without Package Info++-- | Run an IO action with a configuration that is obtained by updating the+-- given default configuration the values defined via command line arguments.+--+-- In addition to the options defined by the given options parser the following+-- options are recognized:+--+-- [@--config-file, -c@]+--     Parse the given file path as a (partial) configuration in YAML+--     format.+--+-- [@--print-config, -p@]+--     Print the final parsed configuration to standard out and exit.+--+-- [@--help, -h@]+--     Print a help message and exit.+--+-- As long as the package wasn't build with @-f-remote-configs@ the following+-- two options are available. They affect how configuration files+-- are loaded from remote URLs.+--+-- [@--config-https-insecure=true|false@]+--     Bypass certificate validation for all HTTPS+--     connections to all services.+--+-- [@--config-https-allow-cert=HOSTNAME:PORT:FINGERPRINT@]+--     Unconditionally trust the certificate for connecting+--     to the service.+--+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 = runInternal appInfo Nothing++-- -------------------------------------------------------------------------- --+-- Main Configuration with Package Info++pPkgInfo ∷ PkgInfo → MParser α+pPkgInfo (sinfo, detailedInfo, version, license) =+    infoO <*> detailedInfoO <*> versionO <*> licenseO+  where+    infoO = infoOption sinfo+        $ O.long "info"+        ⊕ O.short 'i'+        ⊕ O.help "Print program info message and exit"+        ⊕ O.value id+    detailedInfoO = infoOption detailedInfo+        $ O.long "long-info"+        ⊕ O.help "Print detailed program info message and exit"+        ⊕ O.value id+    versionO = infoOption version+        $ O.long "version"+        ⊕ O.short 'v'+        ⊕ O.help "Print version string and exit"+        ⊕ O.value id+    licenseO = infoOption license+        $ O.long "license"+        ⊕ O.help "Print license of the program and exit"+        ⊕ O.value id++-- | Information about the cabal package. The format is:+--+-- @(info message, detailed info message, version string, license text)@+--+-- See the documentation of "Configuration.Utils.Setup" for a way+-- how to generate this information automatically from the package+-- description during the build process.+--+type PkgInfo =+    ( String+      -- info message+    , String+      -- detailed info message+    , String+      -- version string+    , String+      -- license text+    )++-- | Run an IO action with a configuration that is obtained by updating the+-- given default configuration the values defined via command line arguments.+--+-- In addition to the options defined by the given options parser the following+-- options are recognized:+--+-- [@--config-file, -c@]+--     Parse the given file path as a (partial) configuration in YAML+--     format.+--+-- [@--print-config, -p@]+--     Print the final parsed configuration to standard out and exit.+--+-- [@--help, -h@]+--     Print a help message and exit.+--+-- [@--version, -v@]+--     Print the version of the application and exit.+--+-- [@--info, -i@]+--     Print a short info message for the application and exit.+--+-- [@--long-info@]+--     Print a detailed info message for the application and exit.+--+-- [@--license@]+--     Print the text of the license of the application and exit.+--+-- As long as the package wasn't build with @-f-remote-configs@ the following+-- two options are available. They affect how configuration files+-- are loaded from remote URLs.+--+-- [@--config-https-insecure=true|false@]+--     Bypass certificate validation for all HTTPS+--     connections to all services.+--+-- [@--config-https-allow-cert=HOSTNAME:PORT:FINGERPRINT@]+--     Unconditionally trust the certificate for connecting+--     to the service.+--+runWithPkgInfoConfiguration+    ∷ (FromJSON (α → α), ToJSON α, Foldable λ, Monoid (λ T.Text))+    ⇒ ProgramInfoValidate α λ+        -- ^ program info value; use 'programInfo' to construct a value of this+        -- type+    → PkgInfo+        -- 'PkgInfo' value that contains 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 =+    runInternal appInfo (Just $ pPkgInfo pkgInfo)++-- -------------------------------------------------------------------------- --+-- Internal main function++mainOptions+    ∷ ∀ α λ . FromJSON (α → α)+    ⇒ ProgramInfoValidate α λ+        -- ^ Program Info value which may include a validation function++    → (∀ β . Maybe (MParser β))+        -- ^ Maybe a package info parser. This parser is run only for its+        -- side effects. It is supposed to /intercept/ the parsing process+        -- and execute any implied action (showing help messages).++    → O.ParserInfo (AppConfiguration (α → α))+mainOptions ProgramInfo{..} pkgInfoParser = O.info optionParser+    $ O.progDesc _piDescription+    ⊕ O.fullDesc+    ⊕ maybe mempty O.header _piHelpHeader+    ⊕ O.footerDoc (Just $ defaultFooter ⊕ maybe mempty P.text _piHelpFooter)+  where+    optionParser =+        -- these are identity parsers that are only applied for their side effects+        fromMaybe (pure id) pkgInfoParser <*> nonHiddenHelper+        -- this parser produces the results+        <*> pAppConfiguration _piOptionParser++    -- the 'O.helper' option from optparse-applicative is hidden be default+    -- which seems a bit weired. This option doesn't hide the access to help.+    nonHiddenHelper = abortOption ShowHelpText+        × long "help"+        ⊕ short 'h'+        ⊕ short '?'+        ⊕ help "Show this help message"++    defaultFooter = P.vsep+        [ par "Configurations are loaded in order from the following sources:"+        , P.indent 2 ∘ P.vsep $ zipWith ($) (catMaybes [staticFiles, cmdFiles, cmdOptions]) [1..]+        , ""+        , P.fillSep+            [ par "Configuration file locations can be either local file system paths"+            , par "or remote HTTP or HTTPS URLs. Remote URLs must start with"+            , par "either \"http://\" or \"https://\"."+            ]+        , ""+        , P.fillSep+            [ par "Configuration settings that are loaded later overwrite settings"+            , par "that were loaded before."+            ]+        , ""+        ]++    staticFiles+        | null _piConfigurationFiles = Nothing+        | otherwise = Just $ \n → P.hang 3 $ P.vsep+            [ P.int n ⊕ "." P.</> par "Configuration files at the following locations:"+            , P.vsep $ map (\f → "* " ⊕ printConfigFile f) _piConfigurationFiles+            ]+    cmdFiles = Just $ \n → P.hang 3 $ P.fillSep+        [ P.int n ⊕ "." P.</> par "Configuration files from locations provided through"+        , par "--config-file options in the order as they appear."+        ]+    cmdOptions = Just $ \n → P.hang 3+        $ P.int n ⊕ "." P.</> par "Command line options."++    printConfigFile f = P.text (T.unpack $ getConfigFile f) P.<+> case f of+        ConfigFileRequired _ → P.text "(required)"+        ConfigFileOptional _ → P.text "(optional)"++    par ∷ String → P.Doc+    par = P.fillSep ∘ map P.string ∘ words++-- | Internal main function+--+runInternal+    ∷ (FromJSON (α → α), ToJSON α, Foldable λ, Monoid (λ T.Text))+    ⇒ ProgramInfoValidate α λ+        -- ^ program info value; use 'programInfo' to construct a value of this+        -- type+    → (∀ β . Maybe (MParser β))+        -- 'PkgInfo' value that contains 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 ()+runInternal appInfo maybePkgInfo mainFunction = do++    -- Parse command line arguments and add static config files to resulting app config+    cliAppConf ← configFiles `over` (⊕) (_piConfigurationFiles appInfo) <$>+        O.customExecParser parserPrefs (mainOptions appInfo maybePkgInfo)++    -- Load and parse all configuration files+    appConf ← cliAppConf & mainConfig `id` \a → a <$> errorT × CF.parseConfigFiles+        (_configFilesConfig cliAppConf)+        (_piDefaultConfiguration appInfo)+        (_configFiles cliAppConf)++    -- Validate final configuration+    validateConfig appInfo $ _mainConfig appConf++    if _printConfig appConf+        then B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ appConf+        else mainFunction ∘ _mainConfig $ appConf+  where+    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.+--+parseConfiguration+    ∷+        ( Applicative m+        , MonadIO m+#ifdef REMOTE_CONFIGS+        , MonadBaseControl IO m+#endif+        , 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++    -- Parse command line arguments (add static config files to resulting app config)+    cliAppConf ← case O.execParserPure parserPrefs (mainOptions appInfo Nothing) args of+        O.Success a → return $ a & configFiles `over` (⊕) (_piConfigurationFiles appInfo)+        O.Failure e → throwError ∘ T.pack ∘ fst $ renderFailure e (T.unpack appName)+        O.CompletionInvoked _ → throwError "command line parser returned completion result"++    -- Load and parse all configuration files+    appConf ← cliAppConf & mainConfig `id` \a → a <$> CF.parseConfigFiles+        (_configFilesConfig cliAppConf)+        (_piDefaultConfiguration appInfo)+        (_configFiles cliAppConf)++    -- Validate final configuration+    void ∘ validate appInfo $ _mainConfig appConf++    return $ _mainConfig appConf+  where+    parserPrefs = O.prefs O.disambiguate+    validate i conf = runWriterT $+        runConfigValidation (view piValidateConfiguration i) conf++-- -------------------------------------------------------------------------- --+-- Validation++-- | Validates a configuration value. Throws an user error+-- if there is an error. If there are warnings they are+-- printed to 'stderr'.+--+validateConfig+    ∷ (Foldable λ, Monoid (λ T.Text))+    ⇒ ProgramInfoValidate α λ+    → α+    → IO ()+validateConfig appInfo conf = do+    warnings ← execWriterT ∘ 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 

@@ -0,0 +1,270 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Configuration.Utils.CommandLine+-- Description: Command Line Option Parsing with Default Values+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- This module provides tools for defining command line parsers for+-- configuration types.+--+-- Unlike /normal/ command line parsers the parsers for configuration+-- types are expected to yield an update function that takes+-- a value and updates the value with the settings from the command line.+--+-- Assuming that+--+-- * all configuration types are nested Haskell records or+--   simple types and+--+-- * that there are lenses for all record fields+--+-- usually the operators '.::' and '%::' are all that is needed from this module.+--+-- The module "Configuration.Utils.Monoid" provides tools for the case that+-- a /simple type/ is a container with a monoid instance, such as @List@ or+-- @HashMap@.+--+-- The module "Configuration.Utils.Maybe" explains the usage of optional+-- 'Maybe' values in configuration types.+--+module Configuration.Utils.CommandLine+( MParser+, (.::)+, (%::)++-- * Misc Utils+, boolReader+, boolOption+, boolOption_+, enableDisableFlag+, fileOption+, eitherReadP+, module Options.Applicative+) where++import Configuration.Utils.Internal+import Configuration.Utils.Operators++import Control.Applicative+import Control.Monad.Writer hiding (mapM_)++import qualified Data.CaseInsensitive as CI+import Data.Maybe+import Data.Monoid.Unicode+import Data.String+import qualified Data.Text as T++import Options.Applicative hiding (Parser, Success)+import qualified Options.Applicative.Types as O++import qualified Options.Applicative as O+import qualified Options.Applicative.Builder.Internal as O++import Prelude hiding (concatMap, mapM_, any)++import qualified Text.ParserCombinators.ReadP as P hiding (string)++import Prelude.Unicode++-- -------------------------------------------------------------------------- --+-- Applicative Option Parsing with Default Values++-- | Type of option parsers that yield a modification function.+--+type MParser α = O.Parser (α → α)++-- | An operator for applying a setter to an option parser that yields a value.+--+-- Example usage:+--+-- > data Auth = Auth+-- >     { _user ∷ !String+-- >     , _pwd ∷ !String+-- >     }+-- >+-- > user ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth+-- > user f s = (\u → s { _user = u }) <$> f (_user s)+-- >+-- > pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth+-- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)+-- >+-- > -- or with lenses and TemplateHaskell just:+-- > -- $(makeLenses ''Auth)+-- >+-- > pAuth ∷ MParser Auth+-- > pAuth = id+-- >    <$< user .:: strOption+-- >        × long "user"+-- >        ⊕ short 'u'+-- >        ⊕ help "user name"+-- >    <*< pwd .:: strOption+-- >        × long "pwd"+-- >        ⊕ help "password for user"+--+(.::) ∷ (Alternative φ, Applicative φ) ⇒ Lens' α β → φ β → φ (α → α)+(.::) a opt = set a <$> opt <|> pure id+infixr 5 .::+{-# INLINE (.::) #-}++-- | An operator for applying a setter to an option parser that yields+-- a modification function.+--+-- Example usage:+--+-- > data HttpURL = HttpURL+-- >     { _auth ∷ !Auth+-- >     , _domain ∷ !String+-- >     }+-- >+-- > auth ∷ Functor φ ⇒ (Auth → φ Auth) → HttpURL → φ HttpURL+-- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)+-- >+-- > domain ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL+-- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)+-- >+-- > path ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL+-- > path f s = (\u → s { _path = u }) <$> f (_path s)+-- >+-- > -- or with lenses and TemplateHaskell just:+-- > -- $(makeLenses ''HttpURL)+-- >+-- > pHttpURL ∷ MParser HttpURL+-- > pHttpURL = id+-- >     <$< auth %:: pAuth+-- >     <*< domain .:: strOption+-- >         × long "domain"+-- >         ⊕ short 'd'+-- >         ⊕ help "HTTP domain"+--+(%::) ∷ (Alternative φ, Applicative φ) ⇒ Lens' α β → φ (β → β) → φ (α → α)+(%::) a opt = over a <$> opt <|> pure id+infixr 5 %::+{-# INLINE (%::) #-}++-- -------------------------------------------------------------------------- --+-- Misc Utilities for Command Line Option Parsing++boolReader+    ∷ (Eq a, Show a, CI.FoldCase a, IsString a, IsString e, Monoid e)+    ⇒ a+    → Either e Bool+boolReader x = case CI.mk x of+    "true" → Right True+    "false" → Right False+    _ → 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+boolOption mods = O.option (O.eitherReader boolReader)+    × O.metavar "true|false"+    ⊕ O.completeWith ["true", "false", "TRUE", "FALSE", "True", "False"]+    ⊕ mods++-- | An alternative syntax for 'boolOption' for options with long names.+--+-- Instead of taking a boolean argument the presence of the option acts as a+-- switch to set the respective configuration setting to 'True'. If the option+-- is not present the setting is left unchanged.+--+-- In addition for long option names a respective /unset flag/ is provided. For+-- instance for a flag @--verbose@ there will also be a flag @--no-verbose@.+--+-- This can still be used with short option names only, but no /unset flag/+-- would be provided.+--+boolOption_+    ∷ O.Mod O.FlagFields Bool+    → O.Parser Bool+boolOption_ mods = flag' True mods <|> flag' False nomods+  where+    O.Mod f d o = mods+    O.FlagFields names _ = f $ O.FlagFields [] False++    longName (O.OptShort _) = Nothing+    longName (O.OptLong l) = Just l+    longNames = mapMaybe longName names++    noName l = "no-" ⊕ l+    mapFlags flags = flags+        { O.flagNames = mapMaybe (\l → O.OptLong ∘ noName <$> longName l) (O.flagNames flags)+        }+    nomods = O.Mod (mapFlags ∘ f) d o+        ⊕ maybe mempty (\l → help $ "unset flag " ⊕ l) (listToMaybe $ reverse longNames)++-- | An option parser for flags that are enabled via the flag name prefixed+-- with @--enable-@ and disabled via the flag name prefix @--disable-@. The+-- prefixes are applied to all long option names. Short option names are parsed+-- unchanged and and cause the flag to be enabled.+--+-- This resembles the style of flags that is used for instances with Cabal.+--+enableDisableFlag+    ∷ O.Mod O.FlagFields Bool+    → O.Parser Bool+enableDisableFlag mods = flag' True enmods <|> flag' False dismods+  where+    O.Mod f d o = mods+    O.FlagFields names _ = f $ O.FlagFields [] False++    longName (O.OptShort _) = Nothing+    longName (O.OptLong l) = Just l+    longNames = mapMaybe longName names++    disName l = "disable-" ⊕ l+    enName l = "enable-" ⊕ l++    -- disable flags+    mapDisFlags flags = flags+        { O.flagNames = mapMaybe (\l → O.OptLong ∘ disName <$> longName l) (O.flagNames flags)+        }+    dismods = O.Mod (mapDisFlags ∘ f) d o+        ⊕ maybe mempty (\l → help $ "unset flag " ⊕ l) (listToMaybe $ reverse longNames)++    -- enable flags+    mapLong g (O.OptLong l) = O.OptLong (g l)+    mapLong _ s = s+    mapEnFlags flags = flags+        { O.flagNames = map (mapLong enName) (O.flagNames flags)+        }+    enmods = O.Mod (mapEnFlags ∘ f) d o++fileOption+    ∷ O.Mod O.OptionFields String+    → O.Parser FilePath+fileOption mods = O.strOption+    × O.metavar "FILE"+    ⊕ O.action "file"+    ⊕ mods++eitherReadP+    ∷ T.Text+    → P.ReadP a+    → T.Text+    → Either T.Text a+eitherReadP label p s =+    case [ x | (x,"") ← P.readP_to_S p (T.unpack s) ] of+        [x] → Right x+        []  → Left $ "eitherReadP: no parse for " ⊕ label ⊕ " of " ⊕ s+        _  → Left $ "eitherReadP: ambigous parse for " ⊕ label ⊕ " of " ⊕ s+

@@ -0,0 +1,397 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Configuration.Utils.ConfigFile+-- Description: Parsing of Configuration Files with Default Values+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- This module provides tools for defining configuration file+-- parsers via instances of 'FromJSON'.+--+-- Unlike /normal/ 'FromJSON' instances the parsers for configuration+-- files are expected to yield an update function that takes+-- a value and updates the value with the settings from the configuration+-- file.+--+-- Assuming that+--+-- * all configuration types are nested Haskell records or+--   simple types and+--+-- * that there are lenses for all record fields+--+-- usually the operators '..:' and '%.:' are all that is needed from this module.+--+-- The module "Configuration.Utils.Monoid" provides tools for the case that+-- a /simple type/ is a container with a monoid instance, such as @List@ or+-- @HashMap@.+--+-- The module "Configuration.Utils.Maybe" explains the usage of optional+-- 'Maybe' values in configuration types.+--+module Configuration.Utils.ConfigFile+(+-- * Parsing of Configuration Files with Default Values+  setProperty+, (..:)+, (!..:)+, updateProperty+, (%.:)++-- * Configuration File Parsing Policy+, ConfigFile(..)+, ConfigFilesConfig(..)+#if REMOTE_CONFIGS+, cfcHttpsPolicy+#endif+, defaultConfigFilesConfig+, pConfigFilesConfig++-- * Miscellaneous Utilities+, dropAndUncaml+, module Data.Aeson++-- * Internal Tools for Parsing Configuration Files+, parseConfigFiles+) where++import Configuration.Utils.CommandLine+import Configuration.Utils.Internal+import Configuration.Utils.Validation++import Control.Monad.Except hiding (mapM_)++import Data.Aeson+import Data.Aeson.Types (Parser)+import Data.Char+import Data.Foldable+import qualified Data.HashMap.Strict as H+import Data.Maybe+import Data.Monoid.Unicode+import Data.String+import qualified Data.Text as T+import Data.Typeable+import qualified Data.Yaml as Yaml++import Prelude hiding (concatMap, mapM_, any)++#ifdef REMOTE_CONFIGS+import Configuration.Utils.HttpsCertPolicy+import Configuration.Utils.Operators++import Control.Exception.Enclosed+import Control.Monad.Trans.Control++import qualified Data.ByteString.Lazy as LB+import qualified Data.List as L+import qualified Data.Text.IO as T++import qualified Network.HTTP.Client as HTTP++import Prelude.Unicode++import System.IO+#endif++-- | A JSON 'Value' parser for a property of a given+-- 'Object' that updates a setter with the parsed value.+--+-- > data Auth = Auth+-- >     { _userId ∷ !Int+-- >     , _pwd ∷ !String+-- >     }+-- >+-- > userId ∷ Functor φ ⇒ (Int → φ Int) → Auth → φ Auth+-- > userId f s = (\u → s { _userId = u }) <$> f (_userId s)+-- >+-- > pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth+-- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)+-- >+-- > -- or with lenses and TemplateHaskell just:+-- > -- $(makeLenses ''Auth)+-- >+-- > instance FromJSON (Auth → Auth) where+-- >     parseJSON = withObject "Auth" $ \o → id+-- >         <$< setProperty user "user" p o+-- >         <*< setProperty pwd "pwd" parseJSON o+-- >       where+-- >         p = withText "user" $ \case+-- >             "alice" → pure (0 ∷ Int)+-- >             "bob" → pure 1+-- >             e → fail $ "unrecognized user " ⊕ e+--+setProperty+    ∷ Lens' α β -- ^ a lens into the target that is updated by the parser+    → T.Text -- ^ the JSON property name+    → (Value → Parser β) -- ^ the JSON 'Value' parser that is used to parse the value of the property+    → Object -- ^ the parsed JSON 'Value' 'Object'+    → Parser (α → α)+setProperty s k p o = case H.lookup k o of+    Nothing → pure id+    Just v → set s <$> p v++-- | A variant of the 'setProperty' that uses the default 'parseJSON' method from the+-- 'FromJSON' instance to parse the value of the property. Its usage pattern mimics the+-- usage pattern of the '.:' operator from the aeson library.+--+-- > data Auth = Auth+-- >     { _user ∷ !String+-- >     , _pwd ∷ !String+-- >     }+-- >+-- > user ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth+-- > user f s = (\u → s { _user = u }) <$> f (_user s)+-- >+-- > pwd ∷ Functor φ ⇒ (String → φ String) → Auth → φ Auth+-- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s)+-- >+-- > -- or with lenses and TemplateHaskell just:+-- > -- $(makeLenses ''Auth)+-- >+-- > instance FromJSON (Auth → Auth) where+-- >     parseJSON = withObject "Auth" $ \o → id+-- >         <$< user ..: "user" × o+-- >         <*< pwd ..: "pwd" × o+--+(..:) ∷ FromJSON β ⇒ Lens' α β → T.Text → Object → Parser (α → α)+(..:) s k = setProperty s k parseJSON+infix 6 ..:+{-# INLINE (..:) #-}++-- | A JSON parser for a function that modifies a property+-- of a given 'Object' and updates a setter with the parsed+-- function.+--+-- > data HttpURL = HttpURL+-- >     { _auth ∷ !Auth+-- >     , _domain ∷ !String+-- >     }+-- >+-- > auth ∷ Functor φ ⇒ (Auth → φ Auth) → HttpURL → φ HttpURL+-- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)+-- >+-- > domain ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL+-- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)+-- >+-- > path ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL+-- > path f s = (\u → s { _path = u }) <$> f (_path s)+-- >+-- > -- or with lenses and TemplateHaskell just:+-- > -- $(makeLenses ''HttpURL)+-- >+-- > instance FromJSON (HttpURL → HttpURL) where+-- >     parseJSON = withObject "HttpURL" $ \o → id+-- >         <$< auth %.: "auth" × o+-- >         <*< domain ..: "domain" × o+--+updateProperty+    ∷ Lens' α β+    → T.Text+    → (Value → Parser (β → β))+    → Object+    → Parser (α → α)+updateProperty s k p o = case H.lookup k o of+    Nothing → pure id+    Just v → over s <$> p v+{-# INLINE updateProperty #-}++-- | A variant of 'updateProperty' that used the 'FromJSON' instance+-- for the update function. It mimics the aeson operator '.:'.+-- It creates a parser that modifies a setter with a parsed function.+--+-- > data HttpURL = HttpURL+-- >     { _auth ∷ !Auth+-- >     , _domain ∷ !String+-- >     }+-- >+-- > auth ∷ Functor φ ⇒ (Auth → φ Auth) → HttpURL → φ HttpURL+-- > auth f s = (\u → s { _auth = u }) <$> f (_auth s)+-- >+-- > domain ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL+-- > domain f s = (\u → s { _domain = u }) <$> f (_domain s)+-- >+-- > path ∷ Functor φ ⇒ (String → φ String) → HttpURL → φ HttpURL+-- > path f s = (\u → s { _path = u }) <$> f (_path s)+-- >+-- > -- or with lenses and TemplateHaskell just:+-- > -- $(makeLenses ''HttpURL)+-- >+-- > instance FromJSON (HttpURL → HttpURL) where+-- >     parseJSON = withObject "HttpURL" $ \o → id+-- >         <$< auth %.: "auth" × o+-- >         <*< domain ..: "domain" × o+--+(%.:) ∷ FromJSON (β → β) ⇒ Lens' α β → T.Text → Object → Parser (α → α)+(%.:) s k = updateProperty s k parseJSON+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 (!..:) #-}++-- -------------------------------------------------------------------------- --+-- Config File Parsing Policy++data ConfigFile+    = ConfigFileRequired { getConfigFile ∷ !T.Text }+    | ConfigFileOptional { getConfigFile ∷ !T.Text }+    deriving (Show, Read, Eq, Ord, Typeable)++-- | An /internal/ type for the meta configuration that specifies how the+-- configuration files are loaded and parsed.+--+#if REMOTE_CONFIGS+data ConfigFilesConfig = ConfigFilesConfig+    { _cfcHttpsPolicy ∷ !HttpsCertPolicy+    }+    deriving (Show, Eq, Typeable)++cfcHttpsPolicy ∷ Lens' ConfigFilesConfig HttpsCertPolicy+cfcHttpsPolicy = lens _cfcHttpsPolicy $ \a b → a { _cfcHttpsPolicy = b }++defaultConfigFilesConfig ∷ ConfigFilesConfig+defaultConfigFilesConfig = ConfigFilesConfig+    { _cfcHttpsPolicy = defaultHttpsCertPolicy+    }++pConfigFilesConfig ∷ MParser ConfigFilesConfig+pConfigFilesConfig = id+    <$< cfcHttpsPolicy %:: pHttpsCertPolicy "config-"++#else++data ConfigFilesConfig = ConfigFilesConfig {}++defaultConfigFilesConfig ∷ ConfigFilesConfig+defaultConfigFilesConfig = ConfigFilesConfig {}++pConfigFilesConfig ∷ MParser ConfigFilesConfig+pConfigFilesConfig = pure id+#endif++-- -------------------------------------------------------------------------- --+-- Tools for parsing configuration files++#ifdef REMOTE_CONFIGS+type ConfigFileParser μ =+    ( Functor μ+    , Applicative μ+    , MonadIO μ+    , MonadBaseControl IO μ+    , MonadError T.Text μ+    )+#else+type ConfigFileParser μ =+    ( Functor μ+    , Applicative μ+    , MonadIO μ+    , MonadError T.Text μ+    )+#endif++parseConfigFiles+    ∷ (ConfigFileParser μ, FromJSON (α → α))+    ⇒ ConfigFilesConfig+    → α+        -- ^ default configuration value+    → [ConfigFile]+        -- ^ list of configuration file paths+    → μ α+parseConfigFiles conf = foldM $ \val file →+    readConfigFile conf file <*> pure val++readConfigFile+    ∷ (ConfigFileParser μ, FromJSON (α → α))+    ⇒ ConfigFilesConfig+    → ConfigFile+        -- ^ file path+    → μ (α → α)+readConfigFile _conf file =+#ifdef REMOTE_CONFIGS+    if isRemote file then loadRemote _conf file else loadLocal file+#else+    loadLocal file+#endif++loadLocal+    ∷ (Functor μ, MonadIO μ, MonadError T.Text μ, FromJSON (α → α))+    ⇒ ConfigFile+        -- ^ file path+    → μ (α → α)+loadLocal path = do+    validateFilePath "config-file" (T.unpack file)+    exists ← (True <$ validateFile "config-file" (T.unpack file)) `catchError` \e → case path of+        ConfigFileOptional _ → return False+        ConfigFileRequired _ → throwError $ "failed to read config file: " ⊕ e+    if exists+      then+        liftIO (Yaml.decodeFileEither (T.unpack file)) >>= \case+            Left e → throwError $ "failed to parse configuration file " ⊕ file ⊕ ": " ⊕ sshow e+            Right r → return r+      else+        return id+  where+    file = getConfigFile path++#ifdef REMOTE_CONFIGS+isRemote+    ∷ ConfigFile+    → Bool+isRemote path = L.any (`T.isPrefixOf` getConfigFile path) ["http://", "https://"]++loadRemote+    ∷ (ConfigFileParser μ, FromJSON (α → α))+    ⇒ ConfigFilesConfig+    → ConfigFile+        -- ^ URL+    → μ (α → α)+loadRemote conf path = do+    validateHttpOrHttpsUrl "config-file" (T.unpack url)+    dat ← (Just <$> doHttp) `catchAnyDeep` \e →+        case path of+            ConfigFileOptional _ → do+                liftIO ∘ T.hPutStrLn stderr $ "WARNING: failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e+                return Nothing+            ConfigFileRequired _ → throwError $ "failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e++    case dat of+        Nothing → return id+        Just d → case Yaml.decodeEither' d of+            Left e → throwError $ "failed to parse remote configuration " ⊕ url ⊕ ": " ⊕ sshow e+            Right r → return r+  where+    url = getConfigFile path+    policy = _cfcHttpsPolicy conf+    doHttp = LB.toStrict ∘ HTTP.responseBody <$> liftIO × httpWithValidationPolicy url policy+#endif++-- -------------------------------------------------------------------------- --+-- Miscellaneous Utilities++dropAndUncaml ∷ Int → String → String+dropAndUncaml i l+    | length l < i + 1 = l+    | otherwise = let (h:t) = drop i l+        in toLower h : concatMap (\x → if isUpper x then "-" ⊕ [toLower x] else [x]) t+

@@ -0,0 +1,308 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Configuration.Utils.HttpsCertPolicy+-- Description: HTTPS certificate validation policy+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- This module provides means for defining and using HTTPS+-- certificate validation polices for HTTPS requests.+--+module Configuration.Utils.HttpsCertPolicy+(+-- * HTTPS Certificate Validation Policy+  HttpsCertPolicy(..)+, certPolicyInsecure+, certPolicyHostFingerprints+, defaultHttpsCertPolicy+, pHttpsCertPolicy++-- * HTTP Requests With Certificate Validation Policy+, httpWithValidationPolicy+, VerboseTlsException(..)+) where++import Configuration.Utils.CommandLine+import Configuration.Utils.Internal+import Configuration.Utils.Monoid+import Configuration.Utils.Operators+import Configuration.Utils.Validation++import Control.Monad.Except hiding (mapM_)+import Control.Monad.Writer hiding (mapM_)++import qualified Data.ByteString.Char8 as B8+import Data.Maybe+import Data.Monoid.Unicode+import Data.String+import qualified Data.Text as T+import Data.Typeable++import qualified Options.Applicative as O++import Prelude hiding (concatMap, mapM_, any)+import Prelude.Unicode++import Control.Arrow (second)+import qualified Data.ByteString.Lazy as LB+import qualified Data.List as L+import qualified Network.Connection as HTTP+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Client.TLS as HTTP+import qualified System.X509 as TLS (getSystemCertificateStore)+import qualified Data.X509.Validation as TLS (ServiceID, Fingerprint(..), getFingerprint, ValidationCacheQueryCallback)+import qualified Network.TLS as TLS hiding (HashSHA256)+import Data.Default (def)+import qualified Network.TLS.Extra as TLS (ciphersuite_all)+import Text.Read (readEither)+import qualified Data.ByteString.Base64 as B64+import Control.Monad.State hiding (mapM_)+import qualified Data.HashMap.Strict as HM+import Control.Exception (Exception, catch, throwIO, fromException)+import Data.IORef+import qualified Data.Text.Encoding as T+import qualified Data.X509 as TLS (HashALG(HashSHA256), Certificate, SignedExact, CertificateChain(..))++-- -------------------------------------------------------------------------- --+-- HTTPS Certificate Validation Policy++data HttpsCertPolicy = HttpsCertPolicy+    { _certPolicyInsecure ∷ !Bool+        -- ^ disable certificate validation+    , _certPolicyHostFingerprints ∷ !(HM.HashMap TLS.ServiceID TLS.Fingerprint)+        -- ^ a whitelist for services with trusted certificates+    }+    deriving (Show, Eq, Typeable)++certPolicyInsecure ∷ Lens' HttpsCertPolicy Bool+certPolicyInsecure = lens _certPolicyInsecure $ \s a → s { _certPolicyInsecure = a }++certPolicyHostFingerprints ∷ Lens' HttpsCertPolicy (HM.HashMap TLS.ServiceID TLS.Fingerprint)+certPolicyHostFingerprints = lens _certPolicyHostFingerprints $ \s a → s { _certPolicyHostFingerprints = a }++defaultHttpsCertPolicy ∷ HttpsCertPolicy+defaultHttpsCertPolicy = HttpsCertPolicy+    { _certPolicyInsecure = False+    , _certPolicyHostFingerprints = mempty+    }++pHttpsCertPolicy+    ∷ T.Text+        -- ^ prefix for the command line options+    → MParser HttpsCertPolicy+pHttpsCertPolicy prefix = id+    <$< certPolicyInsecure .:: boolOption_+        × O.long (T.unpack prefix ⊕ "https-insecure")+        ⊕ O.help "Bypass certificate validation for all HTTPS connections to all services. ONLY USE THIS WHEN YOU UNDERSTAND WHAT YOU DO."+    <*< certPolicyHostFingerprints %:: pLeftMonoidalUpdate × pRule+  where+    pRule = O.option (O.eitherReader readFingerprint)+        × O.long (T.unpack prefix ⊕ "https-allow-cert")+        ⊕ O.help "Unconditionally trust the certificate for connecting to the service. ONLY USE THIS WHEN YOU ARE SURE THAT THE CERTIFICATE CAN BE TRUSTED."+        ⊕ O.metavar "HOSTNAME:PORT:FINGERPRINT"+    readFingerprint = evalStateT $ do+        hostname ∷ String ← next+        x $ validateNonEmpty "hostname" hostname+        port ∷ Int ← lift ∘ readEither =<< next+        x $ validatePort "port" port+        fingerprint ← lift ∘ B64.decode ∘ B8.pack =<< next+        x $ validateNonEmpty "fingerprint" fingerprint -- FIXME we should evaluate the length+        return $ HM.singleton (hostname, sshow port) (TLS.Fingerprint fingerprint)++    next = state $ second (drop 1) ∘ break (≡ ':')++    x = lift ∘ fmapL T.unpack++-- -------------------------------------------------------------------------- --+-- HTTP Requests With Certificate Validation Policy+++-- | Make an HTTP request with a given certificate validation policy.+--+-- NOTE that the HTTP request is strictly loaded into memory.+--+-- NOTE that this implementation opens a new TCP connection for each single+-- request. HTTPS certificates validation results are not cached between different+-- requests.+--+httpWithValidationPolicy+    ∷ T.Text+        -- ^ HTTP or HTTPS URL+    → HttpsCertPolicy+    → IO (HTTP.Response LB.ByteString)+httpWithValidationPolicy url policy = do+    request ← HTTP.parseUrl $ T.unpack url+    certVar ← newIORef Nothing+    settings ← getSettings policy certVar+    HTTP.withManager settings (HTTP.httpLbs request) `catch` \httpEx → case httpEx of+        HTTP.TlsException tlsEx → case fromException tlsEx of+            Nothing → throwIO httpEx+            Just e → do+                cert ← readIORef certVar+                handleTlsException request cert e+        _ → throwIO httpEx++-- -------------------------------------------------------------------------- --+-- Verbose TLS exceptions++-- | The Haskell @tls@ library provides only limited means for providing+-- user friendly error messages. In particular we'd like to provide the+-- user with fingerprints of the reject certificate for self-signed+-- certificates. Also we want to provide the user with some guidance what+-- a particular failure may indicate with respect to security of the+-- connection.+--+-- Here we employ a /hack/ for better error handling: Based on the assumption+-- that we initialize a new connection 'Manager' and also a new certificate+-- cache for each request, we write the certificate that is received+-- from the server in the TLS handshake to an 'IORef'. If the handshakes+-- fails later on because the certificate is rejected we can recover the+-- rejected certificate from the 'IORef'.+--+-- What we really want are exceptions that can be consumed programatically.+-- In particular exceptions should include rejected certificates.+--+newtype VerboseTlsException = VerboseTlsException T.Text+    deriving (Eq, Ord, Typeable)++instance Show VerboseTlsException where+    show (VerboseTlsException msg) = "TLS exception: " ⊕ T.unpack msg++instance Exception VerboseTlsException++handleTlsException+    ∷ HTTP.Request+    → Maybe (TLS.SignedExact TLS.Certificate)+    → TLS.TLSException+    → IO a+handleTlsException request cert e@(TLS.HandshakeFailed (TLS.Error_Protocol (msg, _b, _alert)))+    | "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"+        ⊕ " may enable usage of this certificate with the following command line option:"+        ⊕ "\n\n"+        ⊕ "   " ⊕ allowCertOption+        ⊕ "\n"++    | "certificate rejected: [CacheSaysNo" `L.isPrefixOf` msg = throwIO ∘ VerboseTlsException+        $ "There is a mismatch between the expected certificate provided for"+        ⊕ " this service and the certificate provided by the service. You may try to remove"+        ⊕ " the expected certificate fingerprint and check if the certificate that is"+        ⊕ " offered by the service validates cleanly. If that is not the case this could"+        ⊕ " mean that someone is intercepting the connections. In this case YOU SHOULD ONLY"+        ⊕ " PROCEED WHEN YOU ARE SURE THAT IT IS SAFE. If you still want to proceed you may"+        ⊕ " accept the new certificate by using following command line option:"+        ⊕ "\n\n"+        ⊕ "   " ⊕ allowCertOption+        ⊕ "\n\n"+        ⊕ " The error message was: " ⊕ T.pack msg+        ⊕ "\n"++    | "certificate rejected: [NameMismatch" `L.isPrefixOf` msg = throwIO ∘ VerboseTlsException+        $ "There is a mismatch between the certificate name and the server name. This"+        ⊕ " could mean that someone is intercepting the connection or that you are not"+        ⊕ " connected to the correct service. YOU SHOULD ONLY PROCEED WHEN YOU ARE SURE"+        ⊕ " THAT IT IS SAFE TO DO SO. If you still want to proceed you may"+        ⊕ " accept the certificate by using following command line option:"+        ⊕ "\n\n"+        ⊕ "   " ⊕ allowCertOption+        ⊕ "\n\n"+        ⊕ " The error message was: " ⊕ T.pack msg+        ⊕ "\n"++    | "certificate rejected:" `L.isPrefixOf` msg = throwIO ∘ VerboseTlsException+        $ "The certificate that was offered by the service was rejected. This"+        ⊕ " could mean that someone is intercepting the connection or that you are not"+        ⊕ " connected to the correct service. YOU SHOULD ONLY PROCEED WHEN YOU ARE SURE"+        ⊕ " THAT IT IS SAFE TO DO SO. If you still want to proceed you may"+        ⊕ " accept the certificate by using following command line option:"+        ⊕ "\n\n"+        ⊕ "   " ⊕ allowCertOption+        ⊕ "\n\n"+        ⊕ " The error message was: " ⊕ T.pack msg+        ⊕ "\n"+    | otherwise = throwIO e+  where+    printFingerprint (TLS.Fingerprint f) = fromString ∘ B8.unpack ∘ B64.encode $ f+    printCertF c = printFingerprint (TLS.getFingerprint c fingerprintAlg)+    fingerprintAlg = TLS.HashSHA256+    hostText = T.decodeUtf8 $ HTTP.host request+    portText = sshow $ HTTP.port request++    allowCertOption = case cert of+        Nothing → "--insecure-remote-config-files"+        (Just c) →+            "--remote-config-fingerprint=" ⊕ hostText ⊕ ":" ⊕ portText ⊕ ":" ⊕ printCertF c++handleTlsException _ _  e = throwIO e++-- -------------------------------------------------------------------------- --+-- TLS Settings++-- | The usage of the 'certVar' parameter is not thread-safe!+--+-- FIXME We could make this thread-safe by using a cache for+-- "unvalidated" certificates.+--+getSettings+    ∷ HttpsCertPolicy+    → IORef (Maybe (TLS.SignedExact TLS.Certificate))+    → IO HTTP.ManagerSettings+getSettings policy certVar = do+    certstore ← TLS.getSystemCertificateStore+    return $ HTTP.mkManagerSettings+        (HTTP.TLSSettings (tlsSettings certstore))+        Nothing+  where+    -- It is safe to pass empty strings for host and port since 'TLS.connectFromHandle'+    -- and 'TLS.connectTo' are going to overwrite this anyways.+    --+    tlsSettings certstore = (TLS.defaultParamsClient "" "")+        { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_all }+        , TLS.clientShared = def+            { TLS.sharedCAStore = certstore+            , TLS.sharedValidationCache = validationCache+            }+        , TLS.clientHooks = def+            { TLS.onServerCertificate = \store cache serviceId certChain@(TLS.CertificateChain certs) → do+                modifyIORef' certVar (const $ listToMaybe certs)+                TLS.onServerCertificate def store cache serviceId certChain+            }+        }++    validationCache+        | _certPolicyInsecure policy = TLS.ValidationCache+            (\_ _ _ → return TLS.ValidationCachePass)+            (\_ _ _ → return ())+        | otherwise = certCache (_certPolicyHostFingerprints policy)++    -- 'TLS.exceptionValidationCache' would have worked to here, but it's hard to get+    -- the certificate fingerprint of the failing certificate from the exceptions it+    -- generates. Unfortunately, the TLS package allows us to pass only a string message,+    -- so that we have to encode and to decode the fingerprint.+    --+    certCache ∷ HM.HashMap TLS.ServiceID TLS.Fingerprint → TLS.ValidationCache+    certCache fingerprints = TLS.ValidationCache+        (queryCallback fingerprints)+        (\_ _ _ → return ())++    queryCallback ∷ HM.HashMap TLS.ServiceID TLS.Fingerprint → TLS.ValidationCacheQueryCallback+    queryCallback cache serviceID fingerprint _ = return $+        case HM.lookup serviceID cache of+            Nothing → TLS.ValidationCacheUnknown+            Just f+                | fingerprint ≡ f → TLS.ValidationCachePass+                | otherwise → TLS.ValidationCacheDenied+                    $ "for host: " ⊕ fst serviceID ⊕ ":" ⊕ B8.unpack (snd serviceID)+                    ⊕ " expected fingerprint: " ⊕ printFingerprint f+                    ⊕ " but got fingerprint: " ⊕ printFingerprint fingerprint+      where+        printFingerprint (TLS.Fingerprint f) = fromString ∘ B8.unpack ∘ B64.encode $ f+

@@ -1,29 +1,54 @@--- ------------------------------------------------------ ----- Copyright © 2014 AlephCloud Systems, Inc.--- ------------------------------------------------------ ---+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} +-- |+-- Module: Configuration.Utils.Interal+-- Description: Internal utilities of the configuration-tools package+-- Copyright: Copyright © 2014-2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+-- module Configuration.Utils.Internal-( lens+(+-- * Lenses+  lens , over , set , view , Lens' , Lens , Iso'+, Iso , iso++-- * Misc Utils+, (&)+, sshow+, exceptT+, errorT+, fmapL ) where  import Control.Applicative (Const(..))+import Control.Monad import Control.Monad.Reader.Class+import Control.Monad.Except  import Data.Functor.Identity+import Data.Monoid.Unicode import Data.Profunctor import Data.Profunctor.Unsafe+import Data.String+import qualified Data.Text as T +import Prelude.Unicode++infixl 1 &+ -- -------------------------------------------------------------------------- -- -- Lenses @@ -49,25 +74,61 @@ lens getter setter lGetter s = setter s `fmap` lGetter (getter s) {-# INLINE lens #-} -over ∷ ((α → Identity α) → β → Identity β) → (α → α) → β → β+over ∷ ((α → Identity β) → σ → Identity τ) → (α → β) → σ → τ over s f = runIdentity . s (Identity . f) {-# INLINE over #-} -set ∷ ((α → Identity α) → β → Identity β) → α → β → β+set ∷ ((α → Identity β) → σ → Identity τ) → β → σ → τ set s a = runIdentity . s (const $ Identity a) {-# INLINE set #-}  view ∷ MonadReader σ μ ⇒ ((α → Const α α) → σ → Const α σ) → μ α view l = asks (getConst #. l Const)+{-# INLINE view #-}  -- | This is 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 Iso' β α = (Profunctor π, Functor φ) ⇒ π α (φ α) → π β (φ β)+type Iso σ τ α β = (Profunctor π, Functor φ) ⇒ π α (φ β) → π σ (φ τ)+type Iso' σ α = Iso σ σ α α -iso ∷ (β → α) → (α → β) → Iso' β α+iso ∷ (σ → α) → (β → τ) → Iso σ τ α β iso f g = dimap f (fmap g) {-# INLINE iso #-}++-- -------------------------------------------------------------------------- --+-- Misc Utils++(&) ∷ α → (α → β) → β+(&) = flip ($)+{-# INLINE (&) #-}++sshow+    ∷ (Show α, IsString τ)+    ⇒ α+    → τ+sshow = fromString ∘ show+{-# INLINE sshow #-}++exceptT+    ∷ Monad μ+    ⇒ (ε → μ β)+    → (α → μ β)+    → ExceptT ε μ α+    → μ β+exceptT a b = runExceptT >=> either a b+{-# INLINE exceptT #-}++errorT+    ∷ Monad μ+    ⇒ ExceptT T.Text μ α+    → μ α+errorT = exceptT (\e → error ∘ T.unpack $ "Error: " ⊕ e) return+{-# INLINE errorT #-}++fmapL ∷ (α → β) → Either α γ → Either β γ+fmapL f = either (Left ∘ f) Right+{-# INLINE fmapL #-} 

@@ -0,0 +1,240 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: Configuration.Utils.Maybe+-- Description: Configuration of Optional Values+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- This module provides tools for defining Maybe configuration types.+--+module Configuration.Utils.Maybe+(+-- * Simple Maybe Values+-- $simplemaybe++-- * Record Maybe Values+-- $recordmaybe+  maybeOption++) where++import Control.Applicative+import Data.Aeson++-- -------------------------------------------------------------------------- --+-- Simple Maybe Value++-- $simplemaybe+-- Optional configuration values are supposed to be encoded by wrapping+-- the respective type with 'Maybe'.+--+-- For simple values the standard 'FromJSON' instance from the aeson+-- package can be used along with the '..:' operator.+--+-- > data LogConfig = LogConfig+-- >    { _logLevel ∷ !Int+-- >    , _logFile ∷ !(Maybe String)+-- >    }+-- >+-- > $(makeLenses ''LogConfig)+-- >+-- > defaultLogConfig ∷ LogConfig+-- > defaultLogConfig = LogConfig+-- >     { _logLevel = 1+-- >     , _logFile = Nothing+-- >     }+-- >+-- > instance FromJSON (LogConfig → LogConfig) where+-- >     parseJSON = withObject "LogConfig" $ \o → id+-- >         <$< logLevel ..: "LogLevel" % o+-- >         <*< logFile ..: "LogConfig" % o+-- >+-- > instance ToJSON LogConfig where+-- >     toJSON config = object+-- >         [ "LogLevel" .= _logLevel config+-- >         , "LogConfig" .= _logFile config+-- >         ]+-- >+--+-- When defining command line option parsers with '.::' and '%::' all+-- options are optional. When an option is not present on the command+-- line the default value is used. For 'Maybe' values it is therefore+-- enough to wrap the parsed value into 'Just'.+--+-- > pLogConfig ∷ MParser LogConfig+-- > pLogConfig = id+-- > #if MIN_VERSION_optparse-applicative(0,10,0)+-- >     <$< logLevel .:: option auto+-- > #else+-- >     <$< logLevel .:: option+-- > #endif+-- >         % long "log-level"+-- >         % metavar "INTEGER"+-- >         % help "log level"+-- >     <*< logFile .:: fmap Just % strOption+-- >         % long "log-file"+-- >         % metavar "FILENAME"+-- >         % help "log file name"+--++-- $recordmaybe+--+-- For 'Maybe' types that wrap product (record) types the following orphan 'FromJSON'+-- instance is provided:+--+-- > instance (FromJSON (a → a), FromJSON a) ⇒ FromJSON (Maybe a → Maybe a)+-- >     parseJSON Null = pure (const Nothing)+-- >     parseJSON v = f <$> parseJSON v <*> parseJSON v+-- >       where+-- >         f g _ Nothing = Just g+-- >         f _ g (Just x) = Just (g x)+--+-- (Using an orphan instance is generally problematic but convenient in+-- this case. It's unlikely that an instance for this type is needed elsewhere.+-- If this is an issue for you, please let me know. In that case we can define a+-- new type for optional configuration values.)+--+-- The semantics are as follows:+--+-- * If the parsed configuration value is 'Null' the result is 'Nothing'.+-- * If the parsed configuration value is not 'Null' then the result is+--   an update function that+--+--     * updates the given default value if this value is @Just x@+--       or+--     * is a constant function that returns the value that is parsed+--       from the configuration using the 'FromJSON' instance for the+--       configuration type.+--+-- Note, that this instance requires an 'FromJSON' instance for the+-- configuration type itself as well as a 'FromJSON' instance for the update+-- function of the configuration type. The former can be defined by means of the+-- latter as follows:+--+-- > instance FromJSON MyType where+-- >     parseJSON v = parseJSON v <*> pure defaultMyType+--+-- This instance will cause the usage of 'defaultMyType' as default value if the+-- default value that is given to the configuration parser is 'Nothing' and the+-- parsed configuration is not 'Null'.+--+instance (FromJSON (a → a), FromJSON a) ⇒ FromJSON (Maybe a → Maybe a) where++    -- | If the configuration explicitly requires 'Null' the result+    -- is 'Nothing'.+    --+    parseJSON Null = pure (const Nothing)++    -- | If the default value is @(Just x)@ and the configuration+    -- provides and update function @f@ then result is @Just f@.+    --+    -- If the default value is 'Nothing' and the configuration+    -- is parsed using a parser for a constant value (and not+    -- an update function).+    --+    parseJSON v = f <$> parseJSON v <*> parseJSON v+      where+        f g _ Nothing = Just g+        f _ g (Just x) = Just (g x)++-- | Command line parser for record 'Maybe' values+--+-- == Example:+--+-- > data Setting = Setting+-- >     { _setA ∷ !Int+-- >     , _setB ∷ !String+-- >     }+-- >     deriving (Show, Read, Eq, Ord, Typeable)+-- >+-- > $(makeLenses ''Setting)+-- >+-- > defaultSetting ∷ Setting+-- > defaultSetting = Setting+-- >     { _setA = 0+-- >     , _setB = 1+-- >     }+-- >+-- > instance ToJSON Setting where+-- >     toJSON setting = object+-- >        [ "a" .= _setA setting+-- >        , "b" .= _setB setting+-- >        ]+-- >+-- > instance FromJSON (Setting → Setting) where+-- >     parseJSON = withObject "Setting" $ \o → id+-- >         <$< setA ..: "a" % o+-- >         <*< setB ..: "b" % o+-- >+-- > instance FromJSON Setting where+-- >    parseJSON v = parseJSON v <*> pure defaultSetting+-- >+-- > pSetting ∷ MParser Setting+-- > pSetting = id+-- >     <$< setA .:: option auto+-- >         % short 'a'+-- >         <> metavar "INT"+-- >         <> help "set a"+-- >     <*< setB .:: option auto+-- >         % short 'b'+-- >         <> metavar "INT"+-- >         <> help "set b"+-- >+-- > -- | Use 'Setting' as 'Maybe' in a configuration:+-- > --+-- > data Config = Config+-- >     { _maybeSetting ∷ !(Maybe Setting)+-- >     }+-- >     deriving (Show, Read, Eq, Ord, Typeable)+-- >+-- > $(makeLenses ''Config)+-- >+-- > defaultConfig ∷ Config+-- > defaultConfig = Config+-- >     { _maybeSetting = defaultSetting+-- >     }+-- >+-- > instance ToJSON Config where+-- >     toJSON config = object+-- >         [ "setting" .= maybeSetting+-- >         ]+-- >+-- > instance FromJSON (Config → Config) where+-- >     parseJSON = withObject "Config" $ \o → id+-- >         <$< maybeSetting %.: "setting" % o+-- >+-- > pConfig ∷ MParser Config+-- > pConfig = id+-- >     <$< maybeSetting %:: (maybeOption defaultSetting+-- >         <$> pEnableSetting+-- >         <*> pSetting)+-- >   where+-- >     pEnableSetting = boolOption+-- >         % long "setting-enable"+-- >         <> value False+-- >         <> help "Enable configuration flags for setting"+--+maybeOption+    ∷ a+        -- ^ default value that is used if base configuration is 'Nothing'+    → Bool+        -- ^ whether to enable this parser or not (usually is a boolean option parser)+    → (a → a)+        -- ^ update function (usually given as applicative 'MParser a')+    → Maybe a+        -- ^ the base value that is updated (usually the result of parsing the configuration file)+    → Maybe a+maybeOption _ False _ Nothing = Nothing -- not enabled+maybeOption defA True update Nothing = Just $ update defA -- disabled in config file but enabled by command line+maybeOption _ _ update (Just val) = Just $ update val -- enabled by config file and possibly by command line+

@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Configuration.Utils.Monoid+-- Description: Configuration of Monoids+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- The distinction between appending on the left and appending on+-- the right is important for monoids that are sensitive to ordering+-- such as 'List'. It is also of relevance for monoids with set semantics+-- with non-extensional equality such as `HashMap`.+--+module Configuration.Utils.Monoid+( LeftMonoidalUpdate+, leftMonoidalUpdate+, fromLeftMonoidalUpdate+, pLeftMonoidalUpdate+, RightMonoidalUpdate+, rightMonoidalUpdate+, fromRightMonoidalUpdate+, pRightMonoidalUpdate+) where++import Configuration.Utils.CommandLine+import Configuration.Utils.Internal++import Control.Monad.Except hiding (mapM_)+import Control.Monad.Writer hiding (mapM_)++import Data.Aeson++import qualified Options.Applicative.Types as O++import Prelude hiding (concatMap, mapM_, any)+import Prelude.Unicode++-- | Update a value by appending on the left. Under normal+-- circumstances you'll never use this type directly but only+-- its 'FromJSON' instance. See the 'leftMonoidalUpdate' for an example.+--+newtype LeftMonoidalUpdate α = LeftMonoidalUpdate+    { _getLeftMonoidalUpdate ∷ α+    }+    deriving (Monoid)++-- | Update a value by appending on the left.+--+-- > newtype RoutingTable = RoutingTable { _routingTableMap ∷ HashMap T.Text T.Text }+-- >+-- > $(makeLenses ''RoutingTable)+-- >+-- > instance FromJSON (RoutingTable → RoutingTable) where+-- >     parseJSON = withObject "RoutingTable" $ \o → id+-- >         <$< routingTableMap . from leftMonoidalUpdate %.: "route_map" % o+--+leftMonoidalUpdate ∷ Iso (LeftMonoidalUpdate α) (LeftMonoidalUpdate β) α β+leftMonoidalUpdate = iso _getLeftMonoidalUpdate LeftMonoidalUpdate++-- | This is the same as @from leftMonoidalUpdate@ but doesn't depend on+-- the lens Library.+--+fromLeftMonoidalUpdate ∷ Iso α β (LeftMonoidalUpdate α) (LeftMonoidalUpdate β)+fromLeftMonoidalUpdate = iso LeftMonoidalUpdate _getLeftMonoidalUpdate++instance (FromJSON α, Monoid α) ⇒ FromJSON (LeftMonoidalUpdate α → LeftMonoidalUpdate α) where+    parseJSON = fmap (mappend ∘ LeftMonoidalUpdate) ∘ parseJSON++-- | Update a value by appending on the left.+--+-- > newtype RoutingTable = RoutingTable { _routingTableMap ∷ HashMap T.Text T.Text }+-- >+-- > $(makeLenses ''RoutingTable)+-- >+-- > pRoutingTable ∷ MParser RoutingTable+-- > pRoutingTable = routingTableMap %:: pLeftMonoidalUpdate pRoute+-- >   where+-- >     pRoute = option (eitherReader readRoute)+-- >         % long "route"+-- >         <> help "add a route to the routing table; the APIROUTE part must not contain a colon character"+-- >         <> metavar "APIROUTE:APIURL"+-- >+-- >     readRoute s = case break (== ':') s of+-- >         (a,':':b) → fmapL T.unpack $ do+-- >             validateNonEmpty "APIROUTE" a+-- >             validateHttpOrHttpsUrl "APIURL" b+-- >             return $ HM.singleton (T.pack a) (T.pack b)+-- >         _ → Left "missing colon between APIROUTE and APIURL"+-- >+-- >     fmapL f = either (Left . f) Right+--+pLeftMonoidalUpdate ∷ Monoid α ⇒ O.Parser α → MParser α+pLeftMonoidalUpdate pElement = mappend ∘ mconcat ∘ reverse <$> many pElement++-- | Update a value by appending on the right. Under normal+-- circumstances you'll never use this type directly but only+-- its 'FromJSON' instance. See the 'leftMonoidalUpdate' for an example.+--+newtype RightMonoidalUpdate α = RightMonoidalUpdate+    { _getRightMonoidalUpdate ∷ α+    }+    deriving (Monoid)++-- | Update a value by appending on the right. See 'leftMonoidalUpdate' for+-- an usage example.+--+rightMonoidalUpdate ∷ Iso (RightMonoidalUpdate α) (RightMonoidalUpdate β) α β+rightMonoidalUpdate = iso _getRightMonoidalUpdate RightMonoidalUpdate++-- | This is the same as @from rightMonoidalUpdate@ but doesn't depend on+-- the lens Library.+--+fromRightMonoidalUpdate ∷ Iso α β (RightMonoidalUpdate α) (RightMonoidalUpdate β)+fromRightMonoidalUpdate = iso RightMonoidalUpdate _getRightMonoidalUpdate++instance (FromJSON α, Monoid α) ⇒ FromJSON (RightMonoidalUpdate α → RightMonoidalUpdate α) where+    parseJSON = fmap (flip mappend ∘ RightMonoidalUpdate) ∘ parseJSON++-- | Update a value by appending on the right. See 'pLeftMonoidalUpdate'+-- for an usage example.+--+pRightMonoidalUpdate ∷ Monoid α ⇒ O.Parser α → MParser α+pRightMonoidalUpdate pElement = flip mappend ∘ mconcat <$> many pElement+

@@ -0,0 +1,115 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Configuration.Utils.Operators+-- Description: Useful operators for defining functions in an applicative context+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- Useful operators for defining functions in an applicative context+--+module Configuration.Utils.Operators+( (%)+, (×)+, (<*<)+, (>*>)+, (<$<)+, (>$>)+, (<.>)+, (⊙)+) where++import Control.Applicative++-- -------------------------------------------------------------------------- --+-- Useful Operators++-- | 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.+--+(%) ∷ (α → β) → α → β+(%) = ($)+infixr 5 %+{-# INLINE (%) #-}++-- | This operator is a UTF-8 version of '%' which is an alternative for '$'+-- 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.+--+-- In VIM type: @Ctrl-V u 00d7@+--+-- You may also define a key binding by adding something like the following line+-- to your vim configuration file:+--+-- > iabbrev <buffer> >< ×+--+(×) ∷ (α → β) → α → β+(×) = ($)+infixr 5 ×+{-# INLINE (×) #-}++-- | Functional composition for applicative functors.+--+(<*<) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)+(<*<) a b = pure (.) <*> a <*> b+infixr 4 <*<+{-# INLINE (<*<) #-}++-- | Functional composition for applicative functors with its arguments+-- flipped.+--+(>*>) ∷ Applicative φ ⇒ φ (α → β) → φ (β → γ) → φ (α → γ)+(>*>) = flip (<*<)+infixr 4 >*>+{-# INLINE (>*>) #-}++-- | Applicative functional composition between a pure function+-- and an applicative function.+--+(<$<) ∷ Functor φ ⇒ (β → γ) → φ (α → β) → φ (α → γ)+(<$<) a b = (a .) <$> b+infixr 4 <$<+{-# INLINE (<$<) #-}++-- | Applicative functional composition between a pure function+-- and an applicative function with its arguments flipped.+--+(>$>) ∷ Functor φ ⇒ φ (α → β) → (β → γ) → φ (α → γ)+(>$>) = flip (<$<)+infixr 4 >$>+{-# INLINE (>$>) #-}++-- | Functional composition for applicative functors.+--+-- This is a rather popular operator. Due to conflicts (for instance with the+-- lens package) it may have to be imported qualified.+--+(<.>) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)+(<.>) = (<*<)+infixr 4 <.>+{-# INLINE (<.>) #-}+{-# DEPRECATED (<.>) "use '<*<' instead" #-}++-- | For people who like nicely aligned code and do not mind messing with+-- editor key-maps: here a version of '<.>' that uses a unicode symbol+--+-- The hex value of the UTF-8 character ⊙ is 0x2299.+--+-- A convenient VIM key-map is:+--+-- > iabbrev <buffer> ../ ⊙+--+(⊙) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)+(⊙) = (<.>)+infixr 4 ⊙+{-# INLINE (⊙) #-}+{-# DEPRECATED (⊙) "use '<*<' instead" #-}+

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -15,9 +16,10 @@ -- Utilities for validating configuration values -- module Configuration.Utils.Validation-(+( ConfigValidation+ -- * Networking-  validateHttpOrHttpsUrl+, validateHttpOrHttpsUrl , validateHttpUrl , validateHttpsUrl , validateUri@@ -41,6 +43,7 @@ , validateFileWritable , validateExecutable , validateDirectory+, validateConfigFile  -- * Boolean Values , validateFalse@@ -62,16 +65,17 @@ , validateRange ) where -import Configuration.Utils+import Configuration.Utils.Internal +import Control.Applicative import Control.Monad.Error.Class import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Writer.Class  import qualified Data.Foldable as F import Data.Monoid import Data.Monoid.Unicode-import Data.String import qualified Data.Text as T  import Network.URI@@ -80,14 +84,10 @@  import System.Directory --- -------------------------------------------------------------------------- ----- Utils--sshow-    ∷ (Show α, IsString τ)-    ⇒ α-    → τ-sshow = fromString ∘ show+-- | A validation function. The type in the 'MonadWriter' is excpected to+-- be a 'Foldable' structure for collecting warnings.+--+type ConfigValidation α λ = (MonadIO μ, Functor μ, Applicative μ, MonadError T.Text μ, MonadWriter (λ T.Text) μ) ⇒ α → μ ()  -- -------------------------------------------------------------------------- -- -- Networking@@ -95,9 +95,11 @@ -- | Validates that a value is an HTTP or HTTPS URL -- validateHttpOrHttpsUrl-    ∷ T.Text+    ∷ MonadError T.Text m+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation String λ+    → String+    → m () validateHttpOrHttpsUrl configName uri =     case parseURI uri of         Nothing → throwError $@@ -108,9 +110,11 @@ -- | Validates that a value is an HTTP URL -- validateHttpUrl-    ∷ T.Text+    ∷ MonadError T.Text m+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation String λ+    → String+    → m () validateHttpUrl configName uri =     case parseURI uri of         Nothing → throwError $@@ -121,9 +125,11 @@ -- | Validates that a value is an HTTPS URL -- validateHttpsUrl-    ∷ T.Text+    ∷ MonadError T.Text m+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation String λ+    → String+    → m () validateHttpsUrl configName uri =     case parseURI uri of         Nothing → throwError $@@ -134,9 +140,11 @@ -- | Validates that a value is an URI without a fragment identifier -- validateUri-    ∷ T.Text+    ∷ MonadError T.Text m+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation String λ+    → String+    → m () validateUri configName uri =     unless (isURIReference uri) ∘ throwError $         "The value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI"@@ -144,9 +152,11 @@ -- | Validates that a value is an absolute URI without a fragment identifier -- validateAbsoluteUri-    ∷ T.Text+    ∷ MonadError T.Text m+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation String λ+    → String+    → m () validateAbsoluteUri configName uri =     unless (isAbsoluteURI uri) ∘ throwError $         "The value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI"@@ -155,33 +165,41 @@ -- identifier -- validateAbsoluteUriFragment-    ∷ T.Text+    ∷ MonadError T.Text m+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation String λ+    → String+    → m () validateAbsoluteUriFragment configName uri =     unless (isURI uri) ∘ throwError $         "The value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI"  validateIPv4-    ∷ T.Text+    ∷ MonadError T.Text m+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation String λ+    → String+    → m () validateIPv4 configName ipv4 =     unless (isIPv4address ipv4) ∘ throwError $         "The value " ⊕ T.pack ipv4 ⊕ " for " ⊕ configName ⊕ " is not a valid IPv4 address"  validateIPv6-    ∷ T.Text+    ∷ MonadError T.Text m+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation String λ+    → String+    → m () validateIPv6 configName ipv6 =     unless (isIPv6address ipv6) ∘ throwError $         "The value " ⊕ T.pack ipv6 ⊕ " for " ⊕ configName ⊕ " is not a valid IPv6 address"  validatePort-    ∷ T.Text+    ∷ (MonadError T.Text m, Integral n, Show n)+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation Int λ+    → n+    → m () validatePort configName p =     unless (p > 1 && p < 65535) ∘ throwError $         "port value " ⊕ T.pack (show p) ⊕ " for " ⊕ configName ⊕ " is not valid port number"@@ -190,56 +208,61 @@ -- Monoids, Foldables, and Co  validateNonEmpty-    ∷ (Eq α, Monoid α)+    ∷ (MonadError T.Text m, Eq α, Monoid α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation α λ+    → α+    → m () validateNonEmpty configName x =     when (x ≡ mempty) ∘ throwError $         "value for " ⊕ configName ⊕ " must not be empty"  validateLength-    ∷ (F.Foldable φ)+    ∷ (MonadError T.Text m, F.Foldable φ)     ⇒ T.Text         -- ^ configuration property name that is used in the error message     → Int         -- ^ exact length of the validated value-    → ConfigValidation (φ α) λ+    → φ α+    → m () validateLength configName len x =     unless (length (F.toList x) ≡ len) ∘ throwError $         "value for " ⊕ configName ⊕ " must be of length exactly " ⊕ sshow len  validateMaxLength-    ∷ (F.Foldable φ)+    ∷ (MonadError T.Text m, F.Foldable φ)     ⇒ T.Text         -- ^ configuration property name that is used in the error message     → Int         -- ^ maximum length of the validated value-    → ConfigValidation (φ α) λ+    → φ α+    → m () validateMaxLength configName u x =     unless (length (F.toList x) ≤ u) ∘ throwError $         "value for " ⊕ configName ⊕ " must be of length at most " ⊕ sshow u  validateMinLength-    ∷ (F.Foldable φ)+    ∷ (MonadError T.Text m, F.Foldable φ)     ⇒ T.Text         -- ^ configuration property name that is used in the error message     → Int         -- ^ minimum length of the validated value-    → ConfigValidation (φ α) λ+    → φ α+    → m () validateMinLength configName l x =     unless (length (F.toList x) ≥ l) ∘ throwError $         "value for " ⊕ configName ⊕ " must be of length at least " ⊕ sshow l  validateMinMaxLength-    ∷ (F.Foldable φ)+    ∷ (MonadError T.Text m, F.Foldable φ)     ⇒ T.Text         -- ^ configuration property name that is used in the error message     → Int         -- ^ minimum length of the validated value     → Int         -- ^ maximum length of the validated value-    → ConfigValidation (φ α) λ+    → φ α+    → m () validateMinMaxLength configName l u x =     unless (len ≥ l && len ≤ u) ∘ throwError $         "the length of the value for " ⊕ configName ⊕@@ -251,53 +274,65 @@ -- Files  validateFilePath-    ∷ T.Text+    ∷ MonadError T.Text m+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation FilePath λ+    → FilePath+    → m () validateFilePath configName file =     when (null file) ∘ throwError $         "file path for " ⊕ configName ⊕ " must not be empty"  validateFile-    ∷ T.Text+    ∷ (MonadError T.Text m, MonadIO m)+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation FilePath λ+    → FilePath+    → m () validateFile configName file = do     exists ← liftIO $ doesFileExist file     unless exists ∘ throwError $         "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " does not exist"  validateFileReadable-    ∷ T.Text+    ∷ (MonadError T.Text m, MonadIO m)+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation FilePath λ+    → FilePath+    → m () validateFileReadable configName file = do     validateFile configName file     liftIO (getPermissions file) >>= \x → unless (readable x) ∘ throwError $         "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " is not readable"  validateFileWritable-    ∷ T.Text+    ∷ (MonadError T.Text m, MonadIO m)+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation FilePath λ+    → FilePath+    → m () validateFileWritable configName file = do     validateFile configName file     liftIO (getPermissions file) >>= \x → unless (writable x) ∘ throwError $         "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " is not writable"  validateFileExecutable-    ∷ T.Text+    ∷ (MonadError T.Text m, MonadIO m)+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation FilePath λ+    → FilePath+    → m () validateFileExecutable configName file = do     validateFile configName file     liftIO (getPermissions file) >>= \x → unless (executable x) ∘ throwError $         "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " is not excutable"  validateDirectory-    ∷ T.Text+    ∷ (MonadError T.Text m, MonadIO m)+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation FilePath λ+    → FilePath+    → m () validateDirectory configName dir = do     exists ← liftIO $ doesDirectoryExist dir     unless exists ∘ throwError $@@ -307,9 +342,11 @@ -- and can be executed. -- validateExecutable-    ∷ T.Text+    ∷ (Functor m, MonadError T.Text m, MonadIO m)+    ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation FilePath λ+    → FilePath+    → m () validateExecutable configName file = do     execFile ← (file <$ validateFile configName file) `catchError` \_ ->         liftIO (findExecutable file) >>= \case@@ -319,6 +356,19 @@             Just f → return f     validateFileExecutable configName execFile +-- | Validate that the input is a config file+--+validateConfigFile+    ∷ (MonadIO m, MonadError T.Text m)+    ⇒ String+    → m ()+validateConfigFile filepath =+    validateFileReadable "config-file" filepath+#ifdef REMOTE_CONFIGS+    `catchError` \_ ->+    validateHttpOrHttpsUrl "config-file" filepath+#endif+ -- -------------------------------------------------------------------------- -- -- Boolean Values @@ -353,46 +403,51 @@ -- Numeric Values  validateNonNegative-    ∷ (Ord α, Num α)+    ∷ (MonadError T.Text m, Ord α, Num α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation α λ+    → α+    → m () validateNonNegative configName x =     when (x < 0) ∘ throwError $         "value for " ⊕ configName ⊕ " must not be negative"  validatePositive-    ∷ (Ord α, Num α)+    ∷ (MonadError T.Text m, Ord α, Num α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation α λ+    → α+    → m () validatePositive configName x =     when (x ≤ 0) ∘ throwError $         "value for " ⊕ configName ⊕ " must be positive"  validateNonPositive-    ∷ (Ord α, Num α)+    ∷ (MonadError T.Text m, Ord α, Num α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation α λ+    → α+    → m () validateNonPositive configName x =     when (x > 0) ∘ throwError $         "value for " ⊕ configName ⊕ " must not be positive"  validateNegative-    ∷ (Ord α, Num α)+    ∷ (MonadError T.Text m, Ord α, Num α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation α λ+    → α+    → m () validateNegative configName x =     when (x ≥ 0) ∘ throwError $         "value for " ⊕ configName ⊕ " must be negative"  validateNonNull-    ∷ (Eq α, Num α)+    ∷ (MonadError T.Text m, Eq α, Num α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message-    → ConfigValidation α λ+    → α+    → m () validateNonNull configName x = when (x ≡ 0) ∘ throwError $     "value for " ⊕ configName ⊕ " must not be zero" @@ -400,52 +455,57 @@ -- Orders  validateLess-    ∷ (Ord α, Show α)+    ∷ (MonadError T.Text m, Ord α, Show α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message     → α         -- ^ a strict upper bound for the configuration value-    → ConfigValidation α λ+    → α+    → m () 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 α)+    ∷ (MonadError T.Text m, Ord α, Show α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message     → α         -- ^ a upper bound for the configuration value-    → ConfigValidation α λ+    → α+    → m () 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 α)+    ∷ (MonadError T.Text m, Ord α, Show α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message     → α         -- ^ a strict lower bound for the configuration value-    → ConfigValidation α λ+    → α+    → m () 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 α)+    ∷ (MonadError T.Text m, Ord α, Show α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message     → α         -- ^ a lower bound for the configuration value-    → ConfigValidation α λ+    → α+    → m () 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 α)+    ∷ (MonadError T.Text m, Ord α, Show α)     ⇒ T.Text         -- ^ configuration property name that is used in the error message     → (α, α)         -- ^ the valid range for the configuration value-    → ConfigValidation α λ+    → α+    → 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 

@@ -1,33 +1,347 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-}  -- | -- Module: Main--- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- Copyright: Copyright © 2014-2015 AlephCloud Systems, Inc. -- License: MIT -- Maintainer: Lars Kuhtz <lars@alephcloud.com> -- Stability: experimental ----- Tests for Example--- module Main ( main ) where -import Control.Exception+import TestTools+import Tests.BoolOption+import Tests.MonoidConfig -import qualified Example+import Configuration.Utils+import Configuration.Utils.Internal -import System.Environment+import Control.Monad +import qualified Data.List as L+import Data.Monoid.Unicode+import qualified Data.Text as T+import qualified Data.Text.IO as T++import Example hiding (main)++import Prelude.Unicode++import PkgInfo_url_example_test++-- -------------------------------------------------------------------------- --+-- main+ main ∷ IO ()-main = do-    withArgs ["--domain=localhost"] Example.main-    withArgs ["--path=abc"] Example.main-    withArgs ["--path=abc", "--user=u"] Example.main-    handle (\(_ ∷ SomeException) → return ()) $ do-        withArgs [] Example.main-        error "expected failure but got success"-    return ()+main =+    withConfigFile config0 $ \tmpPath0 →+    withConfigFileText config1Part$ \tmpPath1 → do++#ifdef REMOTE_CONFIGS+    withConfigFileServer [("config0", ConfigType config0)] [("config1", config1Part), ("invalid", "invalid: invalid")] $ do+#endif+        (successes, failures) ← L.partition id <$> sequence+            × tests0+            ⊕ testsConfigFile [tmpPath0, tmpPath1]+            ⊕ tests2Files1 [tmpPath0, tmpPath1]+            ⊕ tests2Files2 "local-" (tmpPath0) (tmpPath1)+            ⊕ tests2Files3 "local-" (tmpPath0) (tmpPath1)+#ifdef REMOTE_CONFIGS+            ⊕ tests2Files2 "remote-" (serverUrl ⊕ "/config0") (serverUrl ⊕ "/config1")+            ⊕ tests2Files3 "remote-" (serverUrl ⊕ "/config0") (serverUrl ⊕ "/config1")+            ⊕ testsInvalidUrl+            ⊕ testsTlsUrl+#endif+            ⊕ monoidUpdateTests pkgInfo+            ⊕ boolOptionTests pkgInfo+            ⊕ testPrintHelp [tmpPath0, tmpPath1]++        T.putStrLn $ "success: " ⊕ sshow (length successes)+        T.putStrLn $ "failures: " ⊕ sshow (length failures)+        unless (length failures ≡ 0) $ do+            debug $ do+                T.readFile (T.unpack tmpPath0) >>= T.putStrLn+                T.readFile (T.unpack tmpPath1) >>= T.putStrLn+            error "test suite failed"++-- -------------------------------------------------------------------------- --+-- Test Cases++-- | This always succeeds. It prints the help message for manual+-- inspection.+--+testPrintHelp ∷ [T.Text] → [IO Bool]+testPrintHelp files =+    [ runTest pkgInfo (mainInfoConfigFile configFiles) "print-help" False [trueAssertion ["-?"]]+    ]+  where+    configFiles = zipWith ($) (ConfigFileRequired : repeat ConfigFileOptional) files++testsConfigFile ∷ [T.Text] → [IO Bool]+testsConfigFile files =+    [ runTest pkgInfo (mainInfoConfigFile configFiles0) "config-file-1" True [trueAssertion []]+    , runTest pkgInfo (mainInfoConfigFile configFiles1) "config-file-2" False [trueAssertion []]+    ]+  where+    configFiles0 = zipWith ($) (ConfigFileRequired : repeat ConfigFileOptional) (files ⊕ ["./invalid"])+    configFiles1 = zipWith ($) (ConfigFileRequired : repeat ConfigFileOptional) ("./invalid":files)++#ifdef REMOTE_CONFIGS+-- | Test with invalid remote URLs+--+testsInvalidUrl ∷ [IO Bool]+testsInvalidUrl =+    [ runTest pkgInfo mainInfo "invalidUrl-0" False [x0, d1]+    , runTest pkgInfo mainInfo "invalidUrl-1" False [x1, d1]+    ]+  where+    x0 = trueAssertion ["--config-file=http://invalid"]+    x1 = trueAssertion ["--config-file=" ⊕ T.unpack serverUrl ⊕ "/invalid"]++testsTlsUrl ∷ [IO Bool]+testsTlsUrl =+    [ runTest pkgInfo mainInfo "tlsUrl-0" True [cf0, f1 c0]+    , runTest pkgInfo mainInfo "tlsUrl-1" False [cf0t, f1 c0]+    , runTest pkgInfo mainInfo "tlsUrl-2" False [cf0tl, f1 c0]+    , runTest pkgInfo mainInfo "tlsUrl-3" False [cf0t, f1 c0, fingerF]+    , runTest pkgInfo mainInfo "tlsUrl-4" True [cf0t, f1 c0, fingerT]+    , runTest pkgInfo mainInfo "tlsUrl-5" True [insec, cf0, f1 c0]+    , runTest pkgInfo mainInfo "tlsUrl-6" True [insec, cf0t, f1 c0]+    ]+  where+    cf0 = trueAssertion ["--config-file=" ⊕ T.unpack serverUrl ⊕ "/config0"]+    cf0t = trueAssertion ["--config-file=" ⊕ T.unpack serverTlsUrl ⊕ "/config0"]+    cf0tl = trueAssertion ["--config-file=" ⊕ "https://localhost:8284" ⊕ "/config0"] -- FIXME don't hardcode this+    insec = trueAssertion ["--config-https-insecure"]+    fingerF = trueAssertion ["--config-https-allow-cert=" ⊕ drop 8 (T.unpack serverTlsUrl) ⊕ ":0x+SV6/D6JSIKK8pPCpaMZvMXelXb2CnJ8xWo8qi4Fo="]+    fingerT = trueAssertion ["--config-https-allow-cert=" ⊕ drop 8 (T.unpack serverTlsUrl) ⊕ ":HK4/ZeG/3c+H5R/3eTlysmJxmrBil6w8oLdvOdHFlsg="]+    c0 = config0+#endif++-- -------------------------------------------------------------------------- --+-- Tests with two configuration files++-- | Tests with two configuration files+--+tests2Files1 ∷ [T.Text] → [IO Bool]+tests2Files1 files =+    twoFileCasesC0C1 "2files-1-" files (trueAssertion [])+    ⊕ twoFileCasesC1C0 "2files-1-" selif (trueAssertion [])+  where+    selif = reverse files++-- | Tests with two configuration files+--+tests2Files2+    ∷ T.Text+        -- ^ test label prefix+    → T.Text+        -- ^ file for config0+    → T.Text+        -- ^ file for config1+    → [IO Bool]+tests2Files2 suffix file0 file1 =+    twoFileCasesC0C1 ("2files-2-" ⊕ suffix) [file0] x1+    ⊕ twoFileCasesC1C0 ("2files-2-" ⊕ suffix) [file1] x0+  where+    x0 = trueAssertion ["--config-file=" ⊕ T.unpack file0]+    x1 = trueAssertion ["--config-file=" ⊕ T.unpack file1]++-- | Tests with two configuration files+--+tests2Files3+    ∷ T.Text+        -- ^ test label prefix+    → T.Text+        -- ^ file for config0+    → T.Text+        -- ^ file for config1+    → [IO Bool]+tests2Files3 suffix file0 file1 =+    twoFileCasesC0C1 ("2files-3-" ⊕ suffix) [] x01+    ⊕ twoFileCasesC1C0 ("2files-3-" ⊕ suffix) [] x10+  where+    x01 = trueAssertion ["--config-file=" ⊕ T.unpack file0, "--config-file=" ⊕ T.unpack file1]+    x10 = trueAssertion ["--config-file=" ⊕ T.unpack file1, "--config-file=" ⊕ T.unpack file0]++-- | Tests with two configuration files c0 then c1+--+twoFileCasesC0C1 ∷ T.Text → [T.Text] → ConfAssertion HttpURL → [IO Bool]+twoFileCasesC0C1 prefix files x =+    [ runf files (prefix ⊕ "c0c1-0") True [x, f1 c1, f2 c0, f3 c1, f4 c0]+    , runf files (prefix ⊕ "c0c1-1") False [x, f1 c0]+    , runf files (prefix ⊕ "c0c1-2") False [x, d1]+    , runf files (prefix ⊕ "c0c1-3") False [x, f3 c0]+    , runf files (prefix ⊕ "c0c1-4") False [x, d4]+    ]+  where+    c0 = config0+    c1 = config1+    runf = runTest pkgInfo ∘ mainInfoConfigFile ∘ map ConfigFileRequired++-- | Tests with two configuration files c1 then c0+--+twoFileCasesC1C0 ∷ T.Text → [T.Text] → ConfAssertion HttpURL → [IO Bool]+twoFileCasesC1C0 prefix files x =+    [ runf files (prefix ⊕ "c1c0-0") True [x, f1 c0, f2 c0, f3 c0, f4 c0]+    , runf files (prefix ⊕ "c1c0-1") False [x, f1 c1]+    , runf files (prefix ⊕ "c1c0-2") False [x, f2 c1]+    , runf files (prefix ⊕ "c1c0-3") False [x, f3 c1]+    , runf files (prefix ⊕ "c1c0-4") False [x, f4 c1]+    ]+  where+    c0 = config0+    c1 = config1+    runf = runTest pkgInfo ∘ mainInfoConfigFile ∘ map ConfigFileRequired++-- -------------------------------------------------------------------------- --+-- Command Line argument tests++-- | Command Line argument test+--+tests0 ∷ [IO Bool]+tests0 =+    [ run "test0" False [d1, d2, d3, d4]++    , run "test1" True [t0, d2, d3, d4]+    , run "test2" True [t1, d2, d3, d4]+    , run "test3" True [d1, t2, d3, d4]+    , run "test4" False [d1, d2, t3, d4]+    , run "test5" False [d1, d2, d3, t4]++    , run "test6" False [t0, t1, d2, d3, d4]+    , run "test7" True [t0, t2, d3, d4]+    , run "test8" True [t0, d2, t3, d4]+    , run "test9" True [t0, d2, d3, t4]+    , run "test10" True [t1, t2, d3, d4]+    , run "test11" True [t1, d2, t3, d4]+    , run "test12" True [t1, d2, d3, t4]+    , run "test13" True [d1, t2, t3, d4]+    , run "test14" True [d1, t2, d3, t4]+    , run "test15" False [d1, d2, t3, t4]++    , run "test16" False [t0, t1, t2, d3, d4]+    , run "test17" False [t0, t1, t3, d4]+    , run "test18" False [t0, t1, d3, t4]+    , run "test19" True [t0, t2, t3, d4]+    , run "test20" True [t0, t2, d3, t4]+    , run "test21" True [t0, d2, t3, t4]+    , run "test22" True [t1, t2, t3, d4]+    , run "test23" True [t1, t2, d3, t4]+    , run "test24" True [t1, d2, t3, t4]+    , run "test25" True [d1, t2, t3, t4]++    , run "test26" False [t0, t1, t2, t3, d4]+    , run "test27" False [t0, t1, t2, d3, t4]+    , run "test28" False [t0, t1, d2, t3, t4]+    , run "test29" True [t0, t2, t3, t4]+    , run "test30" True [t1, t2, t3, t4]++    , run "test31" False [t0, t1, t2, t3, t4]+    ]+  where+    run = runTest pkgInfo mainInfo++-- -------------------------------------------------------------------------- --+-- Test Data++-- | Test configuration 0+--+config0 ∷ HttpURL+config0 = defaultHttpURL+    { _domain = "f0_localhost"+    , _path = "f0_path"+    , _auth = defaultAuth+        { _user = "f0_user"+        , _pwd = "f0_pwd"+        }+    }++-- | Test configuration 1+--+config1 ∷ HttpURL+config1 = defaultHttpURL+    { _domain = "f1_localhost"+    , _path = "f1_path"+    , _auth = defaultAuth+        { _user = "f1_user"+        , _pwd = "f1_pwd"+        }+    }++-- | A partial version of configuration 1+--+config1Part ∷ T.Text+config1Part = T.unlines+    [ "domain: " ⊕ T.pack (view domain config1)+    , "auth:"+    , "    user: " ⊕ T.pack (view (auth ∘ user) config1)+    ]++mainInfo ∷ ProgramInfoValidate HttpURL []+mainInfo = programInfoValidate "HTTP URL" pHttpURL defaultHttpURL validateHttpURL++mainInfoConfigFile+    ∷ [ConfigFile]+    → ProgramInfoValidate HttpURL []+mainInfoConfigFile files = set piConfigurationFiles files mainInfo++-- -------------------------------------------------------------------------- --+-- Building blocks for tests++-- assert values from given configuration++f1 ∷ HttpURL → ConfAssertion HttpURL+f1 conf = ConfAssertion [] domain (view domain conf)++f2 ∷ HttpURL → ConfAssertion HttpURL+f2 conf = ConfAssertion [] path (view path conf)++f3 ∷ HttpURL → ConfAssertion HttpURL+f3 conf = ConfAssertion [] (auth ∘ user) (view (auth ∘ user) conf)++f4 ∷ HttpURL → ConfAssertion HttpURL+f4 conf = ConfAssertion [] (auth ∘ pwd) (view (auth ∘ pwd) conf)++-- assert default values++d1 ∷ ConfAssertion HttpURL+d1 = f1 defaultHttpURL++d2 ∷ ConfAssertion HttpURL+d2 = f2 defaultHttpURL++d3 ∷ ConfAssertion HttpURL+d3 = f3 defaultHttpURL++d4 ∷ ConfAssertion HttpURL+d4 = f4 defaultHttpURL++-- assert values from command line++-- t0 and t1 are the same option+t0 ∷ ConfAssertion HttpURL+t0 = ConfAssertion ["--domain=c_localhost"] domain "c_localhost"++t1 ∷ ConfAssertion HttpURL+t1 = ConfAssertion ["-d", "c_localhost"] domain "c_localhost"++t2 ∷ ConfAssertion HttpURL+t2 = ConfAssertion ["--path=c_abc"] path "c_abc"++t3 ∷ ConfAssertion HttpURL+t3 = ConfAssertion ["--user=c_u"] (auth ∘ user) "c_u"++t4 ∷ ConfAssertion HttpURL+t4 = ConfAssertion ["--pwd=c_pwd"] (auth ∘ pwd) "c_pwd" 

@@ -0,0 +1,341 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: TestTools+-- Description: Tools for testing program configurations+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- Tools for testing program configurations+--+module TestTools+(+-- * Very Simple Debugging+  enableDebug+, debug++-- * Configuration Assertions for Testing+, ConfAssertion(..)+, trueLens+, trueAssertion++-- * Test Execution+, check+, runTest++-- * Test Configuration Files+, withConfigFile+, withConfigFileText+#ifdef REMOTE_CONFIGS+, ConfigType(..)+, serverUrl+, serverTlsUrl+, withConfigFileServer+#endif+) where++import Configuration.Utils+import Configuration.Utils.Internal++import Control.Exception+import Control.Monad++import qualified Data.ByteString.Char8 as B8+import Data.IORef+import Data.Monoid.Unicode+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Yaml as Yaml++import Distribution.Simple.Utils (withTempFile)++import Prelude.Unicode++import System.Environment+import System.IO++#ifdef REMOTE_CONFIGS+import Control.Concurrent+import qualified Data.ByteString.Lazy as LB+import Data.Maybe+import qualified Data.Text.Encoding as T+import qualified Network.Wai as WAI+import qualified Network.Wai.Handler.Warp as WARP+import qualified Network.Wai.Handler.WarpTLS as WARP+import qualified Network.HTTP.Types as HTTP+#endif++-- -------------------------------------------------------------------------- --+-- Very Simple Debugging++enableDebug ∷ Bool+enableDebug = False++debug+    ∷ Monad m+    ⇒ m ()+    → m ()+debug a+    | enableDebug = a+    | otherwise = return ()++-- -------------------------------------------------------------------------- --+-- Configuration Assertions for Testing++-- | Specify a assertion about the parsed configuration+--+-- The parameters are+--+-- 1. list of command line arguments,+-- 2. lens for the configuration value+-- 3. the expected value+--+data ConfAssertion β = ∀ α . Eq α ⇒ ConfAssertion [String] (Lens' β α) α++trueLens ∷ Lens' β ()+trueLens = lens (const ()) const++trueAssertion ∷ [String] → ConfAssertion β+trueAssertion args = ConfAssertion args trueLens ()++-- -------------------------------------------------------------------------- --+-- Test execution++-- Check the given list of assertions for the given configuration value+--+check+    ∷ α+    → [ConfAssertion α]+    → IO Bool+check conf assertions =+    foldM (\a (b,n) → (&& a) <$> go b n) True $ zip assertions [0 ∷ Int ..]+  where+    go (ConfAssertion _ l v) n =+        if view l conf ≡ v+          then do+            debug ∘ T.putStrLn $ "DEBUG: assertion " ⊕ sshow n ⊕ " succeeded"+            return True+          else do+            debug ∘ T.putStrLn $ "DEBUG: assertion " ⊕ sshow n ⊕ " failed"+            return False++-- | Run a test with an expected outcome ('True' or 'False')+-- for a given that of assertions.+--+runTest+    ∷ (FromJSON (α → α), ToJSON α)+    ⇒ PkgInfo+    → ProgramInfoValidate α []+    → T.Text+        -- ^ label for the test case+    → Bool+        -- ^ expected outcome+    → [ConfAssertion α]+        -- ^ test assertions+    → IO Bool+runTest pkgInfo mInfo label succeed assertions = do++    debug ∘ T.putStrLn $ "\nDEBUG: ======> " ⊕ label++    debug ∘ T.putStrLn $ "DEBUG: runWithPkgInfoConfiguration"+    a ← run $ runWithPkgInfoConfiguration mInfo pkgInfo++    debug ∘ T.putStrLn $ "DEBUG: runWithConfiguration"+    b ← run $ runWithConfiguration mInfo++    if a ≡ b && succeed ≡ (a && b)+      then+        return True+      else do+        T.putStrLn $ "WARNING: test " ⊕ label ⊕ " failed"+        return False+  where+    run f = do+        ref ← newIORef False+        handle (handler ref) $ withArgs args ∘ f $ \conf →+            writeIORef ref =<< check conf assertions+        readIORef ref++    args = concatMap (\(ConfAssertion x _ _) → x) assertions++    handler ref (e ∷ SomeException) = do+        writeIORef ref False+        debug ∘ T.putStrLn $ "DEBUG: caught exception: " ⊕ sshow e++-- -------------------------------------------------------------------------- --+-- Test Config Files+--++withConfigFile+    ∷ ToJSON γ+    ⇒ γ+    → (T.Text → IO α)+    → IO α+withConfigFile config inner =+    withTempFile "." "tmp_TestExample.yml" $ \tmpPath tmpHandle → do+        B8.hPutStrLn tmpHandle ∘ Yaml.encode $ config+        hClose tmpHandle+        inner $ T.pack tmpPath++withConfigFileText+    ∷ T.Text+    → (T.Text → IO α)+    → IO α+withConfigFileText configText inner =+    withTempFile "." "tmp_TestExample.yml" $ \tmpPath tmpHandle → do+        T.hPutStrLn tmpHandle configText+        hClose tmpHandle+        inner $ T.pack tmpPath+++#ifdef REMOTE_CONFIGS+data ConfigType = ∀ γ . ToJSON γ ⇒ ConfigType γ++instance ToJSON ConfigType where+    toJSON (ConfigType a) = toJSON a++withConfigFileServer+    ∷ [(T.Text, ConfigType)]+    → [(T.Text, T.Text)]+    → IO α+    → IO α+withConfigFileServer configs configTexts inner = do+    void ∘ forkIO $ WARP.run serverPort app+    void ∘ forkIO $ WARP.runTLS tlsSettings (warpSettings serverTlsPort) app+    inner+  where+    app req respond = do+        let maybeBody = LB.fromStrict <$> do+                p ← listToMaybe $ WAI.pathInfo req+                do+                    Yaml.encode <$> lookup p configs+                    <|>+                    (T.encodeUtf8 <$> lookup p configTexts)++        respond $ case maybeBody of+            Just body → WAI.responseLBS HTTP.status200 [] body+            Nothing → WAI.responseLBS HTTP.status404 [] "resource not found"++serverPort ∷ Int+serverPort = 8283++serverTlsPort ∷ Int+serverTlsPort = 8284++serverUrl ∷ T.Text+serverUrl = "http://127.0.0.1:" ⊕ sshow serverPort++serverTlsUrl ∷ T.Text+serverTlsUrl = "https://127.0.0.1:" ⊕ sshow serverTlsPort++tlsSettings ∷ WARP.TLSSettings+tlsSettings = WARP.tlsSettingsMemory serverCert serverKey++warpSettings ∷ Int → WARP.Settings+warpSettings port = WARP.setPort port WARP.defaultSettings++serverCert ∷ B8.ByteString+serverCert = B8.unlines+    [ "-----BEGIN CERTIFICATE-----"+    , "MIIF5TCCA82gAwIBAgIJAPT8MspOLMHrMA0GCSqGSIb3DQEBCwUAMFQxCzAJBgNV"+    , "BAYTAlVTMRMwEQYDVQQIEwpTb21lLVN0YXRlMRwwGgYDVQQKExNjb25maWd1cmF0"+    , "aW9uLXRvb2xzMRIwEAYDVQQDEwlsb2NhbGhvc3QwIBcNMTUwMjAzMjMzNjIyWhgP"+    , "MjExNTAxMTAyMzM2MjJaMFQxCzAJBgNVBAYTAlVTMRMwEQYDVQQIEwpTb21lLVN0"+    , "YXRlMRwwGgYDVQQKExNjb25maWd1cmF0aW9uLXRvb2xzMRIwEAYDVQQDEwlsb2Nh"+    , "bGhvc3QwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCtXCeoaw1m+JaX"+    , "qJnxKdOelNJxuZxPFoNN2tNIxY+63H6yH9XkhDw1bTPsTv2YX0ZdNxGHprh2a5jP"+    , "Z5gUh2EUsPnSNhnVhAGef3Y2gfAxeT1k81Ap4IKhBq9Drmlg7uJOPkqBkUhMi675"+    , "pVtxb2oSOrH4wkJD9n47dGSl2ziuUejfhzc0oZcVEs/w90KFkfNvTYXzSJfjU+WJ"+    , "KX2h0VI3m33lBbreyGktoccImF6+gHNKC0m+L74MyfLzu3TDlg7a+YwEOhCu2Tbf"+    , "kdPcSvSW0xEo9yn4epcGL+bRLXsT8DYQSE0q7sJf0I6y+nespoPCpfWnWinKbs7n"+    , "xNDl7wfD4spYcV19lgAicv7l1W+ItB3A/8KOSD+a7bc5LY7svKwBPV5ZQ4jRkvoa"+    , "Efcztv7i89/CjurCm3TX2oespTqCUOKYlc61NQQ9l//2yoBPY2IvBKUOPpDHSyn+"+    , "ZuMKdNu0mzdTHDjsbNW/es2n8Uk1wG+bQ60ZWCkixJZ/SCECBJpt1qkkgh9iclh+"+    , "abTBXBSU+N8DmyO9UACV9LlsBkKxjfK4F+mlodgP5C9R6nPlpYB7W9cuLvIWQnuR"+    , "DSnW6fS1T0g77mXMFeB8bjnADq7dM3aQXisvkX/XGT1KfsJdTqoau3dFMYArFpx9"+    , "0LqEh6pmt2rkNfFNPHnSx/hzVKr0ZwIDAQABo4G3MIG0MB0GA1UdDgQWBBRPlQCM"+    , "ToNUODspmRtqhXHcidXpRDCBhAYDVR0jBH0we4AUT5UAjE6DVDg7KZkbaoVx3InV"+    , "6UShWKRWMFQxCzAJBgNVBAYTAlVTMRMwEQYDVQQIEwpTb21lLVN0YXRlMRwwGgYD"+    , "VQQKExNjb25maWd1cmF0aW9uLXRvb2xzMRIwEAYDVQQDEwlsb2NhbGhvc3SCCQD0"+    , "/DLKTizB6zAMBgNVHRMEBTADAQH/MA0GCSqGSIb3DQEBCwUAA4ICAQAJfpa2Ju9j"+    , "Om7M5U9cQUZaYKqKe2N6+fx4y7C6J9oHAVjXzhevPm307I7MyVWpzh8+AShEnzyY"+    , "R83M8hL61cMOCjU3YOl6exz1jUYHXKhj0chl18z6wDM9o8NkoG4iFDbEipAtciKm"+    , "UbU+vm2d9z6mC+VN6xPVa9S72/+dRvyIgkPl3hQOZ5wKYic/7/EXM0MldQ7gb6KO"+    , "UuYDlr5aEHvF1J8Fnju5RzVofCPbC2obiwJN3RnYYFJv5pybQdnYfBg4z8OzgiQf"+    , "V/OVndzqyHWLg21MxPExM/PHFyuzeAh6e3lu6F1XhwoA4H8UzN1Gei2B8HfNQ54O"+    , "xyzeBu+kdPPzC0xQFm/s80CG+OPhtTd2ka6N2/YwgMSL6QOTQ1J7zpIwfsIgCaNH"+    , "Fkjj0gJk82+URMwjMhyh6m49qwhanL/9yodmascr27o10ZmAq6570C+zqaUoVk8y"+    , "m/PMNTHMLsSddjkelAKSjVU9+PQDRgnZTPiNhpEswgAbF8UjNkyxBRjBUrBIEGWd"+    , "k+PNgjOH3HPT3nWXYyTNTjAJQ7D5RVwFiROMdHdZdFjaxjRQpRkMvR/rpEdsf89H"+    , "75OZcCJzjg03soMUQ+ySp8Ax2Z6PSC1Cbvu+P+aOB0lyNpMYFuL0LVq5iWb6GmcB"+    , "5wxh9JKKsOVBhPDpOQlEAyRqtdXGbOwHNg=="+    , "-----END CERTIFICATE-----"+    ]++serverKey ∷ B8.ByteString+serverKey = B8.unlines+    [ "-----BEGIN RSA PRIVATE KEY-----"+    , "MIIJKAIBAAKCAgEArVwnqGsNZviWl6iZ8SnTnpTScbmcTxaDTdrTSMWPutx+sh/V"+    , "5IQ8NW0z7E79mF9GXTcRh6a4dmuYz2eYFIdhFLD50jYZ1YQBnn92NoHwMXk9ZPNQ"+    , "KeCCoQavQ65pYO7iTj5KgZFITIuu+aVbcW9qEjqx+MJCQ/Z+O3Rkpds4rlHo34c3"+    , "NKGXFRLP8PdChZHzb02F80iX41PliSl9odFSN5t95QW63shpLaHHCJhevoBzSgtJ"+    , "vi++DMny87t0w5YO2vmMBDoQrtk235HT3Er0ltMRKPcp+HqXBi/m0S17E/A2EEhN"+    , "Ku7CX9COsvp3rKaDwqX1p1opym7O58TQ5e8Hw+LKWHFdfZYAInL+5dVviLQdwP/C"+    , "jkg/mu23OS2O7LysAT1eWUOI0ZL6GhH3M7b+4vPfwo7qwpt019qHrKU6glDimJXO"+    , "tTUEPZf/9sqAT2NiLwSlDj6Qx0sp/mbjCnTbtJs3Uxw47GzVv3rNp/FJNcBvm0Ot"+    , "GVgpIsSWf0ghAgSabdapJIIfYnJYfmm0wVwUlPjfA5sjvVAAlfS5bAZCsY3yuBfp"+    , "paHYD+QvUepz5aWAe1vXLi7yFkJ7kQ0p1un0tU9IO+5lzBXgfG45wA6u3TN2kF4r"+    , "L5F/1xk9Sn7CXU6qGrt3RTGAKxacfdC6hIeqZrdq5DXxTTx50sf4c1Sq9GcCAwEA"+    , "AQKCAgBnaupdlj9QhkuP/YyYSZNsrus73LZal9uMvlX8u56aop8SM9utjxU76gFn"+    , "n1e5ZlzbjtZuTg8M1fM7B1m6JWjMpybhOFUBAtbUbsVejvVzDhiJ+HyB/uTumsZD"+    , "YfCLWva2JoLb+Idg4pNnajW63fQxG8K/22McmBeF8FF6f+S4WTTK5CcSxrMSZz6V"+    , "SWvtsru+UkjucQfrHUl5Ib9IoU6izae00E5CSNw11KSfhAZBLu+X5FQBmQmPJ4o/"+    , "zDxD0WjbSLM2ck0xgXMyvBPe/vgaYZ+DCK+JA9jEYB8Z+j/KDSqzW+5tBjH+ZrQ6"+    , "ISDzZgKEQ+zgAPGdSa00pjzYblf6jy2WUDwB38EtecuIxswmfuwWbSX0VGU2Pujl"+    , "2V/JonJv/j23MsRjYxcrgfZowdbSjFJtxkHRZiHvguKMZ+2hp23PonwLRe33zqSV"+    , "PE3YLy/R5wjN7EMUCccVqKb4VdOrIBl6sfZGzoGymE4Fq6x0+ueWuwammiNeegi2"+    , "UXAj93c8kBnfIh6397bfMgM6nLY/NK/igtO4cjuOP2aZpUD0oDzHDTkf+E9Ezavs"+    , "HDqMMuIgxHlKRmWAaw5LIWHsVYpekt9x9zuvb3lCMYOu2gr6XlxLR0L9SPR38uMG"+    , "WJNgo11qt5LCeFdXLBqP5WhqCb7yW2/BLiZM3ihSV/Yn5aZegQKCAQEA5bwEbZke"+    , "UxSljlz7UChbHAeHXrMN7t0+RueRE1hn5pMdZLTaLiUA+qnaCAgWWeeNqUnTRGpN"+    , "DD1/+0D3+5XDNtQiw93vIM/eXBN2HVzqKcPBggPmoIY99/e3vi+VYT8PQt0Sd+Tw"+    , "tfkGNpMen2F+YNWBg9NGtwAs1xDDrzLVD1c4gAxfAv2noywBbkRbn/UQbhcd6ebl"+    , "2DDKJVbZiCSnGAx2nZupet/R1W6fGWqYNv5+Gd/XRhrtwOdLEU6WqE3xN0VWK06y"+    , "D3fR6wPkScZM2UXupgsZyJMPVdb68mah+skOx0wZMWxYzmzDWaDm1kwlmP8FZBtr"+    , "jY3BtKdKza5X6QKCAQEAwS4kQUAkMzyzdScp8TV9dZnvf3QsajB5pTFfsWiGmkzx"+    , "kQQVvIX7L70Phh+oIHxaWhxxWw7J2G1QZu/bnrv+nDviGHo+ZEqY+7mPY/AVC3f4"+    , "i2mLAj61c+p2HtlFo0ZPntTClXHWR+jsA2z+zk2L2LxmvJFdfngOaHkAT5pg34CT"+    , "bJJMucNs0efEiGNgPCTIaZNPH5HW2lHPTOreRFImh843WsS0iLkWG9gMz6F5jkNr"+    , "ReGpJ3432dq91xot0iJ4Qo9cAEo8rra1BgbeJC7IIeLUt8Ud7lDGdTkzPMajqItO"+    , "jat/veec0+9tWzrUu/F6hBWrLtH8Q94ug2pNseaHzwKCAQB79HurKv/qsew2KUNM"+    , "V8n5ELLgzNnKtUNh/JYRixTcmyoz6UUDuuGRXk4PIVX2AnM0EWpVssmJvjEsvzxO"+    , "Wdsv3Tw41Kmu2ZnPsox7gWOzTzU80qAAow4Smm1gx8ng46Z3XFMXr8aVWR0aGz1d"+    , "n7wRwYGVQE0adpS7IgeDo3jEQzpwFLy7H2PxLdBDz8xkPVU1IXH5f6UqhgC8LuVG"+    , "iQhDeI4Tsia67sMIVxyvGQ2yNpSRn25HHEaGXAXr+6xceVmaieXZjieTIwJ3vOzT"+    , "RZS3cv02SC0MRRT0Kv/SBMCHUS6RKCU7vosYLiUlWiTTIdjzeT5OamEYypDmyZEZ"+    , "82TpAoIBABX5iLg/cp69dfCKrvO4UPgytZK7BV5i+0N2VVtZ943P2N7VJx/V4dfx"+    , "WrW4Hijr3F9Jwv9HtGBBNxcui74HxpPBIBwGs9g2wCZKWmxU4B/42rYJIH314jA4"+    , "aI1jy88h7Wa07xmO5IAzl71gBbA0FAdojws+QfNj9sedlBJ6DjD+cEa2cbHj8BoE"+    , "kk+tdkIBMScJUcPWlCkrizhFs1j0O1vRcmyJ2bt/ymsKbZKk3K35L1e4rsRGUFYg"+    , "0t2IJdQ0hZeUtTN3PmXldLwlxdk51Rw9sFLjQl9couasxg5Qzkca6aml65cPpMBb"+    , "CQaKr65dbsFdsaZWzqptuL7MNeBZx/MCggEBALqzujabof6VsX1+BrBeV6iz7VNV"+    , "ECHRaxDH7BIfLXWcP++nZH8nboBjnm7vE8ZBx7m8v1I2uWPQ/pkeClcRmtVeo+PW"+    , "Q9ITFaAmfMiJx/2VzOt9Ze5DT35kTyx4nt5dZ7znnSTqEvP2AEB8GY8zP6yy61Pd"+    , "Yw0cd2Buw0NqmWOIK83WSv44g7+maAkv4Jph5YA0lM3tQPwuKNFWNK2oOT5P911j"+    , "2GQMvNO99jq+FAf7XEL4WAZj+KOk0RBPa82dg8xTUMXEFhYHPhVfOpEZU3H099pM"+    , "Oo6zONyBMHTJazFr6atuwRR6RFRzHmMaJ0K72FBuHb4F31X+yOTSKT8rea0="+    , "-----END RSA PRIVATE KEY-----"+    ]+#endif++

@@ -0,0 +1,194 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Tests.BoolOption+-- Description: Tests for 'boolOption' and 'boolOption_'+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- load in ghci with:+--+-- > ghci -isrc -idist/build/autogen -itest -iexamples -DREMOTE_CONFIGS test/TestExample.hs+--+module Tests.BoolOption+( mainA+, boolOptionTests+) where++import Configuration.Utils+import Configuration.Utils.Internal+import TestTools++import Data.Monoid.Unicode++-- -------------------------------------------------------------------------- --+-- Setup++data A = A+    { _a ∷ !Bool+    , _b ∷ !Bool+    , _c ∷ !Bool+    }+    deriving (Show, Read, Eq, Ord)++a ∷ Lens' A Bool+a = lens _a $ \s x → s { _a = x }++b ∷ Lens' A Bool+b = lens _b $ \s x → s { _b = x }++c ∷ Lens' A Bool+c = lens _c $ \s x → s { _c = x }++defaultA ∷ A+defaultA = A True True True++pA ∷ MParser A+pA = id+    <$< a .:: boolOption_+        × long "a"+        ⊕ short 'a'+        ⊕ help "a flag"+    <*< b .:: boolOption+        × long "b"+        ⊕ short 'b'+        ⊕ help "b flag"+    <*< c .:: enableDisableFlag+        × long "c"+        ⊕ long "c_"+        ⊕ short 'd' -- 'c' is taken by --config-file+        ⊕ help "c flag"++instance ToJSON A where+    toJSON A{..} = object+        [ "a" .= _a+        , "b" .= _b+        , "c" .= _c+        ]++instance FromJSON (A → A) where+    parseJSON = withObject "A" $ \o → id+        <$< a ..: "a" % o+        <*< b ..: "b" % o+        <*< c ..: "c" % o++infoA ∷ ProgramInfo A+infoA = programInfo "BoolOptionTest" pA (A True True True)++infoA_ ∷ ProgramInfo A+infoA_ = programInfo "BoolOptionTest" pA (A False False False)++mainA ∷ IO ()+mainA = runWithConfiguration infoA print++-- -------------------------------------------------------------------------- --+-- Tests++da ∷ ConfAssertion A+da = ConfAssertion [] a $ _a defaultA++db ∷ ConfAssertion A+db = ConfAssertion [] b $ _b defaultA++dc ∷ ConfAssertion A+dc = ConfAssertion [] c $ _c defaultA++boolOptionTests ∷ PkgInfo → [IO Bool]+boolOptionTests pkgInfo = atests ⊕ btests ⊕ ctests ⊕ ctests_+  where+    atests =+        [ runA 1 True [da, db, dc]+        , runA 2 True [ConfAssertion ["--a"] a True]+        , runA 3 True [ConfAssertion ["-a"] a True]+        , runA 4 False [ConfAssertion ["-no-a"] a True]++        , runA 5 False [ConfAssertion ["--a=true"] a True]+        , runA 6 False [ConfAssertion ["--a=false"] a False]+        , runA 7 False [ConfAssertion ["--a", "true"] a True]+        , runA 8 False [ConfAssertion ["--a", "false"] a False]++        , runA 9 True [ConfAssertion ["--no-a"] a False]+        , runA 10 False [ConfAssertion ["--no-a=true"] a True]+        , runA 11 False [ConfAssertion ["--no-a=false"] a False]+        , runA 12 False [ConfAssertion ["--no-a", "true"] a True]+        , runA 13 False [ConfAssertion ["--no-a", "false"] a False]++        , runA 14 True [ConfAssertion ["-a"] a True]+        , runA 15 False [ConfAssertion ["-a=true"] a True]+        , runA 16 False [ConfAssertion ["-a=false"] a False]+        , runA 17 False [ConfAssertion ["-a", "true"] a True]+        , runA 18 False [ConfAssertion ["-a", "false"] a False]+        ]++    btests =+        [ runB 1 False [ConfAssertion ["--b"] b True]+        , runB 2 False [ConfAssertion ["-b"] b True]+        , runB 3 False [ConfAssertion ["-no-b"] b True]++        , runB 4 True [ConfAssertion ["--b=true"] b True]+        , runB 5 True [ConfAssertion ["--b=false"] b False]+        , runB 6 True [ConfAssertion ["--b", "true"] b True]+        , runB 7 True [ConfAssertion ["--b", "false"] b False]++        , runB 8 False [ConfAssertion ["-b=true"] b True]+        , runB 9 False [ConfAssertion ["-b=false"] b False]+        , runB 10 True [ConfAssertion ["-b", "true"] b True]+        , runB 12 True [ConfAssertion ["-b", "false"] b False]++        , runB 13 True [ConfAssertion ["--b=TRUE"] b True]+        , runB 14 True [ConfAssertion ["--b=FALSE"] b False]+        , runB 15 True [ConfAssertion ["--b", "TRUE"] b True]+        , runB 16 True [ConfAssertion ["--b", "FALSE"] b False]++        , runB 17 True [ConfAssertion ["--b=True"] b True]+        , runB 18 True [ConfAssertion ["--b=False"] b False]+        , runB 19 True [ConfAssertion ["--b", "True"] b True]+        , runB 20 True [ConfAssertion ["--b", "False"] b False]+        ]++    ctests =+        [ runC 1 True [da, db, dc]+        , runC 2 False [ConfAssertion ["--c"] c True]+        , runC 3 False [ConfAssertion ["--c_"] c True]+        , runC 4 False [ConfAssertion ["--c"] c False]+        , runC 5 False [ConfAssertion ["--c_"] c False]+        , runC 6 True [ConfAssertion ["--enable-c"] c True]+        , runC 7 True [ConfAssertion ["--enable-c_"] c True]+        , runC 8 True [ConfAssertion ["-d"] c True]+        , runC 9 False [ConfAssertion ["-disable-c"] c False]+        , runC 10 False [ConfAssertion ["-disable-c"] c True]+        , runC 9 False [ConfAssertion ["-disable-d"] c False]+        , runC 10 False [ConfAssertion ["-disable-d"] c True]+        , runC 10 False [ConfAssertion ["--disable-d"] c False]+        , runC 11 True [ConfAssertion ["--disable-c"] c False]+        , runC 12 True [ConfAssertion ["--disable-c_"] c False]+        ]++    ctests_ =+        [ runC_ 1 False [da, db, dc]+        , runC_ 2 False [ConfAssertion ["--c"] c True]+        , runC_ 3 False [ConfAssertion ["--c_"] c True]+        , runC_ 4 False [ConfAssertion ["--c"] c False]+        , runC_ 5 False [ConfAssertion ["--c_"] c False]+        , runC_ 6 True [ConfAssertion ["--enable-c"] c True]+        , runC_ 7 True [ConfAssertion ["--enable-c_"] c True]+        , runC_ 8 True [ConfAssertion ["-d"] c True]+        , runC_ 9 False [ConfAssertion ["-disable-c"] c False]+        , runC_ 10 False [ConfAssertion ["-disable-c"] c True]+        , runC_ 11 True [ConfAssertion ["--disable-c"] c False]+        , runC_ 12 True [ConfAssertion ["--disable-c_"] c False]+        ]++    runA (x ∷ Int) = runTest pkgInfo infoA ("boolOption-a-" ⊕ sshow x)+    runB (x ∷ Int) = runTest pkgInfo infoA ("boolOption-b-" ⊕ sshow x)++    runC (x ∷ Int) = runTest pkgInfo infoA ("boolOption-c1-" ⊕ sshow x)+    runC_ (x ∷ Int) = runTest pkgInfo infoA_ ("boolOption-c2-" ⊕ sshow x)+

@@ -0,0 +1,256 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Tests.MonoidConfig+-- Description: Test cases for monoidal configuration types+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+module Tests.MonoidConfig+( monoidUpdateTests+) where++import TestTools++import Configuration.Utils+import Configuration.Utils.Internal+import Configuration.Utils.Validation++import qualified Data.HashMap.Strict as HM+import Data.Monoid.Unicode+import Data.String+import qualified Data.Text as T++import Prelude.Unicode++-- -------------------------------------------------------------------------- --+-- Test cases++monoidUpdateTests ∷ PkgInfo → [IO Bool]+monoidUpdateTests pkgInfo = concatMap ($ pkgInfo)+    [ routingTableTests+    , textAppendTestsR+    , textAppendTestsFilesR+    , textAppendTestsL+    , textAppendTestsFilesL+    ]++-- -------------------------------------------------------------------------- --+-- HashMap++newtype RoutingTable = RoutingTable { _routingTableMap ∷ HM.HashMap T.Text T.Text }++routingTableMap ∷ Lens' RoutingTable (HM.HashMap T.Text T.Text)+routingTableMap = lens _routingTableMap $ \a b → a { _routingTableMap = b }++defaultRoutingTable ∷ RoutingTable+defaultRoutingTable = RoutingTable HM.empty++instance ToJSON RoutingTable where+    toJSON RoutingTable{..} = object+        [ "route_map" .= _routingTableMap+        ]++instance FromJSON (RoutingTable → RoutingTable) where+    parseJSON = withObject "RoutingTable" $ \o → id+        <$< routingTableMap . fromLeftMonoidalUpdate %.: "route_map" × o++pRoutingTable ∷ MParser RoutingTable+pRoutingTable = routingTableMap %:: pLeftMonoidalUpdate pRoute+  where+    pRoute = option (eitherReader readRoute)+        × long "route"+        ⊕ help "add a route to the routing table; the APIROUTE part must not contain a colon character"+        ⊕ metavar "APIROUTE:APIURL"++    readRoute s = case break (== ':') s of+        (a,':':b) → fmapL T.unpack $ do+            validateNonEmpty "APIROUTE" a+            validateHttpOrHttpsUrl "APIURL" b+            return $ HM.singleton (T.pack a) (T.pack b)+        _ → Left "missing colon between APIROUTE and APIURL"++mainInfoRoutingTable ∷ ProgramInfoValidate RoutingTable []+mainInfoRoutingTable = programInfoValidate "Routing Table" pRoutingTable defaultRoutingTable (const $ return ())++-- Test Cases++routingTableTests ∷ PkgInfo → [IO Bool]+routingTableTests pkgInfo =+    [ run 0 [ConfAssertion ["--route=a:" ⊕ b0] (routingTableMap ∘ at "a") $ Just b0]+    , run 1 [ConfAssertion ["--route=a:" ⊕ b0, "--route=a:" ⊕ b1] (routingTableMap ∘ at "a") $ Just b1]+    , run 2 [ConfAssertion ["--route=a:" ⊕ b0, "--route=a:" ⊕ b1] (routingTableMap ∘ at "a") $ Just b1]+    , run 3 [ConfAssertion ["--route=a:" ⊕ b0, "--route=b:" ⊕ b1] (routingTableMap ∘ at "a") $ Just b0]+    , run 4 [ConfAssertion ["--route=a:" ⊕ b0, "--route=b:" ⊕ b1] (routingTableMap ∘ at "b") $ Just b1]+    , run 5 [ConfAssertion ["--route=a:" ⊕ b0, "--route=b:" ⊕ b1] (routingTableMap ∘ at "c") Nothing]+    ]+  where+    b0,b1 ∷ IsString a ⇒ a+    b0 = "http://b0"+    b1 = "https://b1"+    run (x ∷ Int) = runTest pkgInfo mainInfoRoutingTable ("routing-table-" ⊕ sshow x) True++    at k f m = f mv <&> \r → case r of+        Nothing → maybe m (const (HM.delete k m)) mv+        Just v' → HM.insert k v' m+      where+        mv = HM.lookup k m+        (<&>) = flip fmap++-- -------------------------------------------------------------------------- --+-- Text with right append++newtype StringConfigR = StringConfigR { _stringConfigR ∷ T.Text }++stringConfigR ∷ Lens' StringConfigR T.Text+stringConfigR = lens _stringConfigR $ \a b → a { _stringConfigR = b }++defaultStringConfigR ∷ StringConfigR+defaultStringConfigR = StringConfigR "|"++instance ToJSON StringConfigR where+    toJSON StringConfigR{..} = object+        [ "string" .= _stringConfigR+        ]++instance FromJSON (StringConfigR → StringConfigR) where+    parseJSON = withObject "StringConfigR" $ \o → id+        <$< stringConfigR . fromRightMonoidalUpdate %.: "string" × o++pStringConfigR ∷ MParser StringConfigR+pStringConfigR = stringConfigR %:: pRightMonoidalUpdate pString+  where+    pString = T.pack <$> strOption × long "string"++-- Test cases++textAppendTestsR ∷ PkgInfo → [IO Bool]+textAppendTestsR pkgInfo =+    [ run 0 True [ConfAssertion [] stringConfigR "|"]+    , run 1 True [ConfAssertion ["--string=a"] stringConfigR "|a"]++    , run 2 True [ConfAssertion ["--string=a", "--string=b"] stringConfigR "|ab"]+    , run 3 False [ConfAssertion ["--string=a", "--string=b"] stringConfigR "|ba"]+    , run 4 False [ConfAssertion ["--string=b", "--string=a"] stringConfigR "|ab"]+    , run 5 True [ConfAssertion ["--string=b", "--string=a"] stringConfigR "|ba"]++    , run 6 False [ConfAssertion ["--string=aaa", "--string=bbb"] stringConfigR "|bbbaaa"]+    , run 7 True [ConfAssertion ["--string=aaa", "--string=bbb"] stringConfigR "|aaabbb"]+    , run 8 True [ConfAssertion ["--string=bbb", "--string=aaa"] stringConfigR "|bbbaaa"]+    , run 9 False [ConfAssertion ["--string=bbb", "--string=aaa"] stringConfigR "|aaabbb"]+    ]+  where+    run (x ∷ Int) = runTest pkgInfo mi ("stringR-" ⊕ sshow x)+    mi = programInfoValidate "Text right append" pStringConfigR defaultStringConfigR (const $ return ())++textAppendTestsFilesR ∷ PkgInfo → [IO Bool]+textAppendTestsFilesR pkgInfo =+    [ run ca 0 True [ConfAssertion [] stringConfigR "|a"]++    , run ca 2 True [ConfAssertion ["--string=b"] stringConfigR "|ab"]+    , run ca 3 False [ConfAssertion ["--string=b"] stringConfigR "|ba"]+    , run cb 4 False [ConfAssertion ["--string=a"] stringConfigR "|ab"]+    , run cb 5 True [ConfAssertion ["--string=a"] stringConfigR "|ba"]++    , run2 ca ca 6 True [ConfAssertion [] stringConfigR "|aa"]+    , run2 ca cb 6 False [ConfAssertion [] stringConfigR "|ba"]+    , run2 ca cb 7 True [ConfAssertion [] stringConfigR "|ab"]+    , run2 cb ca 8 True [ConfAssertion [] stringConfigR "|ba"]+    , run2 cb ca 9 False [ConfAssertion [] stringConfigR "|ab"]+    ]+  where+    ca = StringConfigR "a"+    cb = StringConfigR "b"+    run c (x ∷ Int) b a = withConfigFile c $ \file →+        runTest pkgInfo (mi [file]) ("stringR-file1-" ⊕ sshow x) b a++    run2 c0 c1 (x ∷ Int) b a =+        withConfigFile c0 $ \file0 →+        withConfigFile c1 $ \file1 →+        runTest pkgInfo (mi [file0,file1]) ("stringR-file2-" ⊕ sshow x) b a++    mi files = set piConfigurationFiles (map ConfigFileRequired files) $+      programInfoValidate "Text right append with files" pStringConfigR defaultStringConfigR (const $ return ())++-- -------------------------------------------------------------------------- --+-- Text with left append++newtype StringConfigL = StringConfigL { _stringConfigL ∷ T.Text }++stringConfigL ∷ Lens' StringConfigL T.Text+stringConfigL = lens _stringConfigL $ \a b → a { _stringConfigL = b }++defaultStringConfigL ∷ StringConfigL+defaultStringConfigL = StringConfigL "|"++instance ToJSON StringConfigL where+    toJSON StringConfigL{..} = object+        [ "string" .= _stringConfigL+        ]++instance FromJSON (StringConfigL → StringConfigL) where+    parseJSON = withObject "StringConfigL" $ \o → id+        <$< stringConfigL . fromLeftMonoidalUpdate %.: "string" × o++pStringConfigL ∷ MParser StringConfigL+pStringConfigL = stringConfigL %:: pLeftMonoidalUpdate pString+  where+    pString = T.pack <$> strOption × long "string"++-- Test cases++textAppendTestsL ∷ PkgInfo → [IO Bool]+textAppendTestsL pkgInfo =+    [ run 0 True [ConfAssertion [] stringConfigL "|"]+    , run 1 True [ConfAssertion ["--string=a"] stringConfigL "a|"]++    , run 2 True [ConfAssertion ["--string=a", "--string=b"] stringConfigL "ba|"]+    , run 3 False [ConfAssertion ["--string=a", "--string=b"] stringConfigL "ab|"]+    , run 4 False [ConfAssertion ["--string=b", "--string=a"] stringConfigL "ba|"]+    , run 5 True [ConfAssertion ["--string=b", "--string=a"] stringConfigL "ab|"]++    , run 6 True [ConfAssertion ["--string=aaa", "--string=bbb"] stringConfigL "bbbaaa|"]+    , run 7 False [ConfAssertion ["--string=aaa", "--string=bbb"] stringConfigL "aaabbb|"]+    , run 8 False [ConfAssertion ["--string=bbb", "--string=aaa"] stringConfigL "bbbaaa|"]+    , run 9 True [ConfAssertion ["--string=bbb", "--string=aaa"] stringConfigL "aaabbb|"]+    ]+  where+    run (x ∷ Int) = runTest pkgInfo mi ("stringL-" ⊕ sshow x)+    mi = programInfoValidate "Text left append" pStringConfigL defaultStringConfigL (const $ return ())++textAppendTestsFilesL ∷ PkgInfo → [IO Bool]+textAppendTestsFilesL pkgInfo =+    [ run ca 1 True [ConfAssertion [] stringConfigL "a|"]++    , run ca 2 True [ConfAssertion ["--string=b"] stringConfigL "ba|"]+    , run ca 3 False [ConfAssertion ["--string=b"] stringConfigL "ab|"]+    , run cb 4 False [ConfAssertion ["--string=a"] stringConfigL "ba|"]+    , run cb 5 True [ConfAssertion ["--string=a"] stringConfigL "ab|"]++    , run2 ca ca 1 True [ConfAssertion [] stringConfigL "aa|"]+    , run2 ca cb 2 True [ConfAssertion [] stringConfigL "ba|"]+    , run2 ca cb 3 False [ConfAssertion [] stringConfigL "ab|"]+    , run2 cb ca 4 False [ConfAssertion [] stringConfigL "ba|"]+    , run2 cb ca 5 True [ConfAssertion [] stringConfigL "ab|"]+    ]+  where+    ca = StringConfigL "a"+    cb = StringConfigL "b"+    run c (x ∷ Int) b a = withConfigFile c $ \file →+        runTest pkgInfo (mi [file]) ("stringL-file1-" ⊕ sshow x) b a++    run2 c0 c1 (x ∷ Int) b a =+        withConfigFile c0 $ \file0 →+        withConfigFile c1 $ \file1 →+        runTest pkgInfo (mi [file0,file1]) ("stringL-file2-" ⊕ sshow x) b a++    mi files = set piConfigurationFiles (map ConfigFileRequired files) $+      programInfoValidate "Text left append with file" pStringConfigL defaultStringConfigL (const $ return ())+