configuration-tools (empty) → 0.2.1

raw patch · 12 files changed

+2418/−0 lines, 12 filesdep +Cabaldep +aesondep +attoparsecbuild-type:Customsetup-changed

Dependencies added: Cabal, aeson, attoparsec, base, base-unicode-symbols, bytestring, configuration-tools, directory, errors, optparse-applicative, process, profunctors, text, transformers, unordered-containers, yaml

Files

• CHANGELOG.md +10/−0
• LICENSE +20/−0
• README.md +535/−0
• Setup.hs +311/−0
• configuration-tools.cabal +114/−0
• constraints +57/−0
• examples/Example.hs +145/−0
• examples/Trivial.hs +24/−0
• src/Configuration/Utils.hs +601/−0
• src/Configuration/Utils/Http.hs +244/−0
• src/Configuration/Utils/Internal.hs +46/−0
• src/Configuration/Utils/Setup.hs +311/−0

@@ -0,0 +1,10 @@+0.2.1+=====++*   Fix build with GHC-7.6 by relaxing lower bounds on some dependencies.++0.2+===++First release.+

@@ -0,0 +1,20 @@+Copyright (c) 2014 AlephCloud Systems, Inc.++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,535 @@+[![Build Status](https://travis-ci.org/alephcloud/hs-configuration-tools.svg?branch=master)](https://travis-ci.org/alephcloud/hs-configuration-tools)++Overview+========++This package provides a collection of utils on top of the packages+[optparse-applicative](http://hackage.haskell.org/package/optparse-applicative),+[aeson](http://hackage.haskell.org/package/aeson), and+[yaml](http://hackage.haskell.org/package/yaml) for configuring libraries and+applications in a composable way.++The main features are++1.   configuration management through integration of command line option+     parsing and configuration files and+2.   a `Setup.hs` file that generates a `PkgInfo` module for each component+     of a package that provide information about the package and the build.++Configuration Management+========================++The goal of this package 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.++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.++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.++`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.++`--help, -h`+:   prints a help message and exits.++The operators 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` of the+cabal package.++Usage Example+-------------++Remark: there are unicode equivalents for some operators available in+`Configuration.Utils` that lead to better aligned and more readable code.++We start with language extensions and imports.++~~~{.haskell}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++module Main+( main+) where++import Configuration.Utils+import Data.Monoid+~~~++Next we define the types that are used for the configuration of our application.+In this contrived example these types define a simplified version of HTTP URLs.++~~~{.haskell}+data Auth = Auth+    { _user :: !String+    , _pwd :: !String+    }+~~~++We have to define lenses for the configuration types. Here we do it explicitely.+Alternatively one could have used TemplateHaskell along with `makeLenses` from+the module `Control.Lens` from the [lens](http://hackage.haskell.org/package/lens)+package.++~~~{.haskell}+user :: Functor f => (String -> f String) -> Auth -> f Auth+user f s = (\u → s { _user = u }) <$> f (_user s)++pwd :: Functor f => (String -> f String) -> Auth -> f Auth+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.)++We must provide a default value. If there is no reasonable default the+respective value could, for instance, be wrapped into `Maybe`. Here we+use the monoid identity value of the type.++~~~{.haskell}+defaultAuth :: Auth+defaultAuth = Auth+    { _user = ""+    , _pwd = ""+    }+~~~++Now we define an [aeson](https://hackage.haskell.org/package/aeson) `FromJSON`+instance that yields a function that updates a given `Auth` value with the+values from the parsed JSON value. The `<.>` operator is functional composition+lifted for applicative functors and `%` is a version of `$` with a different+precedence that helps to reduce the use of paranthesis in applicative style+code.++~~~{.haskell}+instance FromJSON (Auth -> Auth) where+    parseJSON = withObject "Auth" $ \o -> pure id+        <.> user ..: "user" % o+        <.> pwd ..: "pwd" % o+~~~++The `ToJSON` instance is needed to print the configuration (as YAML document)+when the user provides the `--print-config` command line option.++~~~{.haskell}+instance ToJSON Auth where+    toJSON a = object+        [ "user" .= _user a+        , "pwd" .= _pwd a+        ]+~~~++Finally we define a command line option parser using the machinery from+the [optparse-applicative](https://hackage.haskell.org/package/optparse-applicative)+package. Similar to the `FromJSON` instance the parser does not yield a value+directly but instead yields a function that updates a given `Auth` value with+the value from the command line.++~~~{.haskell}+pAuth :: MParser Auth+pAuth = pure id+    <.> user .:: strOption+        % long "user"+        <> help "user name"+    <.> pwd .:: strOption+        % long "pwd"+        <> help "password for user"+~~~++You may consult the documentation of the+[optparse-applicative](http://hackage.haskell.org/package/optparse-applicative)+package for further information on how to define command line options.++The following definitons for the `HttpURL` are similar to definitions for+the `Auth` type above. In addition it is demonstrated how to deal with nested+configuration types. Mainly the usage of `..:` is replaced by `%.:` and+`.::` is replaced by `%::`.++~~~{.haskell}+data HttpURL = HttpURL+    { _auth :: !Auth+    , _domain :: !String+    , _path :: !String+    }++auth :: Functor f => (Auth -> f Auth) -> HttpURL -> f HttpURL+auth f s = (\u → s { _auth = u }) <$> f (_auth s)++domain :: Functor f => (String -> f String) -> HttpURL -> f HttpURL+domain f s = (\u → s { _domain = u }) <$> f (_domain s)++path :: Functor f => (String -> f String) -> HttpURL -> f HttpURL+path f s = (\u → s { _path = u }) <$> f (_path s)++defaultHttpURL :: HttpURL+defaultHttpURL = HttpURL+    { _auth = defaultAuth+    , _domain = ""+    , _path = ""+    }++instance FromJSON (HttpURL -> HttpURL) where+    parseJSON = withObject "HttpURL" $ \o -> pure id+        <.> auth %.: "auth" % o+        <.> domain ..: "domain" % o+        <.> path ..: "path" % o++instance ToJSON HttpURL where+    toJSON a = object+        [ "auth" .= _auth a+        , "domain" .= _domain a+        , "path" .= _path a+        ]++pHttpURL :: MParser HttpURL+pHttpURL = pure id+    <.> auth %:: pAuth+    <.> domain .:: strOption+        % long "domain"+        <> short 'd'+        <> help "HTTP domain"+    <.> path .:: strOption+        % long "path"+        <> short 'p'+        <> help "HTTP URL path"+~~~++Now that everything is set up the configuration can be used to create a+`ProgramInfo` value. The `ProgramInfo` value is than use with the+`runWithConfiguratin` function to wrap a main function that takes an `HttpURL`+argument with configuration file and command line parsing.++~~~{.haskell}+mainInfo :: ProgramInfo HttpURL+mainInfo = programInfo "HTTP URL" pHttpURL defaultHttpURL++main :: IO ()+main = runWithConfiguration mainInfo $ \conf -> do+    putStrLn+        $ "http://"+        <> (_user . _auth) conf+        <> ":"+        <> (_pwd . _auth) conf+        <> "@"+        <> _domain conf+        <> "/"+        <> _path conf+~~~++Using Sum Types as Configuration Types+======================================++Sum types can not be used as configuration types in the same way as product types.+The reason is that the nondeterminism in the choice of a term for the type is+not restricted to the choosen constructor arguments but in addition there+is non-determinism in the choice of the constructor, too.++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.++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+than a single constructor. For now one must restrict configurations of sum types+to yield constant values instead of point-wise (partial) updates. In practice+this means that for a type `a` one has to provide an `FromJSON` instance for `a`+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 configuration values of type `Maybe a`, though being sum types, 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++*   the function does an pointwise update using the `FromJSON` instance for+    `a -> a` when applied to `Just a` and+*   the function uses the `FromJSON` instance for `a` to return the parsed `a`+    value when applied to 'Nothing'.++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.++Package and Build Information+=============================++The module `Configuration.Utils.Setup` an example `Setup.hs` script that hooks+into the cabal build process at the end of the configuration phase and generates+a module with package information for each component of the cabal pacakge.++The modules are created in the *autogen* build directory where also the *Path_*+module is created by cabal's simple build setup. This is usually the directory+`./dist/build/autogen`.++For a library component the module is named just `PkgInfo`. For all+other components the module is named `PkgInfo_COMPONENT_NAME` where+`COMPONENT_NAME` is the name of the component with `-` characters replaced by+`_`.++For instance, if a cabal package contains a library and an executable that+is called *my-app*, the following modules are created: `PkgInfo`+and `PkgInfo_my_app`.++Usage as Setup Script+---------------------++There are two ways how this module can be used:++1.  Copy the code of this module into a file called `Setup.hs` in the root+    directory of your package.++2.  If the *configuration-tools* package is already installed in the system+    where the build is done, following code can be used as `Setup.hs` script:++    ~~~{.haskell}+    module Main (main) where++    import Configuration.Utils.Setup+    ~~~++With both methods the field `Build-Type` in the package description (cabal) file+must be set to `Custom`:++    Build-Type: Custom++Integration With `Configuration.Utils`+--------------------------------------++You can integrate the information provided by the `PkgInfo` modules with the+command line interface of an application by importing the respective module for+the component and using the `runWithPkgInfoConfiguration` function from the+module `Configuration.Utils` as show in the following example:++~~~{.haskell}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++module Main+( main+) where++import Configuration.Utils+import PkgInfo++instance FromJSON (() -> ()) where parseJSON _ = pure id++mainInfo :: ProgramInfo ()+mainInfo = programInfo "Hello World" (pure id) ()++main :: IO ()+main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world"+~~~++With that the resulting application supports the following additional command+line options:++`--version, -v`+:    prints the version of 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.+    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.++Here is the example output of `--long-info` for the example+`examples/Trivial.hs` from this package:++~~~{.shell}+trivial-0.1 (package configuration-tools-0.1 revision 080c27a)+Copyright (c) 2014 AlephCloud, Inc.++Author: Lars Kuhtz <lars@alephcloud.com>+License: MIT+Homepage: https://github.com/alephcloud/hs-configuration-tools+Build with: ghc-7.8.2 (x86_64-osx)+Build flags:++Dependencies:+    Cabal-1.21.0.0 [BSD3, 2003-2006, Isaac Jones 2005-2011, Duncan Coutts]+    MonadRandom-0.1.13 [OtherLicense]+    aeson-0.7.0.6 [BSD3, (c) 2011-2014 Bryan O'Sullivan (c) 2011 MailRank, Inc.]+    ansi-terminal-0.6.1.1 [BSD3]+    ansi-wl-pprint-0.6.7.1 [BSD3]+    array-0.5.0.0 [BSD3]+    attoparsec-0.11.3.4 [BSD3]+    base-4.7.0.0 [BSD3]+    base-unicode-symbols-0.2.2.4 [BSD3, 2009–2011 Roel van Dijk <vandijk.roel@gmail.com>]+    rts-1.0 [BSD3]+    bytestring-0.10.4.0 [BSD3, Copyright (c) Don Stewart 2005-2009, (c) Duncan Coutts 2006-2013, (c) David Roundy 2003-2005, (c) Jasper Van der Jeugt 2010, (c) Simon Meier 2010-2013.]+    comonad-4.2 [BSD3, Copyright (C) 2008-2013 Edward A. Kmett, Copyright (C) 2004-2008 Dave Menendez]+    conduit-1.1.2.1 [MIT]+    containers-0.5.5.1 [BSD3]+    contravariant-0.5.1 [BSD3, Copyright (C) 2007-2013 Edward A. Kmett]+    deepseq-1.3.0.2 [BSD3]+    directory-1.2.1.0 [BSD3]+    distributive-0.4.3.2 [BSD3, Copyright (C) 2011-2014 Edward A. Kmett]+    dlist-0.7.0.1 [BSD3, 2006-2009 Don Stewart, 2013 Sean Leather]+    either-4.1.2 [BSD3, Copyright (C) 2008-2014 Edward A. Kmett]+    errors-1.4.7 [BSD3, 2012, 2013 Gabriel Gonzalez]+    exceptions-0.6.1 [BSD3, Copyright (C) 2013-2014 Edward A. Kmett Copyright (C) 2012 Google Inc.]+    filepath-1.3.0.2 [BSD3]+    ghc-prim-0.3.1.0 [BSD3]+    hashable-1.2.2.0 [BSD3]+    integer-gmp-0.5.1.0 [BSD3]+    lifted-base-0.2.2.2 [BSD3, (c) 2011-2012 Bas van Dijk, Anders Kaseorg]+    mmorph-1.0.3 [BSD3, 2013 Gabriel Gonzalez]+    monad-control-0.3.3.0 [BSD3, (c) 2011 Bas van Dijk, Anders Kaseorg]+    mtl-2.1.3.1 [BSD3]+    nats-0.2 [BSD3, Copyright (C) 2011-2014 Edward A. Kmett]+    old-locale-1.0.0.6 [BSD3]+    optparse-applicative-0.8.1 [BSD3, (c) 2012 Paolo Capriotti <p.capriotti@gmail.com>]+    pretty-1.1.1.1 [BSD3]+    primitive-0.5.3.0 [BSD3, (c) Roman Leshchinskiy 2009-2012]+    process-1.2.0.0 [BSD3]+    random-1.0.1.1 [BSD3]+    resourcet-1.1.2.2 [BSD3]+    safe-0.3.4 [BSD3, Neil Mitchell 2007-2014]+    scientific-0.3.2.0 [BSD3]+    semigroupoids-4.0.2 [BSD3, Copyright (C) 2011-2013 Edward A. Kmett]+    semigroups-0.14 [BSD3, Copyright (C) 2011-2014 Edward A. Kmett]+    syb-0.4.1 [BSD3]+    tagged-0.7.2 [BSD3, 2009-2013 Edward A. Kmett]+    template-haskell-2.9.0.0 [BSD3]+    text-1.1.1.2 [BSD3, 2009-2011 Bryan O'Sullivan, 2008-2009 Tom Harper]+    time-1.4.2 [BSD3]+    transformers-0.3.0.0 [BSD3]+    transformers-base-0.4.2 [BSD3, 2011 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>, Bas van Dijk <v.dijk.bas@gmail.com>]+    transformers-compat-0.1.1.1 [BSD3, Copyright (C) 2012 Edward A. Kmett]+    unix-2.7.0.1 [BSD3]+    unordered-containers-0.2.4.0 [BSD3, 2010-2014 Johan Tibell 2010 Edward Z. Yang]+    vector-0.10.9.1 [BSD3, (c) Roman Leshchinskiy 2008-2012]+    void-0.6.1 [BSD3, Copyright (C) 2008-2013 Edward A. Kmett]+    yaml-0.8.8.3 [BSD3]++Available options:+  -i,--info                Print program info message and exit+  --long-info              Print detailed program info message and exit+  -v,--version             Print version string and exit+  --license                Print license of the program and exit+  -h,--help                Show this help text+  -p,--print-config        Print the parsed configuration to standard out and+                           exit+  -c,--config-file FILE    Configuration file for backend services in YAML+                           fromat+~~~++Configuration Types for HTTP Services and Clients+=================================================++The module `Configuration.Utils.Http` contains some types for configuring HTTP+services and clients. Currently these types only provide the most basic+configuration settings. This will probably be extended in the future. Feel free+to submit patches for missing settings.++TODO+====++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.++*   Come up with a storry for sum types. We may use the following approach: The+    definition of the default should include alternate values for each+    constructor. Effectively, this means to map the sum type onto a product type+    by interpreting the summands as factors. For mapping back from the product+    type to the original sum type one has to provide a choice of the+    constructor. Intuitively, a sum type can be represented as a tree where the+    leafs partition the type into classes of value with the same constructors.+    By providing a default value for each such class partial configurations that+    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.++*   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.+

@@ -0,0 +1,311 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-- | This module contains a @Setup.hs@ script that hooks into the cabal build+-- process at the end of the configuration phase and generates a module with+-- package information for each component of the cabal package.+--+-- The modules are created in the /autogen/ build directory where also the+-- @Path_@ module is created by cabal's simple build setup. This is usually the+-- directory @.\/dist\/build\/autogen@.+--+-- For a library component the module is named just @PkgInfo@. For all other+-- components the module is named @PkgInfo_COMPONENT_NAME@ where+-- @COMPONENT_NAME@ is the name of the component with @-@ characters replaced by+-- @_@.+--+-- For instance, if a cabal package contains a library and an executable that is+-- called /my-app/, the following modules are created: @PkgInfo@ and+-- @PkgInfo_my_app@.+--+--+-- = Usage as Setup Script+--+-- There are two ways how this module can be used:+--+-- 1. Copy the code of this module into a file called @Setup.hs@ in the root+--    directory of your package.+--+-- 2. If the /configuration-tools/ package is already installed in the system+--    where the build is done, following code can be used as @Setup.hs@ script:+--+--    > module Main (main) where+--    >+--    > import Configuration.Utils.Setup+--+-- With both methods the field @Build-Type@ in the package description (cabal) file+-- must be set to @Custom@:+--+-- > Build-Type: Custom+--+--+-- = Integration With "Configuration.Utils"+--+-- You can integrate the information provided by the @PkgInfo@ modules with the+-- command line interface of an application by importing the respective module+-- for the component and using the+-- 'Configuration.Utils.runWithPkgInfoConfiguration' function from the module+-- "Configuration.Utils" as show in the following example:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- >+-- > module Main+-- > ( main+-- > ) where+-- >+-- > import Configuration.Utils+-- > import PkgInfo+-- >+-- > instance FromJSON (() -> ()) where parseJSON _ = pure id+-- >+-- > mainInfo :: ProgramInfo ()+-- > mainInfo = programInfo "Hello World" (pure id) ()+-- >+-- > main :: IO ()+-- > main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world"+--+-- With that the resulting application supports the following additional command+-- line options:+--+-- [@--version@, @-v@]+--     prints the version of 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.+--     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.+--+module Main (main) where++import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.Setup+import qualified Distribution.InstalledPackageInfo as I+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.BuildPaths+import Distribution.Simple.PackageIndex+import Distribution.Text+import System.Process++import Control.Applicative+import Control.Monad++import qualified Data.ByteString as B+import Data.ByteString.Char8 (pack)+import Data.Char (isSpace)+import Data.List (intercalate)+import Data.Monoid++import Prelude hiding (readFile, writeFile)++import System.Directory (doesFileExist, doesDirectoryExist, createDirectoryIfMissing)+import System.Exit (ExitCode(ExitSuccess))++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+    { postConf = mkPkgInfoModules+    }+  where+    mkPkgInfoModules _ _ pkgDesc bInfo = mapM_ f . map (\(a,_,_) -> a) $ componentsConfigs bInfo+      where+        f cname = case cname of+            CLibName -> updatePkgInfoModule Nothing pkgDesc bInfo+            CExeName s -> updatePkgInfoModule (Just s) pkgDesc bInfo+            CTestName s -> updatePkgInfoModule (Just s) pkgDesc bInfo+            CBenchName s -> updatePkgInfoModule (Just s) pkgDesc bInfo++pkgInfoModuleName :: Maybe String -> String+pkgInfoModuleName Nothing = "PkgInfo"+pkgInfoModuleName (Just cn) = "PkgInfo_" ++ map tr cn+  where+    tr '-' = '_'+    tr c = c++pkgInfoFileName :: Maybe String -> LocalBuildInfo -> FilePath+pkgInfoFileName cn bInfo = autogenModulesDir bInfo ++ "/" ++ pkgInfoModuleName cn ++ ".hs"++trim :: String -> String+trim = f . f+  where f = reverse . dropWhile isSpace++getVCS :: IO (Maybe RepoType)+getVCS = do+    doesDirectoryExist ".hg" >>= \x0 -> if x0+    then return (Just Mercurial)+    else doesDirectoryExist ".git" >>= \x1 -> if x1+    then return (Just Git)+    else return Nothing++pkgInfoModule :: Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString+pkgInfoModule cName pkgDesc bInfo = do+    (tag, revision, branch) <- getVCS >>= \x -> case x of+        Just Mercurial -> hgInfo+        Just Git -> gitInfo+        _ -> noVcsInfo++    let vcsBranch = if branch == "default" || branch == "master" then "" else branch+        vcsVersion = intercalate "-" . filter (/= "") $ [tag, revision, vcsBranch]+        flags = map fst . filter snd . configConfigurationsFlags . configFlags $ bInfo++    licenseString <- licenseFilesText pkgDesc++    return $ B.intercalate "\n" $+            [ "{-# LANGUAGE OverloadedStrings #-}"+            , "{-# LANGUAGE RankNTypes #-}"+            , ""+            , "module " <> (pack . pkgInfoModuleName) cName <> " where"+            , ""+            , "    import Data.String (IsString)"+            , "    import Data.Monoid"+            , ""+            , "    name :: IsString a => Maybe a"+            , "    name = " <> maybe "Nothing" (\x -> "Just \"" <> pack x <> "\"") cName+            , ""+            , "    tag :: IsString a => a"+            , "    tag = \"" <> pack tag <> "\""+            , ""+            , "    revision :: IsString a => a"+            , "    revision = \"" <> pack revision <> "\""+            , ""+            , "    branch :: IsString a => a"+            , "    branch = \"" <> pack branch <> "\""+            , ""+            , "    branch' :: IsString a => a"+            , "    branch' = \"" <> pack vcsBranch <> "\""+            , ""+            , "    vcsVersion :: IsString a => a"+            , "    vcsVersion = \"" <> pack vcsVersion <> "\""+            , ""+            , "    compiler :: IsString a => a"+            , "    compiler = \"" <> (pack . display . compilerId . compiler) bInfo <> "\""+            , ""+            , "    flags :: IsString a => [a]"+            , "    flags = " <> (pack . show) flags+            , ""+            , "    arch :: IsString a => a"+            , "    arch = \"" <> (pack . display . hostPlatform) bInfo <> "\""+            , ""+            , "    license :: IsString a => a"+            , "    license = \"" <> (pack . display . license) pkgDesc <> "\""+            , ""+            , "    licenseText :: IsString a => a"+            , "    licenseText = " <> (pack . show) licenseString+            , ""+            , "    copyright :: IsString a => a"+            , "    copyright = \"" <> (pack . copyright) pkgDesc <> "\""+            , ""+            , "    author :: IsString a => a"+            , "    author = \"" <> (pack . author) pkgDesc <> "\""+            , ""+            , "    homepage :: IsString a => a"+            , "    homepage = \"" <> (pack . homepage) pkgDesc <> "\""+            , ""+            , "    package :: IsString a => a"+            , "    package = \"" <> (pack . display . package) pkgDesc <> "\""+            , ""+            , "    packageName :: IsString a => a"+            , "    packageName = \"" <> (pack . display . packageName) pkgDesc <> "\""+            , ""+            , "    packageVersion :: IsString a => a"+            , "    packageVersion = \"" <> (pack . display . packageVersion) pkgDesc <> "\""+            , ""+            , "    dependencies :: IsString a => [a]"+            , "    dependencies = " <> (pack . show . map (display . packageId) . allPackages . installedPkgs) bInfo+            , ""+            , "    dependenciesWithLicenses :: IsString a => [a]"+            , "    dependenciesWithLicenses = " <> (pack . show . map pkgIdWithLicense . allPackages . installedPkgs) bInfo+            , ""+            , "    versionString :: (Monoid a, IsString a) => a"+            , "    versionString = case name of"+            , "        Nothing -> package <> \" (revision \" <> vcsVersion <> \")\""+            , "        Just n -> n <> \"-\" <> packageVersion <> \" (package \" <> package <> \" revision \" <> vcsVersion <> \")\""+            , ""+            , "    info :: (Monoid a, IsString a) => a"+            , "    info = versionString <> \"\\n\" <> copyright"+            , ""+            , "    longInfo :: (Monoid a, IsString a) => a"+            , "    longInfo = info <> \"\\n\\n\""+            , "        <> \"Author: \" <> author <> \"\\n\""+            , "        <> \"License: \" <> license <> \"\\n\""+            , "        <> \"Homepage: \" <> homepage <> \"\\n\""+            , "        <> \"Build with: \" <> compiler <> \" (\" <> arch <> \")\" <> \"\\n\""+            , "        <> \"Build flags: \" <> mconcat (map (\\x -> \" \" <> x) flags) <> \"\\n\\n\""+            , "        <> \"Dependencies:\\n\" <> mconcat (map (\\x -> \"    \" <> x <> \"\\n\") dependenciesWithLicenses)"+            , ""+            , "    pkgInfo :: (Monoid a, IsString a) => (a, a, a, a)"+            , "    pkgInfo ="+            , "        ( info"+            , "        , longInfo"+            , "        , versionString"+            , "        , licenseText"+            , "        )"+            , ""+            ]++updatePkgInfoModule :: Maybe String -> PackageDescription -> LocalBuildInfo -> IO ()+updatePkgInfoModule cName pkgDesc bInfo = do+    createDirectoryIfMissing True $ autogenModulesDir bInfo+    newFile <- pkgInfoModule cName pkgDesc bInfo+    let update = B.writeFile fileName newFile+    doesFileExist fileName >>= \x -> if x+    then do+        oldRevisionFile <- B.readFile fileName+        when (oldRevisionFile /= newFile) update+    else+        update+  where+    fileName = pkgInfoFileName cName bInfo++licenseFilesText :: PackageDescription -> IO B.ByteString+licenseFilesText PackageDescription{ licenseFiles = fileNames } =+    B.intercalate "\n------------------------------------------------------------\n" <$> mapM fileText fileNames+  where+    fileText file = doesFileExist file >>= \x -> if x+        then B.readFile file+        else return ""++hgInfo :: IO (String, String, String)+hgInfo = do+    tag <- fmap trim $ readProcess "hg" ["id", "-r", "max(ancestors(\".\") and tag())", "-t"] ""+    rev <- fmap trim $ readProcess "hg" ["id", "-i"] ""+    branch <- fmap trim $ readProcess "hg" ["id", "-b"] ""+    return (tag, rev, branch)++gitInfo :: IO (String, String, String)+gitInfo = do+    tag <- do+        (exitCode, out, _err) <- readProcessWithExitCode "git" ["describe", "--exact-match", "--abbrev=0"] ""+        case exitCode of+            ExitSuccess -> return $ trim out+            _ -> return ""+    rev <- fmap trim $ readProcess "git" ["rev-parse", "--short", "HEAD"] ""+    branch <- fmap trim $ readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] ""+    return (tag, rev, branch)++noVcsInfo :: IO (String, String, String)+noVcsInfo = return ("", "", "")++pkgIdWithLicense :: I.InstalledPackageInfo -> String+pkgIdWithLicense a = (display . packageId) a+    ++ " ["+    ++ (display . I.license) a+    ++ (if cr /= "" then ", " ++ cr else "")+    ++ "]"+  where+    cr = (unwords . words . I.copyright) a+

@@ -0,0 +1,114 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++Name:                configuration-tools+Version:             0.2.1+Synopsis:            Tools for specifying and parsing configurations+description:+    Tools for specifying and parsing configurations+    .+    This package provides a collection of utils on top of the packages+    <http://hackage.haskell.org/package/optparse-applicative optparse-applicative>,+    <http://hackage.haskell.org/package/aeson aeson>, and+    <http://hackage.haskell.org/package/yaml yaml> for configuring libraries and+    applications in a convenient and composable way.+    .+    The main features are+    .+    1. configuration management through integration of command line option+       parsing and configuration files and+    .+    2. a @Setup.hs@ file that generates a @PkgInfo@ module for each component+       of a package that provides information about the package and the build.+    .+    Documentation on how to use this package can be found in the+    <https://github.com/alephcloud/hs-configuration-tools/blob/master/README.md README>+    and in the API documentation of the modules "Configuration.Utils" and+    "Configuration.Utils.Setup".++Homepage:            https://github.com/alephcloud/hs-configuration-tools+Bug-reports:         https://github.com/alephcloud/hs-configuration-tools/issues+License:             MIT+License-file:        LICENSE+Author:              Lars Kuhtz <lars@alephcloud.com>+Maintainer:          Lars Kuhtz <lars@alephcloud.com>+Copyright:           Copyright (c) 2014 AlephCloud, Inc.+Category:            Configuration, Console+Build-type:          Custom++cabal-version:  >= 1.20++extra-doc-files:+    README.md,+    CHANGELOG.md++extra-source-files:+    constraints++source-repository head+    type: git+    location: https://github.com/alephcloud/hs-configuration-tools.git++source-repository this+    type: git+    location: https://github.com/alephcloud/hs-configuration-tools.git+    tag: 0.2.1++Library+    hs-source-dirs: src+    default-language: Haskell2010++    exposed-modules:+        -- Configuration.Utils.FromJsonWithDef+        Configuration.Utils+        Configuration.Utils.Http+        Configuration.Utils.Setup++    other-modules:+        Configuration.Utils.Internal++    build-depends:+        Cabal >= 1.20,+        aeson >= 0.7.0.6,+        attoparsec >= 0.11.3.4,+        base >= 4.6 && < 5.0,+        base-unicode-symbols >= 0.2.2.4,+        bytestring >= 0.10.0.2,+        directory >= 1.2.1.0,+        errors >= 1.4.3,+        optparse-applicative >= 0.8.1,+        process >= 1.2.0.0,+        text >= 1.0,+        transformers >= 0.3.0.0,+        unordered-containers >= 0.2.4.0,+        yaml >= 0.8.8.3,+        profunctors >= 4.0.4++    ghc-options: -Wall++Test-Suite url-example+    type: exitcode-stdio-1.0+    default-language: Haskell2010+    main-is: Example.hs+    hs-source-dirs: examples++    build-depends:+        base >= 4.6 && < 5.0,+        base-unicode-symbols >= 0.2.2.4,+        configuration-tools++    ghc-options: -Wall++Test-Suite trivial+    type: exitcode-stdio-1.0+    default-language: Haskell2010+    main-is: Trivial.hs+    hs-source-dirs: examples++    build-depends:+        base >= 4.6 && < 5.0,+        base-unicode-symbols >= 0.2.2.4,+        configuration-tools++    ghc-options: -Wall

@@ -0,0 +1,57 @@+constraints: Cabal ==1.21.0.0,+             MonadRandom ==0.1.13,+             aeson ==0.7.0.6,+             ansi-terminal ==0.6.1.1,+             ansi-wl-pprint ==0.6.7.1,+             array ==0.5.0.0,+             attoparsec ==0.11.3.4,+             base ==4.7.0.0,+             base-unicode-symbols ==0.2.2.4,+             bytestring ==0.10.4.0,+             comonad ==4.2,+             conduit ==1.1.2.1,+             configuration-tools ==0.2,+             containers ==0.5.5.1,+             contravariant ==0.5.1,+             deepseq ==1.3.0.2,+             directory ==1.2.1.0,+             distributive ==0.4.3.2,+             dlist ==0.7.0.1,+             either ==4.1.2,+             errors ==1.4.7,+             exceptions ==0.6.1,+             filepath ==1.3.0.2,+             ghc-prim ==0.3.1.0,+             hashable ==1.2.2.0,+             integer-gmp ==0.5.1.0,+             lifted-base ==0.2.2.2,+             mmorph ==1.0.3,+             monad-control ==0.3.3.0,+             mtl ==2.1.3.1,+             nats ==0.2,+             old-locale ==1.0.0.6,+             optparse-applicative ==0.8.1,+             pretty ==1.1.1.1,+             primitive ==0.5.3.0,+             process ==1.2.0.0,+             profunctors ==4.0.4,+             random ==1.0.1.1,+             resourcet ==1.1.2.2,+             rts ==1.0,+             safe ==0.3.4,+             scientific ==0.3.2.0,+             semigroupoids ==4.0.2,+             semigroups ==0.14,+             syb ==0.4.1,+             tagged ==0.7.2,+             template-haskell ==2.9.0.0,+             text ==1.1.1.2,+             time ==1.4.2,+             transformers ==0.3.0.0,+             transformers-base ==0.4.2,+             transformers-compat ==0.1.1.1,+             unix ==2.7.0.1,+             unordered-containers ==0.2.4.0,+             vector ==0.10.9.1,+             void ==0.6.1,+             yaml ==0.8.8.3

@@ -0,0 +1,145 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++module Main+( main+) where++import Configuration.Utils+import Data.Monoid.Unicode+import Prelude.Unicode++-- This assume usage of cabal with custom Setup.hs+--+import PkgInfo_url_example++-- | Specification of the authentication section of a URL.+--+data Auth = Auth+    { _user ∷ !String+    , _pwd ∷ !String+    }++-- Define Lenses.+--+-- (alternatively we could have used TemplateHaskell along with+-- 'makeLenses' from "Control.Lens" from the lens package.)++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)++defaultAuth ∷ Auth+defaultAuth = Auth+    { _user = ""+    , _pwd = ""+    }++instance FromJSON (Auth → Auth) where+    parseJSON = withObject "Auth" $ \o → pure id+        ⊙ user ..: "user" × o+        ⊙ pwd ..: "pwd" × o++instance ToJSON Auth where+    toJSON a = object+        [ "user" .= _user a+        , "pwd" .=  _pwd a+        ]++pAuth ∷ MParser Auth+pAuth = pure id+    ⊙ user .:: strOption+        × long "user"+        ⊕ help "user name"+    ⊙ pwd .:: strOption+        × long "pwd"+        ⊕ help "password for user"++-- | Simplified specification of an HTTP URL+--+data HttpURL = HttpURL+    { _auth ∷ !Auth+    , _domain ∷ !String+    , _path ∷ !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)++defaultHttpURL ∷ HttpURL+defaultHttpURL = HttpURL+    { _auth = defaultAuth+    , _domain = ""+    , _path = ""+    }++instance FromJSON (HttpURL → HttpURL) where+    parseJSON = withObject "HttpURL" $ \o → pure id+        ⊙ auth %.: "auth" × o+        ⊙ domain ..: "domain" × o+        ⊙ path ..: "path" × o++instance ToJSON HttpURL where+    toJSON a = object+        [ "auth" .= _auth a+        , "domain" .= _domain a+        , "path" .= _path a+        ]++pHttpURL ∷ MParser HttpURL+pHttpURL = pure id+    ⊙ auth %:: pAuth+    ⊙ domain .:: strOption+        × long "domain"+        ⊕ short 'd'+        ⊕ help "HTTP domain"+    ⊙ path .:: strOption+        × long "path"+        ⊕ short 'p'+        ⊕ help "HTTP URL path"++-- | Information about the main Application+--+mainInfo ∷ ProgramInfo HttpURL+mainInfo = programInfo "HTTP URL" pHttpURL defaultHttpURL++-- This version assumes usage of cabal with custom Setup.hs+--+main ∷ IO ()+main = runWithPkgInfoConfiguration mainInfo pkgInfo $ \conf → do+    putStrLn+        $ "http://"+        ⊕ (_user ∘ _auth) conf+        ⊕ ":"+        ⊕ (_pwd ∘ _auth) conf+        ⊕ "@"+        ⊕ _domain conf+        ⊕ "/"+        ⊕ _path conf++-- This version does not rely on cabal+--+main_ ∷ IO ()+main_ = runWithConfiguration mainInfo $ \conf → do+    putStrLn+        $ "http://"+        ⊕ (_user ∘ _auth) conf+        ⊕ ":"+        ⊕ (_pwd ∘ _auth) conf+        ⊕ "@"+        ⊕ _domain conf+        ⊕ "/"+        ⊕ _path conf

@@ -0,0 +1,24 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++module Main+( main+) where++import Configuration.Utils+import PkgInfo_trivial++instance FromJSON (() → ()) where+    parseJSON _ = pure id++mainInfo ∷ ProgramInfo ()+mainInfo = programInfo "Hello World" (pure id) ()++main ∷ IO ()+main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world"+

@@ -0,0 +1,601 @@+-- ------------------------------------------------------ --+-- 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.+--+-- 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++-- * Running an Configured Application+, runWithConfiguration+, PkgInfo+, runWithPkgInfoConfiguration++-- * Applicative Option Parsing with Default Values+, MParser+, (.::)+, (%::)++-- * Parsing of Configuration Files with Default Values+, (..:)+, (%.:)++-- * Misc Utils+, (%)+, (×)+, (<.>)+, (⊙)+, dropAndUncaml+, Lens'++-- * Configuration of Optional Values+-- $maybe++-- * Reexports+, module Data.Aeson+, module Options.Applicative+) where++import Configuration.Utils.Internal++import Control.Error (fmapL)++import Data.Aeson+import Data.Aeson.Types (Parser)+import qualified Data.ByteString.Char8 as B8+import Data.Char+import qualified Data.HashMap.Strict as H+import Data.Maybe+import Data.Monoid+import Data.Monoid.Unicode+import qualified Data.Text as T+import qualified Data.Yaml as Yaml++import Options.Applicative hiding (Parser, Success, (&))+import qualified Options.Applicative as O++import Prelude.Unicode++import System.IO.Unsafe (unsafePerformIO)++-- -------------------------------------------------------------------------- --+-- Useful Operators++-- | This operator is an alternative for '$' with a higher precedence which+-- makes it suitable for usage within Applicative style funtors without the need+-- to add parenthesis.+--+(%) ∷ (α → β) → α → β+(%) = ($)+infixr 5 %+{-# INLINE (%) #-}++-- | This operator is a UTF-8 version of '%' which is an alternative for '$'+-- with a higher precedence which makes it suitable for usage within Applicative+-- style funtors without the need to add parenthesis.+--+-- 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.+--+-- This is a rather popular operator. Due to conflicts (for instance with the+-- lens package) it may have to be imported qualified.+--+(<.>) ∷ Applicative φ ⇒ φ (β → γ) → φ (α → β) → φ (α → γ)+(<.>) a b = pure (.) <*> a <*> b+infixr 4 <.>+{-# INLINE (<.>) #-}++-- | 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 (⊙) #-}++-- -------------------------------------------------------------------------- --+-- 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 = pure id+-- >    ⊙ user .:: strOption+-- >        × long "user"+-- >        ⊕ short 'u'+-- >        ⊕ help "user name"+-- >    ⊙ pwd .:: strOption+-- >        × long "pwd"+-- >        ⊕ short 'p'+-- >        ⊕ 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 = pure 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 variant of the aeson operator '.:' that creates a parser+-- that updates a setter with the parsed value.+--+-- > 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 → pure id+-- >         ⊙ user ..: "user" × o+-- >         ⊙ pwd ..: "pwd" × o+--+(..:) ∷ FromJSON β ⇒ Lens' α β → T.Text → Object → Parser (α → α)+(..:) s k o = case H.lookup k o of+    Nothing → pure id+    Just v → set s <$> parseJSON v+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 → pure 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 (%.:) #-}++-- -------------------------------------------------------------------------- --+-- Main Configuration++data ProgramInfo α = ProgramInfo+    { _piDescription ∷ !String+      -- ^ Program Description+    , _piHelpHeader ∷ !(Maybe String)+      -- ^ Help header+    , _piHelpFooter ∷ !(Maybe String)+      -- ^ Help footer+    , _piOptionParser ∷ !(MParser α)+      -- ^ options parser for configuration (TODO consider using a typeclass for this)+    , _piDefaultConfiguration ∷ !α+      -- ^ default configuration+    }++-- | Program Description+--+piDescription ∷ Lens' (ProgramInfo α) String+piDescription = lens _piDescription $ \s a → s { _piDescription = a}++-- | Help header+--+piHelpHeader ∷ Lens' (ProgramInfo α) (Maybe String)+piHelpHeader = lens _piHelpHeader $ \s a → s { _piHelpHeader = a}++-- | Help footer+--+piHelpFooter ∷ Lens' (ProgramInfo α) (Maybe String)+piHelpFooter = lens _piHelpFooter $ \s a → s { _piHelpFooter = a}++-- | options parser for configuration (TODO consider using a typeclass for this)+--+piOptionParser ∷ Lens' (ProgramInfo α) (MParser α)+piOptionParser = lens _piOptionParser $ \s a → s { _piOptionParser = a}++-- | default configuration+--+piDefaultConfiguration ∷ Lens' (ProgramInfo α) α+piDefaultConfiguration = lens _piDefaultConfiguration $ \s a → s { _piDefaultConfiguration = a}++-- | Smart constructor for 'ProgramInfo'.+--+-- 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'.+--+programInfo ∷ String → MParser α → α → ProgramInfo α+programInfo desc parser defaultConfig = ProgramInfo+    { _piDescription = desc+    , _piHelpHeader = Nothing+    , _piHelpFooter = Nothing+    , _piOptionParser = parser+    , _piDefaultConfiguration = defaultConfig+    }++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.nullOption+        × O.long "config-file"+        ⊕ O.short 'c'+        ⊕ O.metavar "FILE"+        ⊕ O.help "Configuration file in YAML format"+        ⊕ O.eitherReader (\file → fileReader file <*> pure d)+        ⊕ O.value d+  where+    fileReader file = fmapL (\e → "failed to parse configuration file " ⊕ file ⊕ ": " ⊕ show e)+        $ unsafePerformIO (Yaml.decodeFileEither file)++mainOptions+    ∷ ∀ α . FromJSON (α → α)+    ⇒ ProgramInfo α+    → (∀ β . 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+        <*> O.helper+        <*> (over mainConfig <$> _piOptionParser)+        <*> pAppConfiguration _piDefaultConfiguration++-- | 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 α)+    ⇒ ProgramInfo α+    → (α → IO ())+    → IO ()+runWithConfiguration appInfo mainFunction = do+    conf ← O.customExecParser parserPrefs mainOpts+    if _printConfig conf+        then B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ conf+        else mainFunction ∘ _mainConfig $ conf+  where+    mainOpts = mainOptions appInfo Nothing+    parserPrefs = O.prefs+        $ O.disambiguate+        ⊕ O.showHelpOnError++-- -------------------------------------------------------------------------- --+-- 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-inf@]+--     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 α)+    ⇒ ProgramInfo α+    → PkgInfo+    → (α → IO ())+    → IO ()+runWithPkgInfoConfiguration appInfo pkgInfo mainFunction = do+    conf ← O.customExecParser parserPrefs mainOpts+    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+        ⊕ O.showHelpOnError++-- -------------------------------------------------------------------------- --+-- Configuration of Optional Values++-- $maybe+-- Optional configuration values are supposed to be encoded by wrapping+-- the respective type with 'Maybe'.+--+-- For this 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)+

@@ -0,0 +1,244 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Configuration.Utils.Http+(+-- * HTTP Service TLS Configuration+  HttpServiceTLSConfiguration+, hstcCertFile+, hstcKeyFile++-- * HTTP Service Configuration+, HttpServiceConfiguration+, hscHost+, hscPort+, hscUseTLS+, defaultHttpServiceConfiguration+, pHttpServiceConfiguration++-- * Http Client Configuration+, HttpClientConfiguration+, hccHost+, hccPort+, hccUseTLS+, defaultHttpClientConfiguration+, pHttpClientConfiguration+, httpService2clientConfiguration+) where++import Configuration.Utils+import Configuration.Utils.Internal++import qualified Data.ByteString.Char8 as B8+import Data.Maybe (isJust)+import Data.Monoid.Unicode++import Prelude.Unicode++-- -------------------------------------------------------------------------- --+-- Http Service TLS Configuration++-- | In order to make TLS optional this type should be used+-- wrapped into a Maybe.+--+data HttpServiceTLSConfiguration = HttpServiceTLSConfiguration+    { _hstcCertFile ∷ !FilePath+    , _hstcKeyFile ∷ !FilePath+    }+    deriving (Show, Read, Eq, Ord)++hstcCertFile ∷ Lens' HttpServiceTLSConfiguration FilePath+hstcCertFile = lens _hstcCertFile $ \s a → s { _hstcCertFile = a}++hstcKeyFile ∷ Lens' HttpServiceTLSConfiguration FilePath+hstcKeyFile = lens _hstcKeyFile $ \s a → s { _hstcKeyFile = a}++defaultHttpServiceTLSConfiguration ∷ HttpServiceTLSConfiguration+defaultHttpServiceTLSConfiguration = HttpServiceTLSConfiguration+    { _hstcCertFile = "cert.pem"+    , _hstcKeyFile = "key.pem"+    }++instance FromJSON (HttpServiceTLSConfiguration → HttpServiceTLSConfiguration) where+    parseJSON = withObject "HttpServiceTLSConfiguration" $ \o → pure id+        ⊙ hstcCertFile ..: "cert-file" × o+        ⊙ hstcKeyFile ..: "pem-file" × o++-- | This is used as default when wrapped into Maybe and+--+-- 1. the parsed value is not 'Null' and+-- 2. the given default is not 'Nothing'.+--+instance FromJSON HttpServiceTLSConfiguration where+    parseJSON v = parseJSON v <*> pure defaultHttpServiceTLSConfiguration++instance ToJSON HttpServiceTLSConfiguration where+    toJSON HttpServiceTLSConfiguration{..} = object+        [ "cert-file" .= _hstcCertFile+        , "key-file" .= _hstcKeyFile+        ]++-- | This option parser does not allow to enable or disable+-- usage of TLS. The option will have effect only when TLS+-- usage is configured in the configuration file or the default+-- configuration.+--+-- FIXME: print a warning and exit when one of these options is+-- provided even though TLS is turned off.+--+pHttpServiceTLSConfiguration ∷ String → MParser HttpServiceTLSConfiguration+pHttpServiceTLSConfiguration prefix = pure id+    ⊙ hstcCertFile .:: strOption+        × long (prefix ⊕ "cert-file")+        ⊕ help "File with PEM encoded TLS Certificate"+    ⊙ hstcKeyFile .:: strOption+        × long (prefix ⊕ "key-file")+        ⊕ help "File with PEM encoded TLS key"++-- -------------------------------------------------------------------------- --+-- Http Service Configuration++-- | We restrict services to use either HTTP or HTTPS but not both.+--+-- TLS can be turned off explicitely in the configuration file by+-- setting the respective section to @null@. It can not be+-- turned on or off via command line options. But once it is turned+-- on the values for the certificate and key file can be changed+-- by command line options.+--+data HttpServiceConfiguration = HttpServiceConfiguration+    { _hscHost ∷ !B8.ByteString+    , _hscPort ∷ !Int+    , _hscInterface ∷ !B8.ByteString+    , _hscUseTLS ∷ !(Maybe HttpServiceTLSConfiguration)+    }+    deriving (Show, Read, Eq, Ord)++hscHost ∷ Lens' HttpServiceConfiguration B8.ByteString+hscHost = lens _hscHost $ \s a → s { _hscHost = a}++hscPort ∷ Lens' HttpServiceConfiguration Int+hscPort = lens _hscPort $ \s a → s { _hscPort = a}++hscInterface ∷ Lens' HttpServiceConfiguration B8.ByteString+hscInterface = lens _hscInterface $ \s a → s { _hscInterface = a}++hscUseTLS ∷ Lens' HttpServiceConfiguration (Maybe HttpServiceTLSConfiguration)+hscUseTLS = lens _hscUseTLS $ \s a → s { _hscUseTLS = a}+++defaultHttpServiceConfiguration ∷ HttpServiceConfiguration+defaultHttpServiceConfiguration = HttpServiceConfiguration+    { _hscHost = "localhost"+    , _hscPort = 80+    , _hscInterface = "0.0.0.0"+    , _hscUseTLS = Nothing+    }++instance FromJSON (HttpServiceConfiguration → HttpServiceConfiguration) where+    parseJSON = withObject "HttpServiceConfiguration" $ \o → pure id+        ⊙ hscHost ∘ bs ..: "host" × o+        ⊙ hscPort ..: "port" × o+        ⊙ hscInterface ∘ bs ..: "interface" × o+        ⊙ hscUseTLS %.: "use-tls" × o+      where+        bs ∷ Iso' B8.ByteString String+        bs = iso B8.unpack B8.pack++instance ToJSON HttpServiceConfiguration where+    toJSON HttpServiceConfiguration{..} = object+        [ "host" .= B8.unpack _hscHost+        , "port" .= _hscPort+        , "interface" .= B8.unpack _hscInterface+        , "use-tls" .= _hscUseTLS+        ]++pHttpServiceConfiguration ∷ String → MParser HttpServiceConfiguration+pHttpServiceConfiguration prefix = pure id+    ⊙ hscHost ∘ bs .:: strOption+        × long (prefix ⊕ "host")+        ⊕ help "Hostname of the service"+    ⊙ hscPort .:: option+        × long (prefix ⊕ "port")+        ⊕ help "Port of the service"+    ⊙ hscInterface ∘ bs .:: option+        × long (prefix ⊕ "interface")+        ⊕ help "Interface of the service"+    ⊙ (hscUseTLS %:: (fmap <$> pHttpServiceTLSConfiguration prefix))+  where+    bs ∷ Iso' B8.ByteString String+    bs = iso B8.unpack B8.pack++-- -------------------------------------------------------------------------- --+-- Http Client Configuration++data HttpClientConfiguration = HttpClientConfiguration+    { _hccHost ∷ !B8.ByteString+    , _hccPort ∷ !Int+    , _hccUseTLS ∷ !Bool+    }+    deriving (Show, Read, Eq, Ord)++hccHost ∷ Lens' HttpClientConfiguration B8.ByteString+hccHost = lens _hccHost $ \s a → s { _hccHost = a}++hccPort ∷ Lens' HttpClientConfiguration Int+hccPort = lens _hccPort $ \s a → s { _hccPort = a}++hccUseTLS ∷ Lens' HttpClientConfiguration Bool+hccUseTLS = lens _hccUseTLS $ \s a → s { _hccUseTLS = a}++defaultHttpClientConfiguration ∷ HttpClientConfiguration+defaultHttpClientConfiguration = HttpClientConfiguration+    { _hccHost = "localhost"+    , _hccPort = 80+    , _hccUseTLS = False+    }++instance FromJSON (HttpClientConfiguration → HttpClientConfiguration) where+    parseJSON = withObject "HttpClientConfiguration" $ \o → pure id+        ⊙ hccHost ∘ bs ..: "host" × o+        ⊙ hccPort ..: "port" × o+        ⊙ hccUseTLS ..: "use-tls" × o+      where+        bs ∷ Iso' B8.ByteString String+        bs = iso B8.unpack B8.pack++instance ToJSON HttpClientConfiguration where+    toJSON HttpClientConfiguration{..} = object+        [ "host" .= B8.unpack _hccHost+        , "port" .= _hccPort+        , "use-tls" .= _hccUseTLS+        ]++pHttpClientConfiguration ∷ String → MParser HttpClientConfiguration+pHttpClientConfiguration serviceName = pure id+    ⊙ hccHost ∘ bs .:: strOption+        × long (serviceName ⊕ "-host")+        ⊕ help ("Hostname of " ⊕ serviceName)+    ⊙ hccPort .:: option+        × long (serviceName ⊕ "-port")+        ⊕ help ("Port of " ⊕ serviceName)+    ⊙ hccUseTLS .:: switch+        × long (serviceName ⊕ "-use-tls")+        ⊕ help ("Connect to " ⊕ serviceName ⊕ " via TLS")+  where+    bs ∷ Iso' B8.ByteString String+    bs = iso B8.unpack B8.pack++httpService2clientConfiguration ∷ HttpServiceConfiguration → HttpClientConfiguration+httpService2clientConfiguration HttpServiceConfiguration{..} = HttpClientConfiguration+    { _hccHost = _hscHost+    , _hccPort = _hscPort+    , _hccUseTLS = isJust _hscUseTLS+    }+

@@ -0,0 +1,46 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Configuration.Utils.Internal+( lens+, over+, set+, Lens'+, Iso'+, iso+) where++import Data.Functor.Identity+import Data.Profunctor++-- -------------------------------------------------------------------------- --+-- Lenses++-- Just what we need of van Laarhoven Lenses+--+-- These few lines of code do safe us a lot of dependencies++-- | This is the same type as the type from the lens library with the same name.+--+type Lens' β α = Functor φ ⇒ (α → φ α) → β → φ β++lens ∷ Functor φ ⇒ (β → α) → (β → α → β) → (α → φ α) → β → φ β+lens getter setter lGetter s = setter s `fmap` lGetter (getter s)++over ∷ ((α → Identity α) → β → Identity β) → (α → α) → β → β+over s f = runIdentity . s (Identity . f)++set ∷ ((α → Identity α) → β → Identity β) → α → β → β+set s a = runIdentity . s (const $ Identity a)++-- | This is the same type as the type from the lens library with the same name.+--+type Iso' β α = (Profunctor π, Functor φ) ⇒ π α (φ α) → π β (φ β)++iso :: (β -> α) -> (α -> β) -> Iso' β α+iso f g = dimap f (fmap g)

@@ -0,0 +1,311 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-- | This module contains a @Setup.hs@ script that hooks into the cabal build+-- process at the end of the configuration phase and generates a module with+-- package information for each component of the cabal package.+--+-- The modules are created in the /autogen/ build directory where also the+-- @Path_@ module is created by cabal's simple build setup. This is usually the+-- directory @.\/dist\/build\/autogen@.+--+-- For a library component the module is named just @PkgInfo@. For all other+-- components the module is named @PkgInfo_COMPONENT_NAME@ where+-- @COMPONENT_NAME@ is the name of the component with @-@ characters replaced by+-- @_@.+--+-- For instance, if a cabal package contains a library and an executable that is+-- called /my-app/, the following modules are created: @PkgInfo@ and+-- @PkgInfo_my_app@.+--+--+-- = Usage as Setup Script+--+-- There are two ways how this module can be used:+--+-- 1. Copy the code of this module into a file called @Setup.hs@ in the root+--    directory of your package.+--+-- 2. If the /configuration-tools/ package is already installed in the system+--    where the build is done, following code can be used as @Setup.hs@ script:+--+--    > module Main (main) where+--    >+--    > import Configuration.Utils.Setup+--+-- With both methods the field @Build-Type@ in the package description (cabal) file+-- must be set to @Custom@:+--+-- > Build-Type: Custom+--+--+-- = Integration With "Configuration.Utils"+--+-- You can integrate the information provided by the @PkgInfo@ modules with the+-- command line interface of an application by importing the respective module+-- for the component and using the+-- 'Configuration.Utils.runWithPkgInfoConfiguration' function from the module+-- "Configuration.Utils" as show in the following example:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE FlexibleInstances #-}+-- >+-- > module Main+-- > ( main+-- > ) where+-- >+-- > import Configuration.Utils+-- > import PkgInfo+-- >+-- > instance FromJSON (() -> ()) where parseJSON _ = pure id+-- >+-- > mainInfo :: ProgramInfo ()+-- > mainInfo = programInfo "Hello World" (pure id) ()+-- >+-- > main :: IO ()+-- > main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world"+--+-- With that the resulting application supports the following additional command+-- line options:+--+-- [@--version@, @-v@]+--     prints the version of 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.+--     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.+--+module Configuration.Utils.Setup (main) where++import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.Setup+import qualified Distribution.InstalledPackageInfo as I+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.BuildPaths+import Distribution.Simple.PackageIndex+import Distribution.Text+import System.Process++import Control.Applicative+import Control.Monad++import qualified Data.ByteString as B+import Data.ByteString.Char8 (pack)+import Data.Char (isSpace)+import Data.List (intercalate)+import Data.Monoid++import Prelude hiding (readFile, writeFile)++import System.Directory (doesFileExist, doesDirectoryExist, createDirectoryIfMissing)+import System.Exit (ExitCode(ExitSuccess))++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+    { postConf = mkPkgInfoModules+    }+  where+    mkPkgInfoModules _ _ pkgDesc bInfo = mapM_ f . map (\(a,_,_) -> a) $ componentsConfigs bInfo+      where+        f cname = case cname of+            CLibName -> updatePkgInfoModule Nothing pkgDesc bInfo+            CExeName s -> updatePkgInfoModule (Just s) pkgDesc bInfo+            CTestName s -> updatePkgInfoModule (Just s) pkgDesc bInfo+            CBenchName s -> updatePkgInfoModule (Just s) pkgDesc bInfo++pkgInfoModuleName :: Maybe String -> String+pkgInfoModuleName Nothing = "PkgInfo"+pkgInfoModuleName (Just cn) = "PkgInfo_" ++ map tr cn+  where+    tr '-' = '_'+    tr c = c++pkgInfoFileName :: Maybe String -> LocalBuildInfo -> FilePath+pkgInfoFileName cn bInfo = autogenModulesDir bInfo ++ "/" ++ pkgInfoModuleName cn ++ ".hs"++trim :: String -> String+trim = f . f+  where f = reverse . dropWhile isSpace++getVCS :: IO (Maybe RepoType)+getVCS = do+    doesDirectoryExist ".hg" >>= \x0 -> if x0+    then return (Just Mercurial)+    else doesDirectoryExist ".git" >>= \x1 -> if x1+    then return (Just Git)+    else return Nothing++pkgInfoModule :: Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString+pkgInfoModule cName pkgDesc bInfo = do+    (tag, revision, branch) <- getVCS >>= \x -> case x of+        Just Mercurial -> hgInfo+        Just Git -> gitInfo+        _ -> noVcsInfo++    let vcsBranch = if branch == "default" || branch == "master" then "" else branch+        vcsVersion = intercalate "-" . filter (/= "") $ [tag, revision, vcsBranch]+        flags = map fst . filter snd . configConfigurationsFlags . configFlags $ bInfo++    licenseString <- licenseFilesText pkgDesc++    return $ B.intercalate "\n" $+            [ "{-# LANGUAGE OverloadedStrings #-}"+            , "{-# LANGUAGE RankNTypes #-}"+            , ""+            , "module " <> (pack . pkgInfoModuleName) cName <> " where"+            , ""+            , "    import Data.String (IsString)"+            , "    import Data.Monoid"+            , ""+            , "    name :: IsString a => Maybe a"+            , "    name = " <> maybe "Nothing" (\x -> "Just \"" <> pack x <> "\"") cName+            , ""+            , "    tag :: IsString a => a"+            , "    tag = \"" <> pack tag <> "\""+            , ""+            , "    revision :: IsString a => a"+            , "    revision = \"" <> pack revision <> "\""+            , ""+            , "    branch :: IsString a => a"+            , "    branch = \"" <> pack branch <> "\""+            , ""+            , "    branch' :: IsString a => a"+            , "    branch' = \"" <> pack vcsBranch <> "\""+            , ""+            , "    vcsVersion :: IsString a => a"+            , "    vcsVersion = \"" <> pack vcsVersion <> "\""+            , ""+            , "    compiler :: IsString a => a"+            , "    compiler = \"" <> (pack . display . compilerId . compiler) bInfo <> "\""+            , ""+            , "    flags :: IsString a => [a]"+            , "    flags = " <> (pack . show) flags+            , ""+            , "    arch :: IsString a => a"+            , "    arch = \"" <> (pack . display . hostPlatform) bInfo <> "\""+            , ""+            , "    license :: IsString a => a"+            , "    license = \"" <> (pack . display . license) pkgDesc <> "\""+            , ""+            , "    licenseText :: IsString a => a"+            , "    licenseText = " <> (pack . show) licenseString+            , ""+            , "    copyright :: IsString a => a"+            , "    copyright = \"" <> (pack . copyright) pkgDesc <> "\""+            , ""+            , "    author :: IsString a => a"+            , "    author = \"" <> (pack . author) pkgDesc <> "\""+            , ""+            , "    homepage :: IsString a => a"+            , "    homepage = \"" <> (pack . homepage) pkgDesc <> "\""+            , ""+            , "    package :: IsString a => a"+            , "    package = \"" <> (pack . display . package) pkgDesc <> "\""+            , ""+            , "    packageName :: IsString a => a"+            , "    packageName = \"" <> (pack . display . packageName) pkgDesc <> "\""+            , ""+            , "    packageVersion :: IsString a => a"+            , "    packageVersion = \"" <> (pack . display . packageVersion) pkgDesc <> "\""+            , ""+            , "    dependencies :: IsString a => [a]"+            , "    dependencies = " <> (pack . show . map (display . packageId) . allPackages . installedPkgs) bInfo+            , ""+            , "    dependenciesWithLicenses :: IsString a => [a]"+            , "    dependenciesWithLicenses = " <> (pack . show . map pkgIdWithLicense . allPackages . installedPkgs) bInfo+            , ""+            , "    versionString :: (Monoid a, IsString a) => a"+            , "    versionString = case name of"+            , "        Nothing -> package <> \" (revision \" <> vcsVersion <> \")\""+            , "        Just n -> n <> \"-\" <> packageVersion <> \" (package \" <> package <> \" revision \" <> vcsVersion <> \")\""+            , ""+            , "    info :: (Monoid a, IsString a) => a"+            , "    info = versionString <> \"\\n\" <> copyright"+            , ""+            , "    longInfo :: (Monoid a, IsString a) => a"+            , "    longInfo = info <> \"\\n\\n\""+            , "        <> \"Author: \" <> author <> \"\\n\""+            , "        <> \"License: \" <> license <> \"\\n\""+            , "        <> \"Homepage: \" <> homepage <> \"\\n\""+            , "        <> \"Build with: \" <> compiler <> \" (\" <> arch <> \")\" <> \"\\n\""+            , "        <> \"Build flags: \" <> mconcat (map (\\x -> \" \" <> x) flags) <> \"\\n\\n\""+            , "        <> \"Dependencies:\\n\" <> mconcat (map (\\x -> \"    \" <> x <> \"\\n\") dependenciesWithLicenses)"+            , ""+            , "    pkgInfo :: (Monoid a, IsString a) => (a, a, a, a)"+            , "    pkgInfo ="+            , "        ( info"+            , "        , longInfo"+            , "        , versionString"+            , "        , licenseText"+            , "        )"+            , ""+            ]++updatePkgInfoModule :: Maybe String -> PackageDescription -> LocalBuildInfo -> IO ()+updatePkgInfoModule cName pkgDesc bInfo = do+    createDirectoryIfMissing True $ autogenModulesDir bInfo+    newFile <- pkgInfoModule cName pkgDesc bInfo+    let update = B.writeFile fileName newFile+    doesFileExist fileName >>= \x -> if x+    then do+        oldRevisionFile <- B.readFile fileName+        when (oldRevisionFile /= newFile) update+    else+        update+  where+    fileName = pkgInfoFileName cName bInfo++licenseFilesText :: PackageDescription -> IO B.ByteString+licenseFilesText PackageDescription{ licenseFiles = fileNames } =+    B.intercalate "\n------------------------------------------------------------\n" <$> mapM fileText fileNames+  where+    fileText file = doesFileExist file >>= \x -> if x+        then B.readFile file+        else return ""++hgInfo :: IO (String, String, String)+hgInfo = do+    tag <- fmap trim $ readProcess "hg" ["id", "-r", "max(ancestors(\".\") and tag())", "-t"] ""+    rev <- fmap trim $ readProcess "hg" ["id", "-i"] ""+    branch <- fmap trim $ readProcess "hg" ["id", "-b"] ""+    return (tag, rev, branch)++gitInfo :: IO (String, String, String)+gitInfo = do+    tag <- do+        (exitCode, out, _err) <- readProcessWithExitCode "git" ["describe", "--exact-match", "--abbrev=0"] ""+        case exitCode of+            ExitSuccess -> return $ trim out+            _ -> return ""+    rev <- fmap trim $ readProcess "git" ["rev-parse", "--short", "HEAD"] ""+    branch <- fmap trim $ readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] ""+    return (tag, rev, branch)++noVcsInfo :: IO (String, String, String)+noVcsInfo = return ("", "", "")++pkgIdWithLicense :: I.InstalledPackageInfo -> String+pkgIdWithLicense a = (display . packageId) a+    ++ " ["+    ++ (display . I.license) a+    ++ (if cr /= "" then ", " ++ cr else "")+    ++ "]"+  where+    cr = (unwords . words . I.copyright) a+