diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +0.2.1 +===== + +* Fix build with GHC-7.6 by relaxing lower bounds on some dependencies. + +0.2 +=== + +First release. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +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 ] + 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 ] + 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 , Bas van Dijk ] + 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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 + diff --git a/configuration-tools.cabal b/configuration-tools.cabal new file mode 100644 --- /dev/null +++ b/configuration-tools.cabal @@ -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 + , + , and + 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 + + 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 +Maintainer: Lars Kuhtz +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 diff --git a/constraints b/constraints new file mode 100644 --- /dev/null +++ b/constraints @@ -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 diff --git a/examples/Example.hs b/examples/Example.hs new file mode 100644 --- /dev/null +++ b/examples/Example.hs @@ -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 diff --git a/examples/Trivial.hs b/examples/Trivial.hs new file mode 100644 --- /dev/null +++ b/examples/Trivial.hs @@ -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" + diff --git a/src/Configuration/Utils.hs b/src/Configuration/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Utils.hs @@ -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 >< × +-- +(×) ∷ (α → β) → α → β +(×) = ($) +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 ../ ⊙ +-- +(⊙) ∷ 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) + diff --git a/src/Configuration/Utils/Http.hs b/src/Configuration/Utils/Http.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Utils/Http.hs @@ -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 + } + diff --git a/src/Configuration/Utils/Internal.hs b/src/Configuration/Utils/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Utils/Internal.hs @@ -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) diff --git a/src/Configuration/Utils/Setup.hs b/src/Configuration/Utils/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Utils/Setup.hs @@ -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 +