├── .github └── workflows │ └── cabal-ci.yaml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── configuration-tools.cabal ├── examples ├── Example.hs └── Trivial.hs ├── src └── Configuration │ ├── Utils.hs │ └── Utils │ ├── CommandLine.hs │ ├── ConfigFile.hs │ ├── FromJsonWithDef.hs │ ├── Http.hs │ ├── Internal.hs │ ├── Internal │ ├── ConfigFileReader.hs │ ├── HttpsCertPolicy.hs │ └── JsonTools.hs │ ├── Maybe.hs │ ├── Monoid.hs │ ├── Operators.hs │ ├── Setup.hs │ └── Validation.hs ├── stack.yaml └── test ├── TestExample.hs ├── TestTools.hs └── Tests ├── BoolOption.hs └── MonoidConfig.hs /.github/workflows/cabal-ci.yaml: -------------------------------------------------------------------------------- 1 | name: Build with Cabal 2 | 3 | on: ['push'] 4 | 5 | jobs: 6 | 7 | build: 8 | name: Build 9 | runs-on: ${{ matrix.os }} 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | ghc: ['9.4', '9.6', '9.8', '9.10', '9.12'] 14 | cabal: ['latest'] 15 | os: ['ubuntu-22.04', 'ubuntu-24.04', 'macOS-latest'] 16 | remoteConfigs: ['-remote-configs', '+remote-configs'] 17 | include: 18 | - ghc: '9.6' 19 | cabal: '3.8' 20 | os: 'ubuntu-22.04' 21 | remoteConfigs: '-remote-configs' 22 | 23 | 24 | steps: 25 | 26 | # Setup 27 | - name: Checkout repository 28 | uses: actions/checkout@v4 29 | 30 | - name: Install GHC and Cabal 31 | uses: haskell-actions/setup@v2 32 | with: 33 | ghc-version: ${{ matrix.ghc }} 34 | cabal-version: ${{ matrix.cabal }} 35 | 36 | - name: Configure project 37 | run: | 38 | cat > cabal.project.local <=3.6. 16 | * Drop support for GHC <8.10. 17 | * Require optparse-applicative >=0.18. 18 | * Require prettyprinter package and drop dependency on deprecated ansi-wl-pprint. 19 | * Replace dependency on cryptonite package by crypton. 20 | * Raise some outdated lower dependency bounds. 21 | 22 | ## 0.6.1 (2021-10-12) 23 | 24 | * Support GHC-9.2 25 | * Support aeson >=2.0 26 | 27 | ## 0.6.0 (2021-02-16) 28 | 29 | #### New 30 | 31 | * The command line option `--print-config-as` was added, that takes the values 32 | `full`, `minimal`, and `diff` and print either the full configuration, a 33 | minimal configuration that contains only changes that are different from the 34 | default configuration, or it print a YAML document that shows the difference 35 | between the actual configuration and the default configuration. 36 | 37 | * The helper functions `jsonOption` and `jsonReader` for building command line 38 | parsers have been added. 39 | 40 | #### Removed 41 | 42 | * The function `fmapL` is removed from `Configuration.Utils.Internal`. Instead 43 | the function `first` from `Data.Bifunctor` from the `base` package can be 44 | used. 45 | 46 | ## 0.5.0 (2020-04-06) 47 | 48 | #### Changed 49 | 50 | - Support for GHC < 8.4 has been dropped. 51 | - Support for Cabal < 2.2 has been dropped. 52 | - Support for "Remote Configuration" has been turned off by default. It can be 53 | manually activated via the `remote-configs` flag. 54 | 55 | #### Removed 56 | 57 | - The previously deprecated `<.>` and `⊙` operators have been removed. Use `<.<` 58 | instead for either. 59 | 60 | #### Deprecated 61 | 62 | - The unicode `×` operator will be removed with the next major release. Use `%` 63 | instead. 64 | 65 | ## 0.4.2 (2020-01-25) 66 | 67 | * GHC 8.8 support. 68 | 69 | ## 0.4.1 (2019-05-10) 70 | 71 | * Added `pLeftSemigroupalUpdate` and `pRightSemigroupalUpdate`. 72 | 73 | ## 0.4.0 (2018-08-21) 74 | 75 | * Drop support for GHC < 7.10 and base < 4.8 76 | * Drop support for Cabal < 1.24 77 | * Drop support for transformers < 0.4 78 | * Don't run CI tests for Cabal < 2 79 | 80 | * With Cabal 2.0 or later package info modules are placed in per component 81 | `autogen` directories. All package info modules are named just `PkgInfo`. 82 | For backward compatibility modules with the old legacy names (`PkgInfo_*`) 83 | are still generated but marked deprecated. With Cabal 1.24 only the legacy 84 | behavior is available and a deprecation warning is raised. 85 | 86 | ## 0.3.1 (2018-03-16) 87 | 88 | * Support GHC-8.4.1 and Cabal-2.2 89 | * Replaced the use of non-ascii identifiers in the public API 90 | 91 | ## 0.3.0 92 | 93 | * Remove built in short options `-p`, `-c`, and `-i` 94 | * Support GHC-8.2 and Cabal-2.0 95 | 96 | ## 0.2.15 97 | 98 | * Support for http-client >= 0.5 99 | 100 | ## 0.2.14 101 | 102 | * Support for GHC-8 and Cabal-1.24 103 | 104 | ## 0.2.13 105 | 106 | * Eliminate most compiler warnings when compiling with GHC-7.10. 107 | 108 | * Bump lower bound on the version of `optparse-applicative` to `0.11.0.2`. 109 | This avoids issues when building with `transformers-compat`. 110 | 111 | * Reduce compilation time with `text<1.2.0.5` by avoiding usage of `toCaseFold` 112 | from the `case-insensitive` package. 113 | 114 | * Dropped dependency on the error package. 115 | 116 | * [Issue 43](https://github.com/alephcloud/hs-configuration-tools/issues/43): 117 | Support detection of the version control system when the package directory 118 | and thus the cabal file is in sub-directory of the repository. 119 | 120 | ## 0.2.12 121 | 122 | * Added support for transformers-0.3.0.0. This changes allows usage 123 | of configuration-tools along with packages that depend on ghc, which 124 | in turn depends on transformers-0.3.0.0. 125 | 126 | ## 0.2.11 127 | 128 | * Added support for Cabal-1.18. This is supposed to make the build more 129 | robust and simplify integration with existing build infrastructure 130 | and other packages. 131 | 132 | ## 0.2.10 133 | 134 | * Moved all internal APIs to the `Internal` name space. Exposing them 135 | in 0.2.9 was considered a bug. 136 | 137 | * Configuration files can be formatted either as JSON or as YAML. 138 | For remote configuration files the HTTP `Content-Type` header is used to 139 | determine the format, for local files the file suffix is used. 140 | The default format is YAML. 141 | 142 | * Set the HTTP `accept` header for JSON and YAML when requesting remote 143 | configuration files. 144 | 145 | ## 0.2.9 146 | 147 | * Use tight constraint for all validation functions. Previously the 148 | constraint where unnecessarily restrictive. 149 | 150 | * Added `updateProperty` function that generalized `%.:` in the same 151 | way as `setProperty` generalizes `..:`. 152 | 153 | * Added a validation function for configuration file arguments. 154 | 155 | * Allow usage of more than a single `--config-file` option on the 156 | command line. 157 | 158 | * Support for static configuration file locations. Configuration files 159 | can be marked as `required` or `optional`. 160 | 161 | * Support for loading of configuration files form HTTP and HTTPS URLs. 162 | There are new flags for disabling validation of SSL certificates and 163 | white listing SSL certificates based on their fingerprint. 164 | 165 | * Added tools for updating configurations with a monoid instance. 166 | 167 | * Added two new option parsers for boolean flags. 168 | 169 | * The `boolOption_` parser uses the syntax `--feature` and 170 | `--no-feature` to enable and respectively disable a feature. 171 | 172 | * The `enableDisableFlag` parser uses the syntax `--enable-feature` 173 | and `--disable-feature` to enable and respectively disable a feature. 174 | 175 | * Refactored the module layout. The API of the existing modules is 176 | is backward compatible, but a lot of code got moved into submodules. 177 | 178 | * Improved documentation. 179 | 180 | * Improved test suite. 181 | 182 | ## 0.2.8 183 | 184 | * Added validation functions for Boolean values, numeric values and 185 | orders. 186 | 187 | * Added operator `!..:` for parsing of configuration values that are 188 | required to be present in a configuration file, thus preventing 189 | the default value from being used. 190 | 191 | * More consistent usage of case in metavar values. 192 | 193 | * Drop support for optparse-applicative < 0.10. 194 | 195 | ## 0.2.7 196 | 197 | * Added `view` function for lenses to `Configuration.Utils.Internal`. 198 | 199 | * Added support for validation of configuration values. 200 | 201 | * Added module `Configuration.Utils.Validation` that provides primitives 202 | for validating different basic configuration values. 203 | 204 | ## 0.2.6 205 | 206 | * For git repositories include also light-weight (non-annotated) tags 207 | in the version description. 208 | 209 | * Added new function `boolReader`, `boolOption`, `fileOption`, and 210 | `eitherReadP` to `Utils`. 211 | 212 | * Added new function `maybeOption` and improved documentation about 213 | `Maybe` config values. 214 | 215 | * Included optimisation level into long info. 216 | 217 | ## 0.2.5 218 | 219 | * `Configuration.Utils.Setup`: export `mkPkgInfoModules` function 220 | that modifies a given `UserHooks` record to generate an `PkgInfo` 221 | module during configuration. 222 | 223 | ## 0.2.4.1 224 | 225 | * Support for optparse-applicative >= 0.10. 226 | 227 | ## 0.2.4 228 | 229 | * Configuration.Utils.Setup: fixed generation of `PkgInfo` module for 230 | package configurations with explicit flags. 231 | 232 | * Improved documentation for `Maybe` values. 233 | 234 | ## 0.2.3 235 | 236 | * Show the help options in the options summary message. 237 | 238 | * Add `-?` as short version of for `--help` in addition to `-h`. 239 | 240 | * Remove `showHelpOnError` and `disambiguate` from option parser preferences. 241 | 242 | * Added file `INSTALL_ON_WINDOWS.md` with installation instructions for 243 | windows to the package. 244 | 245 | ## 0.2.2 246 | 247 | * Add Lens `piOptionParserAndDefaultConfiguration` that gives simultaneous 248 | accesses to `piOptionParser` and `piDefaultConfiguration` which allows 249 | changing the type parameter of `ProgramInfo a`. 250 | 251 | * Introduce function `setProperty`. It is used as the `..:` operator 252 | but allows to specify a custom parser for the property value instead 253 | of the default `parseJSON` from the `FromJSON` instance. 254 | 255 | * Introduce operators `(<*<)`, `(>*>)`, `(<$<)`, `(>$>)` and deprecate 256 | `(⊙)` and `(<.>)`. 257 | 258 | ## 0.2.1 259 | 260 | * Fix build with GHC-7.6 by relaxing lower bounds on some dependencies. 261 | 262 | ## 0.2 263 | 264 | First release. 265 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 AlephCloud Systems, Inc. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------------------ -- 2 | -- Copyright © 2019 Colin Woodbury 3 | -- Copyright © 2015-2020 Lars Kuhtz 4 | -- Copyright © 2014 AlephCloud Systems, Inc. 5 | -- ------------------------------------------------------ -- 6 | 7 | {-# LANGUAGE CPP #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE MultiWayIf #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | 13 | {-# OPTIONS_HADDOCK show-extensions #-} 14 | 15 | -- | This module contains a @Setup.hs@ script that hooks into the cabal build 16 | -- process at the end of the configuration phase and generates a module with 17 | -- package information for each component of the cabal package. 18 | -- 19 | -- The modules are created in the /autogen/ build directories where also the 20 | -- @Path_@ modules are created by cabal's simple build setup. 21 | -- 22 | -- = Usage as Setup Script 23 | -- 24 | -- There are three ways how this module can be used: 25 | -- 26 | -- 1. Copy the code of this module into a file called @Setup.hs@ in the root 27 | -- directory of your package. 28 | -- 29 | -- 2. If the /configuration-tools/ package is already installed in the system 30 | -- where the build is done, following code can be used as @Setup.hs@ script: 31 | -- 32 | -- > module Main (main) where 33 | -- > 34 | -- > import Configuration.Utils.Setup 35 | -- 36 | -- 3. For usage within a more complex @Setup.hs@ script you shall import this 37 | -- module qualified and use the 'mkPkgInfoModules' function. For example: 38 | -- 39 | -- > module Main (main) where 40 | -- > 41 | -- > import qualified Configuration.Utils.Setup as ConfTools 42 | -- > 43 | -- > main :: IO () 44 | -- > main = defaultMainWithHooks (ConfTools.mkPkgInfoModules simpleUserHooks) 45 | -- > 46 | -- 47 | -- With all methods the field @Build-Type@ in the package description (cabal) file 48 | -- must be set to @Custom@: 49 | -- 50 | -- > Build-Type: Custom 51 | -- 52 | -- 53 | -- = Integration With "Configuration.Utils" 54 | -- 55 | -- You can integrate the information provided by the @PkgInfo@ modules with the 56 | -- command line interface of an application by importing the respective module 57 | -- for the component and using the 58 | -- 'Configuration.Utils.runWithPkgInfoConfiguration' function from the module 59 | -- "Configuration.Utils" as show in the following example: 60 | -- 61 | -- > {-# LANGUAGE OverloadedStrings #-} 62 | -- > {-# LANGUAGE FlexibleInstances #-} 63 | -- > 64 | -- > module Main 65 | -- > ( main 66 | -- > ) where 67 | -- > 68 | -- > import Configuration.Utils 69 | -- > import PkgInfo 70 | -- > 71 | -- > instance FromJSON (() -> ()) where parseJSON _ = pure id 72 | -- > 73 | -- > mainInfo :: ProgramInfo () 74 | -- > mainInfo = programInfo "Hello World" (pure id) () 75 | -- > 76 | -- > main :: IO () 77 | -- > main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world" 78 | -- 79 | -- With that the resulting application supports the following additional command 80 | -- line options: 81 | -- 82 | -- [@--version@, @-v@] 83 | -- prints the version of the application and exits. 84 | -- 85 | -- [@--info@, @-i@] 86 | -- prints a short info message for the application and exits. 87 | -- 88 | -- [@--long-info@] 89 | -- print a detailed info message for the application and exits. 90 | -- Beside component name, package name, version, revision, and copyright 91 | -- the message also contain information about the compiler that 92 | -- was used for the build, the build architecture, build flags, 93 | -- the author, the license type, and a list of all direct and 94 | -- indirect dependencies along with their licenses and copyrights. 95 | -- 96 | -- [@--license@] 97 | -- prints the text of the lincense of the application and exits. 98 | -- 99 | module Main 100 | ( main 101 | , mkPkgInfoModules 102 | ) where 103 | 104 | import qualified Distribution.Compat.Graph as Graph 105 | import qualified Distribution.InstalledPackageInfo as I 106 | import Distribution.PackageDescription 107 | import Distribution.Pretty 108 | import Distribution.Simple 109 | import Distribution.Simple.BuildPaths 110 | import Distribution.Simple.LocalBuildInfo 111 | import Distribution.Simple.PackageIndex 112 | import Distribution.Simple.Setup 113 | import Distribution.Simple.Utils (createDirectoryIfMissingVerbose) 114 | import Distribution.Text 115 | import Distribution.Utils.Path 116 | import Distribution.Utils.ShortText 117 | 118 | import System.Process 119 | 120 | import Control.Applicative 121 | import Control.Monad 122 | 123 | import qualified Data.ByteString as B 124 | import Data.ByteString.Char8 (pack) 125 | import Data.Char (isSpace) 126 | import Data.List (intercalate) 127 | import Data.Monoid 128 | 129 | import Prelude hiding (readFile, writeFile) 130 | 131 | import System.Directory 132 | ( canonicalizePath 133 | , doesDirectoryExist 134 | , doesFileExist 135 | , getCurrentDirectory 136 | ) 137 | import System.Exit (ExitCode(ExitSuccess)) 138 | #if MIN_VERSION_Cabal(3,14,0) 139 | import System.FilePath (isDrive, takeDirectory) 140 | #else 141 | import System.FilePath (isDrive, takeDirectory, ()) 142 | #endif 143 | 144 | -- | Include this function when your setup doesn't contain any 145 | -- extra functionality. 146 | -- 147 | main :: IO () 148 | main = defaultMainWithHooks (mkPkgInfoModules simpleUserHooks) 149 | 150 | -- | Modifies the given record of hooks by adding functionality that 151 | -- creates a package info module for each component of the cabal package. 152 | -- 153 | -- This function is intended for usage in more complex @Setup.hs@ scripts. 154 | -- If your setup doesn't contain any other function you can just import 155 | -- the 'main' function from this module. 156 | -- 157 | -- The modules are created in the /autogen/ build directories where also the 158 | -- @Path_@ modules are created by cabal's simple build setup. 159 | -- 160 | mkPkgInfoModules 161 | :: UserHooks 162 | -> UserHooks 163 | mkPkgInfoModules hooks = hooks 164 | { postConf = mkPkgInfoModulesPostConf (postConf hooks) 165 | } 166 | 167 | -- -------------------------------------------------------------------------- -- 168 | -- Compat Implementations 169 | 170 | prettyLicense :: I.InstalledPackageInfo -> String 171 | prettyLicense = either prettyShow prettyShow . I.license 172 | 173 | #if !MIN_VERSION_Cabal(3,14,0) 174 | interpretSymbolicPath :: Maybe () -> FilePath -> FilePath 175 | interpretSymbolicPath _ p = p 176 | #endif 177 | 178 | -- -------------------------------------------------------------------------- -- 179 | -- Cabal 2.0 180 | 181 | mkPkgInfoModulesPostConf 182 | :: (Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()) 183 | -> Args 184 | -> ConfigFlags 185 | -> PackageDescription 186 | -> LocalBuildInfo 187 | -> IO () 188 | mkPkgInfoModulesPostConf hook args flags pkgDesc bInfo = do 189 | mapM_ (updatePkgInfoModule pkgDesc bInfo flags) $ Graph.toList $ componentGraph bInfo 190 | hook args flags pkgDesc bInfo 191 | 192 | updatePkgInfoModule 193 | :: PackageDescription 194 | -> LocalBuildInfo 195 | -> ConfigFlags 196 | -> ComponentLocalBuildInfo 197 | -> IO () 198 | updatePkgInfoModule pkgDesc bInfo flags clbInfo = do 199 | createDirectoryIfMissingVerbose verbosity True dirName 200 | moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo 201 | updateFile fileName moduleBytes 202 | 203 | -- legacy module 204 | legacyModuleBytes <- pkgInfoModule legacyModuleName cName pkgDesc bInfo 205 | updateFile legacyFileName legacyModuleBytes 206 | where 207 | verbosity = fromFlag $ configVerbosity flags 208 | dirName = interpretSymbolicPath Nothing $ autogenComponentModulesDir bInfo clbInfo 209 | cName = unUnqualComponentName <$> componentNameString (componentLocalName clbInfo) 210 | moduleName = pkgInfoModuleName 211 | fileName = dirName moduleName <> ".hs" 212 | legacyModuleName = legacyPkgInfoModuleName cName 213 | legacyFileName = dirName legacyModuleName <> ".hs" 214 | 215 | -- -------------------------------------------------------------------------- -- 216 | -- Generate PkgInfo Module 217 | 218 | pkgInfoModuleName :: String 219 | pkgInfoModuleName = "PkgInfo" 220 | 221 | updateFile :: FilePath -> B.ByteString -> IO () 222 | updateFile fileName content = do 223 | x <- doesFileExist fileName 224 | if | not x -> update 225 | | otherwise -> do 226 | oldRevisionFile <- B.readFile fileName 227 | when (oldRevisionFile /= content) update 228 | where 229 | update = B.writeFile fileName content 230 | 231 | legacyPkgInfoModuleName :: Maybe String -> String 232 | legacyPkgInfoModuleName Nothing = "PkgInfo" 233 | legacyPkgInfoModuleName (Just cn) = "PkgInfo_" <> map tr cn 234 | where 235 | tr '-' = '_' 236 | tr c = c 237 | 238 | trim :: String -> String 239 | trim = f . f 240 | where f = reverse . dropWhile isSpace 241 | 242 | getVCS :: IO (Maybe KnownRepoType) 243 | getVCS = getCurrentDirectory >>= getVcsOfDir 244 | where 245 | getVcsOfDir d = do 246 | canonicDir <- canonicalizePath d 247 | doesDirectoryExist (canonicDir ".hg") >>= \x0 -> if x0 248 | then return (Just Mercurial) 249 | else doesDirectoryExist (canonicDir ".git") >>= \x1 -> if x1 250 | then return $ Just Git 251 | else if isDrive canonicDir 252 | then return Nothing 253 | else getVcsOfDir (takeDirectory canonicDir) 254 | 255 | pkgInfoModule 256 | :: String 257 | -> Maybe String 258 | -> PackageDescription 259 | -> LocalBuildInfo 260 | -> IO B.ByteString 261 | pkgInfoModule moduleName cName pkgDesc bInfo = do 262 | (tag, revision, branch) <- getVCS >>= \case 263 | Just Mercurial -> hgInfo 264 | Just Git -> gitInfo 265 | _ -> noVcsInfo 266 | 267 | let vcsBranch = if branch == "default" || branch == "master" then "" else branch 268 | vcsVersion = intercalate "-" . filter (/= "") $ [tag, revision, vcsBranch] 269 | flags = map (unFlagName . fst) . filter snd . unFlagAssignment . configConfigurationsFlags . configFlags $ bInfo 270 | 271 | licenseString <- licenseFilesText pkgDesc 272 | 273 | return $ B.intercalate "\n" 274 | [ "{-# LANGUAGE OverloadedStrings #-}" 275 | , "{-# LANGUAGE RankNTypes #-}" 276 | , "" 277 | , "module " <> pack moduleName <> " " <> deprecatedMsg <> " where" 278 | , "" 279 | , " import Data.String (IsString)" 280 | , " import Data.Monoid" 281 | , " import Prelude hiding ((<>))" 282 | , "" 283 | , " name :: IsString a => Maybe a" 284 | , " name = " <> maybe "Nothing" (\x -> "Just \"" <> pack x <> "\"") cName 285 | , "" 286 | , " tag :: IsString a => a" 287 | , " tag = \"" <> pack tag <> "\"" 288 | , "" 289 | , " revision :: IsString a => a" 290 | , " revision = \"" <> pack revision <> "\"" 291 | , "" 292 | , " branch :: IsString a => a" 293 | , " branch = \"" <> pack branch <> "\"" 294 | , "" 295 | , " branch' :: IsString a => a" 296 | , " branch' = \"" <> pack vcsBranch <> "\"" 297 | , "" 298 | , " vcsVersion :: IsString a => a" 299 | , " vcsVersion = \"" <> pack vcsVersion <> "\"" 300 | , "" 301 | , " compiler :: IsString a => a" 302 | , " compiler = \"" <> (pack . display . compilerId . compiler) bInfo <> "\"" 303 | , "" 304 | , " flags :: IsString a => [a]" 305 | , " flags = " <> (pack . show) flags 306 | , "" 307 | , " optimisation :: IsString a => a" 308 | , " optimisation = \"" <> (displayOptimisationLevel . withOptimization) bInfo <> "\"" 309 | , "" 310 | , " arch :: IsString a => a" 311 | , " arch = \"" <> (pack . display . hostPlatform) bInfo <> "\"" 312 | , "" 313 | , " license :: IsString a => a" 314 | , " license = \"" <> (pack . prettyShow . license) pkgDesc <> "\"" 315 | , "" 316 | , " licenseText :: IsString a => a" 317 | , " licenseText = " <> (pack . show) licenseString 318 | , "" 319 | , " copyright :: IsString a => a" 320 | , " copyright = " <> (pack . show . copyright) pkgDesc 321 | , "" 322 | , " author :: IsString a => a" 323 | , " author = \"" <> (pack . fromShortText . author) pkgDesc <> "\"" 324 | , "" 325 | , " homepage :: IsString a => a" 326 | , " homepage = \"" <> (pack . fromShortText . homepage) pkgDesc <> "\"" 327 | , "" 328 | , " package :: IsString a => a" 329 | , " package = \"" <> (pack . display . package) pkgDesc <> "\"" 330 | , "" 331 | , " packageName :: IsString a => a" 332 | , " packageName = \"" <> (pack . display . packageName) pkgDesc <> "\"" 333 | , "" 334 | , " packageVersion :: IsString a => a" 335 | , " packageVersion = \"" <> (pack . display . packageVersion) pkgDesc <> "\"" 336 | , "" 337 | , " dependencies :: IsString a => [a]" 338 | , " dependencies = " <> (pack . show . map (display . packageId) . allPackages . installedPkgs) bInfo 339 | , "" 340 | , " dependenciesWithLicenses :: IsString a => [a]" 341 | , " dependenciesWithLicenses = " <> (pack . show . map pkgIdWithLicense . allPackages . installedPkgs) bInfo 342 | , "" 343 | , " versionString :: (Monoid a, IsString a) => a" 344 | , " versionString = case name of" 345 | , " Nothing -> package <> \" (revision \" <> vcsVersion <> \")\"" 346 | , " Just n -> n <> \"-\" <> packageVersion <> \" (package \" <> package <> \" revision \" <> vcsVersion <> \")\"" 347 | , "" 348 | , " info :: (Monoid a, IsString a) => a" 349 | , " info = versionString <> \"\\n\" <> copyright" 350 | , "" 351 | , " longInfo :: (Monoid a, IsString a) => a" 352 | , " longInfo = info <> \"\\n\\n\"" 353 | , " <> \"Author: \" <> author <> \"\\n\"" 354 | , " <> \"License: \" <> license <> \"\\n\"" 355 | , " <> \"Homepage: \" <> homepage <> \"\\n\"" 356 | , " <> \"Build with: \" <> compiler <> \" (\" <> arch <> \")\" <> \"\\n\"" 357 | , " <> \"Build flags: \" <> mconcat (map (\\x -> \" \" <> x) flags) <> \"\\n\"" 358 | , " <> \"Optimisation: \" <> optimisation <> \"\\n\\n\"" 359 | , " <> \"Dependencies:\\n\" <> mconcat (map (\\x -> \" \" <> x <> \"\\n\") dependenciesWithLicenses)" 360 | , "" 361 | , " pkgInfo :: (Monoid a, IsString a) => (a, a, a, a)" 362 | , " pkgInfo =" 363 | , " ( info" 364 | , " , longInfo" 365 | , " , versionString" 366 | , " , licenseText" 367 | , " )" 368 | , "" 369 | ] 370 | where 371 | displayOptimisationLevel NoOptimisation = "none" 372 | displayOptimisationLevel NormalOptimisation = "normal" 373 | displayOptimisationLevel MaximumOptimisation = "maximum" 374 | 375 | deprecatedMsg = if moduleName /= pkgInfoModuleName 376 | then "{-# DEPRECATED \"Update to Cabal 2.0 or later and use just PkgInfo as module name.\" #-}" 377 | else "" 378 | 379 | licenseFilesText :: PackageDescription -> IO B.ByteString 380 | licenseFilesText pkgDesc = 381 | B.intercalate "\n------------------------------------------------------------\n" <$> mapM fileTextStr 382 | (licenseFiles pkgDesc) 383 | where 384 | fileText file = doesFileExist file >>= \x -> if x 385 | then B.readFile file 386 | else return "" 387 | fileTextStr = fileText . getSymbolicPath 388 | 389 | 390 | hgInfo :: IO (String, String, String) 391 | hgInfo = do 392 | tag <- trim <$> readProcess "hg" ["id", "-r", "max(ancestors(\".\") and tag())", "-t"] "" 393 | rev <- trim <$> readProcess "hg" ["id", "-i"] "" 394 | branch <- trim <$> readProcess "hg" ["id", "-b"] "" 395 | return (tag, rev, branch) 396 | 397 | gitInfo :: IO (String, String, String) 398 | gitInfo = do 399 | tag <- do 400 | (exitCode, out, _err) <- readProcessWithExitCode "git" ["describe", "--exact-match", "--tags", "--abbrev=0"] "" 401 | case exitCode of 402 | ExitSuccess -> return $ trim out 403 | _ -> return "" 404 | rev <- trim <$> readProcess "git" ["rev-parse", "--short", "HEAD"] "" 405 | branch <- trim <$> readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "" 406 | return (tag, rev, branch) 407 | 408 | noVcsInfo :: IO (String, String, String) 409 | noVcsInfo = return ("", "", "") 410 | 411 | pkgIdWithLicense :: I.InstalledPackageInfo -> String 412 | pkgIdWithLicense a = (display . packageId) a 413 | ++ " [" 414 | ++ prettyLicense a 415 | ++ (if cr /= "" then ", " ++ cr else "") 416 | ++ "]" 417 | where 418 | cr = (unwords . words . fromShortText . I.copyright) a 419 | -------------------------------------------------------------------------------- /configuration-tools.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | name: configuration-tools 4 | version: 0.7.1 5 | synopsis: Tools for specifying and parsing configurations 6 | description: 7 | Tools for specifying and parsing configurations 8 | 9 | This package provides a collection of utils on top of the packages 10 | , 11 | , and 12 | for configuring libraries and 13 | applications in a convenient and composable way. 14 | 15 | The main features are 16 | 17 | 1. configuration management through integration of command line option 18 | parsing and configuration files and 19 | 20 | 2. a @Setup.hs@ file that generates a @PkgInfo@ module for each component 21 | of a package that provides information about the package and the build. 22 | 23 | Documentation on how to use this package can be found in the 24 | 25 | and in the API documentation of the modules "Configuration.Utils" and 26 | "Configuration.Utils.Setup". 27 | 28 | homepage: https://github.com/alephcloud/hs-configuration-tools 29 | bug-reports: https://github.com/alephcloud/hs-configuration-tools/issues 30 | license: MIT 31 | license-file: LICENSE 32 | author: Lars Kuhtz 33 | maintainer: Lars Kuhtz , Edmund Noble 34 | copyright: 35 | (c) 2024-2025 Edmund Noble , 36 | (c) 2019-2020 Colin Woodbury , 37 | (c) 2015-2025 Lars Kuhtz , 38 | (c) 2014-2015 AlephCloud, Inc. 39 | category: Configuration, Console 40 | build-type: Custom 41 | tested-with: 42 | , GHC==9.12 43 | , GHC==9.10 44 | , GHC==9.8 45 | , GHC==9.6 46 | , GHC==9.4 47 | 48 | extra-doc-files: 49 | README.md, 50 | CHANGELOG.md 51 | 52 | custom-setup 53 | setup-depends: 54 | Cabal >= 3.6 && < 100, 55 | base >= 4.14 && < 5.0, 56 | bytestring >= 0.10.0.2, 57 | directory >= 1.2.1.0, 58 | filepath >= 1.3.0.1, 59 | process >= 1.2.0.0 60 | 61 | source-repository head 62 | type: git 63 | location: https://github.com/alephcloud/hs-configuration-tools.git 64 | branch: master 65 | 66 | flag remote-configs 67 | Description: enable loading of configuration files from HTTP URLs 68 | Default: False 69 | Manual: True 70 | 71 | library 72 | hs-source-dirs: src 73 | default-language: Haskell2010 74 | ghc-options: -Wall 75 | 76 | exposed-modules: 77 | Configuration.Utils 78 | Configuration.Utils.CommandLine 79 | Configuration.Utils.ConfigFile 80 | Configuration.Utils.Http 81 | Configuration.Utils.Internal 82 | Configuration.Utils.Internal.JsonTools 83 | Configuration.Utils.Internal.ConfigFileReader 84 | Configuration.Utils.Maybe 85 | Configuration.Utils.Monoid 86 | Configuration.Utils.Operators 87 | Configuration.Utils.Setup 88 | Configuration.Utils.Validation 89 | 90 | other-modules: 91 | PkgInfo 92 | 93 | autogen-modules: 94 | PkgInfo 95 | 96 | if flag(remote-configs) 97 | exposed-modules: 98 | Configuration.Utils.Internal.HttpsCertPolicy 99 | 100 | build-depends: 101 | Cabal >= 3.6 102 | , aeson >= 0.7.0.6 103 | , prettyprinter >= 1.7 104 | , attoparsec >= 0.11.3.4 105 | , base >= 4.14 && < 5 106 | , base-unicode-symbols >= 0.2.2.4 107 | , bytestring >= 0.10.0.2 108 | , case-insensitive >= 1.2 109 | , deepseq >= 1.3 110 | , directory >= 1.2.1.0 111 | , dlist >= 0.7.1 112 | , filepath >= 1.3.0.1 113 | , mtl >= 2.2 114 | , network-uri >= 2.6.0.1 115 | , optparse-applicative >= 0.18 116 | , process >= 1.2.0.0 117 | , profunctors >= 4.0.4 118 | , semigroups >= 0.18 119 | , semigroupoids >= 5.0 120 | , text >= 1.0 121 | , transformers >= 0.4 122 | , unordered-containers >= 0.2.4.0 123 | , vector >= 0.12 124 | , yaml >= 0.8.8.3 125 | 126 | if flag(remote-configs) 127 | build-depends: 128 | base64-bytestring >= 1.0 129 | , crypton-connection >= 0.3 130 | , crypton-x509 >= 1.5 131 | , crypton-x509-system >= 1.5 132 | , crypton-x509-validation >= 1.5.1 133 | , data-default >= 0.5 134 | , enclosed-exceptions >= 1.0 135 | , http-client >= 0.5 136 | , http-client-tls >= 0.3 137 | , http-types >= 0.8 138 | , monad-control >= 1.0 139 | , tls >= 1.2 140 | 141 | if flag(remote-configs) 142 | cpp-options: -DREMOTE_CONFIGS 143 | 144 | test-suite url-example-test 145 | default-language: Haskell2010 146 | ghc-options: -Wall 147 | type: exitcode-stdio-1.0 148 | main-is: TestExample.hs 149 | hs-source-dirs: examples, test 150 | 151 | other-modules: 152 | Example 153 | TestTools 154 | Tests.BoolOption 155 | Tests.MonoidConfig 156 | PkgInfo 157 | 158 | autogen-modules: 159 | PkgInfo 160 | 161 | build-depends: 162 | Cabal >= 3.6 163 | , base >= 4.14 && < 5 164 | , base-unicode-symbols >= 0.2.2.4 165 | , bytestring >= 0.10 166 | , configuration-tools 167 | , mtl >= 2.2 168 | , text >= 1.0 169 | , transformers >= 0.4 170 | , unordered-containers >= 0.2.4.0 171 | , yaml >= 0.8.8.3 172 | 173 | if flag(remote-configs) 174 | build-depends: 175 | enclosed-exceptions >= 1.0 176 | , http-types >= 0.8 177 | , monad-control >= 1.0 178 | , wai >= 3.2 179 | , warp >= 3.3 180 | , warp-tls >= 3.4 181 | , network >= 2.8 182 | 183 | cpp-options: -DREMOTE_CONFIGS 184 | 185 | test-suite trivial 186 | default-language: Haskell2010 187 | ghc-options: -Wall 188 | type: exitcode-stdio-1.0 189 | main-is: Trivial.hs 190 | hs-source-dirs: examples 191 | 192 | other-modules: 193 | PkgInfo 194 | 195 | autogen-modules: 196 | PkgInfo 197 | 198 | build-depends: 199 | base >= 4.14 && < 5 200 | , base-unicode-symbols >= 0.2.2.4 201 | , Cabal >= 3.6 202 | , configuration-tools 203 | 204 | executable example 205 | default-language: Haskell2010 206 | ghc-options: -Wall 207 | main-is: Example.hs 208 | ghc-options: -main-is Example 209 | hs-source-dirs: examples 210 | other-modules: 211 | PkgInfo 212 | autogen-modules: 213 | PkgInfo 214 | build-depends: 215 | base >= 4.14 && < 5 216 | , base-unicode-symbols >= 0.2.2.4 217 | , Cabal >= 3.6 218 | , configuration-tools 219 | , mtl >= 2.2 220 | -------------------------------------------------------------------------------- /examples/Example.hs: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------------------ -- 2 | -- Copyright © 2014 AlephCloud Systems, Inc. 3 | -- ------------------------------------------------------ -- 4 | 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE UnicodeSyntax #-} 10 | 11 | module Example 12 | ( 13 | -- * Authentication 14 | Auth(..) 15 | , user 16 | , pwd 17 | , defaultAuth 18 | , validateAuth 19 | , pAuth 20 | 21 | -- * Http URL 22 | , HttpURL(..) 23 | , auth 24 | , domain 25 | , path 26 | , defaultHttpURL 27 | , validateHttpURL 28 | , pHttpURL 29 | 30 | -- * main functions 31 | , main 32 | , main_ 33 | ) where 34 | 35 | import Configuration.Utils 36 | 37 | import Control.Monad 38 | import Control.Monad.Except 39 | import Control.Monad.Writer 40 | 41 | import Data.Monoid.Unicode 42 | 43 | import Prelude.Unicode hiding ((×)) 44 | 45 | -- This assumes usage of cabal with custom Setup.hs 46 | -- 47 | import PkgInfo 48 | 49 | -- | Specification of the authentication section of a URL. 50 | -- 51 | data Auth = Auth 52 | { _user ∷ !String 53 | , _pwd ∷ !String 54 | } 55 | 56 | -- Define Lenses. 57 | -- 58 | -- (alternatively we could have used TemplateHaskell along with 59 | -- 'makeLenses' from "Control.Lens" from the lens package.) 60 | 61 | user ∷ Functor f ⇒ (String → f String) → Auth → f Auth 62 | user f s = (\u → s { _user = u }) <$> f (_user s) 63 | 64 | pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth 65 | pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s) 66 | 67 | defaultAuth ∷ Auth 68 | defaultAuth = Auth 69 | { _user = "" 70 | , _pwd = "" 71 | } 72 | 73 | validateAuth ∷ ConfigValidation Auth [] 74 | validateAuth conf = 75 | when (_user conf ≠ "" && _pwd conf ≡ "") $ tell ["password is empty"] 76 | 77 | instance FromJSON (Auth → Auth) where 78 | parseJSON = withObject "Auth" $ \o → id 79 | <$< user ..: "user" % o 80 | <*< pwd ..: "pwd" % o 81 | 82 | instance ToJSON Auth where 83 | toJSON a = object 84 | [ "user" .= _user a 85 | , "pwd" .= _pwd a 86 | ] 87 | 88 | pAuth ∷ MParser Auth 89 | pAuth = id 90 | <$< user .:: strOption 91 | % long "user" 92 | ⊕ help "user name" 93 | <*< pwd .:: strOption 94 | % long "pwd" 95 | ⊕ help "password for user" 96 | 97 | -- | Simplified specification of an HTTP URL 98 | -- 99 | data HttpURL = HttpURL 100 | { _auth ∷ !Auth 101 | , _domain ∷ !String 102 | , _path ∷ !String 103 | } 104 | 105 | auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL 106 | auth f s = (\u → s { _auth = u }) <$> f (_auth s) 107 | 108 | domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL 109 | domain f s = (\u → s { _domain = u }) <$> f (_domain s) 110 | 111 | path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL 112 | path f s = (\u → s { _path = u }) <$> f (_path s) 113 | 114 | defaultHttpURL ∷ HttpURL 115 | defaultHttpURL = HttpURL 116 | { _auth = defaultAuth 117 | , _domain = "" 118 | , _path = "" 119 | } 120 | 121 | validateHttpURL ∷ ConfigValidation HttpURL [] 122 | validateHttpURL conf = do 123 | validateAuth $ _auth conf 124 | when (_domain conf ≡ "" && _path conf ≡ "") $ 125 | throwError "domain and path must not both be null" 126 | 127 | instance FromJSON (HttpURL → HttpURL) where 128 | parseJSON = withObject "HttpURL" $ \o → id 129 | <$< auth %.: "auth" % o 130 | <*< domain ..: "domain" % o 131 | <*< path ..: "path" % o 132 | 133 | instance ToJSON HttpURL where 134 | toJSON a = object 135 | [ "auth" .= _auth a 136 | , "domain" .= _domain a 137 | , "path" .= _path a 138 | ] 139 | 140 | pHttpURL ∷ MParser HttpURL 141 | pHttpURL = id 142 | <$< auth %:: pAuth 143 | <*< domain .:: strOption 144 | % long "domain" 145 | ⊕ short 'd' 146 | ⊕ help "HTTP domain" 147 | <*< path .:: strOption 148 | % long "path" 149 | ⊕ help "HTTP URL path" 150 | 151 | -- | Information about the main Application 152 | -- 153 | mainInfo ∷ ProgramInfoValidate HttpURL [] 154 | mainInfo = programInfoValidate "HTTP URL" pHttpURL defaultHttpURL validateHttpURL 155 | 156 | -- This version assumes usage of cabal with custom Setup.hs 157 | -- 158 | main ∷ IO () 159 | main = runWithPkgInfoConfiguration mainInfo pkgInfo $ \conf → 160 | putStrLn 161 | $ "http://" 162 | ⊕ (_user ∘ _auth) conf 163 | ⊕ ":" 164 | ⊕ (_pwd ∘ _auth) conf 165 | ⊕ "@" 166 | ⊕ _domain conf 167 | ⊕ "/" 168 | ⊕ _path conf 169 | 170 | -- This version does not rely on cabal 171 | -- 172 | main_ ∷ IO () 173 | main_ = runWithConfiguration mainInfo $ \conf → 174 | putStrLn 175 | $ "http://" 176 | ⊕ (_user ∘ _auth) conf 177 | ⊕ ":" 178 | ⊕ (_pwd ∘ _auth) conf 179 | ⊕ "@" 180 | ⊕ _domain conf 181 | ⊕ "/" 182 | ⊕ _path conf 183 | -------------------------------------------------------------------------------- /examples/Trivial.hs: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------------------ -- 2 | -- Copyright © 2014 AlephCloud Systems, Inc. 3 | -- ------------------------------------------------------ -- 4 | 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE UnicodeSyntax #-} 9 | 10 | {-# OPTIONS_GHC -fno-warn-orphans #-} 11 | 12 | module Main ( main ) where 13 | 14 | import Configuration.Utils 15 | 16 | import PkgInfo 17 | 18 | instance FromJSON (() → ()) where 19 | parseJSON _ = pure id 20 | 21 | mainInfo ∷ ProgramInfo () 22 | mainInfo = programInfo "Hello World" (pure id) () 23 | 24 | main ∷ IO () 25 | main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world" 26 | -------------------------------------------------------------------------------- /src/Configuration/Utils/CommandLine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE UnicodeSyntax #-} 6 | 7 | -- | 8 | -- Module: Configuration.Utils.CommandLine 9 | -- Description: Command Line Option Parsing with Default Values 10 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 11 | -- License: MIT 12 | -- Maintainer: Lars Kuhtz 13 | -- Stability: experimental 14 | -- 15 | -- This module provides tools for defining command line parsers for 16 | -- configuration types. 17 | -- 18 | -- Unlike /normal/ command line parsers the parsers for configuration 19 | -- types are expected to yield an update function that takes 20 | -- a value and updates the value with the settings from the command line. 21 | -- 22 | -- Assuming that 23 | -- 24 | -- * all configuration types are nested Haskell records or 25 | -- simple types and 26 | -- 27 | -- * that there are lenses for all record fields 28 | -- 29 | -- usually the operators '.::' and '%::' are all that is needed from this module. 30 | -- 31 | -- The module "Configuration.Utils.Monoid" provides tools for the case that 32 | -- a /simple type/ is a container with a monoid instance, such as @List@ or 33 | -- @HashMap@. 34 | -- 35 | -- The module "Configuration.Utils.Maybe" explains the usage of optional 36 | -- 'Maybe' values in configuration types. 37 | -- 38 | module Configuration.Utils.CommandLine 39 | ( MParser 40 | , (.::) 41 | , (%::) 42 | 43 | -- * Misc Utils 44 | , boolReader 45 | , boolOption 46 | , boolOption_ 47 | , enableDisableFlag 48 | , fileOption 49 | , eitherReadP 50 | , jsonOption 51 | , jsonReader 52 | , module Options.Applicative 53 | ) where 54 | 55 | import Configuration.Utils.Internal 56 | import Configuration.Utils.Operators 57 | 58 | import Control.Applicative 59 | 60 | import Data.Aeson 61 | import qualified Data.ByteString.Lazy.Char8 as BL8 62 | import qualified Data.CaseInsensitive as CI 63 | import Data.Maybe 64 | import Data.Monoid.Unicode 65 | import Data.String 66 | import qualified Data.Text as T 67 | 68 | import Options.Applicative hiding (Parser, Success) 69 | import qualified Options.Applicative.Types as O 70 | 71 | import qualified Options.Applicative as O 72 | import qualified Options.Applicative.Builder.Internal as O 73 | 74 | import Prelude hiding (any, concatMap, mapM_) 75 | 76 | import qualified Text.ParserCombinators.ReadP as P hiding (string) 77 | 78 | import Prelude.Unicode hiding ((×)) 79 | 80 | 81 | -- -------------------------------------------------------------------------- -- 82 | -- Applicative Option Parsing with Default Values 83 | 84 | -- | Type of option parsers that yield a modification function. 85 | -- 86 | type MParser a = O.Parser (a → a) 87 | 88 | -- | An operator for applying a setter to an option parser that yields a value. 89 | -- 90 | -- Example usage: 91 | -- 92 | -- > data Auth = Auth 93 | -- > { _user ∷ !String 94 | -- > , _pwd ∷ !String 95 | -- > } 96 | -- > 97 | -- > user ∷ Functor f ⇒ (String → f String) → Auth → f Auth 98 | -- > user f s = (\u → s { _user = u }) <$> f (_user s) 99 | -- > 100 | -- > pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth 101 | -- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s) 102 | -- > 103 | -- > -- or with lenses and TemplateHaskell just: 104 | -- > -- $(makeLenses ''Auth) 105 | -- > 106 | -- > pAuth ∷ MParser Auth 107 | -- > pAuth = id 108 | -- > <$< user .:: strOption 109 | -- > % long "user" 110 | -- > ⊕ short 'u' 111 | -- > ⊕ help "user name" 112 | -- > <*< pwd .:: strOption 113 | -- > % long "pwd" 114 | -- > ⊕ help "password for user" 115 | -- 116 | (.::) ∷ (Alternative f, Applicative f) ⇒ Lens' a b → f b → f (a → a) 117 | (.::) a opt = set a <$> opt <|> pure id 118 | infixr 5 .:: 119 | {-# INLINE (.::) #-} 120 | 121 | -- | An operator for applying a setter to an option parser that yields 122 | -- a modification function. 123 | -- 124 | -- Example usage: 125 | -- 126 | -- > data HttpURL = HttpURL 127 | -- > { _auth ∷ !Auth 128 | -- > , _domain ∷ !String 129 | -- > } 130 | -- > 131 | -- > auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL 132 | -- > auth f s = (\u → s { _auth = u }) <$> f (_auth s) 133 | -- > 134 | -- > domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL 135 | -- > domain f s = (\u → s { _domain = u }) <$> f (_domain s) 136 | -- > 137 | -- > path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL 138 | -- > path f s = (\u → s { _path = u }) <$> f (_path s) 139 | -- > 140 | -- > -- or with lenses and TemplateHaskell just: 141 | -- > -- $(makeLenses ''HttpURL) 142 | -- > 143 | -- > pHttpURL ∷ MParser HttpURL 144 | -- > pHttpURL = id 145 | -- > <$< auth %:: pAuth 146 | -- > <*< domain .:: strOption 147 | -- > % long "domain" 148 | -- > ⊕ short 'd' 149 | -- > ⊕ help "HTTP domain" 150 | -- 151 | (%::) ∷ (Alternative f, Applicative f) ⇒ Lens' a b → f (b → b) → f (a → a) 152 | (%::) a opt = over a <$> opt <|> pure id 153 | infixr 5 %:: 154 | {-# INLINE (%::) #-} 155 | 156 | -- -------------------------------------------------------------------------- -- 157 | -- Misc Utilities for Command Line Option Parsing 158 | 159 | boolReader 160 | ∷ (Eq a, Show a, CI.FoldCase a, IsString a, IsString e, Monoid e) 161 | ⇒ a 162 | → Either e Bool 163 | boolReader x = case CI.mk x of 164 | "true" → Right True 165 | "false" → Right False 166 | _ → Left $ "failed to read Boolean value " ⊕ fromString (show x) 167 | ⊕ ". Expected either \"true\" or \"false\"" 168 | 169 | -- | The 'boolOption' is an alternative to 'O.switch'. 170 | -- 171 | -- Using 'O.switch' with command line parsers that overwrite settings 172 | -- from a configuration file is problematic: the absence of the 'switch' 173 | -- is interpreted as setting the respective configuration value to 'False'. 174 | -- So there is no way to specify on the command line that the value from 175 | -- the configuration file shall be used. Some command line UIs use two 176 | -- different options for those values, for instance @--enable-feature@ and 177 | -- @--disable-feature@. This option instead expects a Boolean value. Beside 178 | -- that it behaves like any other option. 179 | -- 180 | boolOption 181 | ∷ O.Mod O.OptionFields Bool 182 | → O.Parser Bool 183 | boolOption mods = O.option (O.eitherReader (boolReader ∷ String → Either String Bool)) 184 | % O.metavar "true|false" 185 | ⊕ O.completeWith ["true", "false", "TRUE", "FALSE", "True", "False"] 186 | ⊕ mods 187 | 188 | -- | An alternative syntax for 'boolOption' for options with long names. 189 | -- 190 | -- Instead of taking a boolean argument the presence of the option acts as a 191 | -- switch to set the respective configuration setting to 'True'. If the option 192 | -- is not present the setting is left unchanged. 193 | -- 194 | -- In addition for long option names a respective /unset flag/ is provided. For 195 | -- instance for a flag @--verbose@ there will also be a flag @--no-verbose@. 196 | -- 197 | -- This can still be used with short option names only, but no /unset flag/ 198 | -- would be provided. 199 | -- 200 | boolOption_ 201 | ∷ O.Mod O.FlagFields Bool 202 | → O.Parser Bool 203 | boolOption_ mods = flag' True mods <|> flag' False nomods 204 | where 205 | O.Mod f d o = mods 206 | O.FlagFields names _ = f $ O.FlagFields [] False 207 | 208 | longName (O.OptShort _) = Nothing 209 | longName (O.OptLong l) = Just l 210 | longNames = mapMaybe longName names 211 | 212 | noName l = "no-" ⊕ l 213 | mapFlags flags = flags 214 | { O.flagNames = mapMaybe (\l → O.OptLong ∘ noName <$> longName l) (O.flagNames flags) 215 | } 216 | nomods = O.Mod (mapFlags ∘ f) d o 217 | ⊕ maybe mempty (\l → help $ "unset flag " ⊕ l) (listToMaybe $ reverse longNames) 218 | 219 | -- | An option parser for flags that are enabled via the flag name prefixed 220 | -- with @--enable-@ and disabled via the flag name prefix @--disable-@. The 221 | -- prefixes are applied to all long option names. Short option names are parsed 222 | -- unchanged and cause the flag to be enabled. 223 | -- 224 | -- This resembles the style of flags that is used for instances with Cabal. 225 | -- 226 | enableDisableFlag 227 | ∷ O.Mod O.FlagFields Bool 228 | → O.Parser Bool 229 | enableDisableFlag mods = flag' True enmods <|> flag' False dismods 230 | where 231 | O.Mod f d o = mods 232 | O.FlagFields names _ = f $ O.FlagFields [] False 233 | 234 | longName (O.OptShort _) = Nothing 235 | longName (O.OptLong l) = Just l 236 | longNames = mapMaybe longName names 237 | 238 | disName l = "disable-" ⊕ l 239 | enName l = "enable-" ⊕ l 240 | 241 | -- disable flags 242 | mapDisFlags flags = flags 243 | { O.flagNames = mapMaybe (\l → O.OptLong ∘ disName <$> longName l) (O.flagNames flags) 244 | } 245 | dismods = O.Mod (mapDisFlags ∘ f) d o 246 | ⊕ maybe mempty (\l → help $ "unset flag " ⊕ l) (listToMaybe $ reverse longNames) 247 | 248 | -- enable flags 249 | mapLong g (O.OptLong l) = O.OptLong (g l) 250 | mapLong _ s = s 251 | mapEnFlags flags = flags 252 | { O.flagNames = map (mapLong enName) (O.flagNames flags) 253 | } 254 | enmods = O.Mod (mapEnFlags ∘ f) d o 255 | 256 | -- | An option that expects a file name. 257 | -- 258 | fileOption 259 | ∷ O.Mod O.OptionFields String 260 | → O.Parser FilePath 261 | fileOption mods = O.strOption 262 | % O.metavar "FILE" 263 | ⊕ O.action "file" 264 | ⊕ mods 265 | 266 | -- | Create an either-reader from a 'ReadP' parser. 267 | -- 268 | eitherReadP 269 | ∷ T.Text 270 | → P.ReadP a 271 | → T.Text 272 | → Either T.Text a 273 | eitherReadP label p s = 274 | case [ x | (x,"") ← P.readP_to_S p (T.unpack s) ] of 275 | [x] → Right x 276 | [] → Left $ "eitherReadP: no parse for " ⊕ label ⊕ " of " ⊕ s 277 | _ → Left $ "eitherReadP: ambigous parse for " ⊕ label ⊕ " of " ⊕ s 278 | 279 | -- | An option that expects a JSON value as argument. 280 | -- 281 | jsonOption ∷ FromJSON a ⇒ Mod OptionFields a → O.Parser a 282 | jsonOption = O.option jsonReader 283 | 284 | -- | An option reader for a JSON value. 285 | -- 286 | jsonReader ∷ FromJSON a ⇒ ReadM a 287 | jsonReader = eitherReader $ eitherDecode' ∘ BL8.pack 288 | 289 | -------------------------------------------------------------------------------- /src/Configuration/Utils/ConfigFile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE UnicodeSyntax #-} 8 | 9 | -- | 10 | -- Module: Configuration.Utils.ConfigFile 11 | -- Description: Parsing of Configuration Files with Default Values 12 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 13 | -- License: MIT 14 | -- Maintainer: Lars Kuhtz 15 | -- Stability: experimental 16 | -- 17 | -- This module provides tools for defining configuration file 18 | -- parsers via instances of 'FromJSON'. 19 | -- 20 | -- Unlike /normal/ 'FromJSON' instances the parsers for configuration 21 | -- files are expected to yield an update function that takes 22 | -- a value and updates the value with the settings from the configuration 23 | -- file. 24 | -- 25 | -- Assuming that 26 | -- 27 | -- * all configuration types are nested Haskell records or 28 | -- simple types and 29 | -- 30 | -- * that there are lenses for all record fields 31 | -- 32 | -- usually the operators '..:' and '%.:' are all that is needed from this module. 33 | -- 34 | -- The module "Configuration.Utils.Monoid" provides tools for the case that 35 | -- a /simple type/ is a container with a monoid instance, such as @List@ or 36 | -- @HashMap@. 37 | -- 38 | -- The module "Configuration.Utils.Maybe" explains the usage of optional 39 | -- 'Maybe' values in configuration types. 40 | -- 41 | module Configuration.Utils.ConfigFile 42 | ( 43 | -- * Parsing of Configuration Files with Default Values 44 | setProperty 45 | , (..:) 46 | , (!..:) 47 | , updateProperty 48 | , (%.:) 49 | 50 | -- * Configuration File Parsing Policy 51 | , ConfigFile(..) 52 | , ConfigFilesConfig(..) 53 | #if REMOTE_CONFIGS 54 | , cfcHttpsPolicy 55 | #endif 56 | , defaultConfigFilesConfig 57 | , pConfigFilesConfig 58 | 59 | -- * Miscellaneous Utilities 60 | , dropAndUncaml 61 | , module Data.Aeson 62 | ) where 63 | 64 | import Configuration.Utils.CommandLine 65 | import Configuration.Utils.Internal 66 | 67 | import Data.Aeson 68 | import Data.Aeson.Types (Parser) 69 | import Data.Char 70 | import Data.Foldable 71 | #if MIN_VERSION_aeson(2,0,0) 72 | import qualified Data.Aeson.Key as K 73 | import qualified Data.Aeson.KeyMap as H 74 | #else 75 | import qualified Data.HashMap.Strict as H 76 | #endif 77 | import Data.Maybe 78 | import Data.Monoid.Unicode 79 | import Data.String 80 | import qualified Data.Text as T 81 | 82 | import Prelude hiding (any, concatMap, mapM_) 83 | 84 | #ifdef REMOTE_CONFIGS 85 | import Configuration.Utils.Internal.HttpsCertPolicy 86 | import Configuration.Utils.Operators 87 | #endif 88 | 89 | -- -------------------------------------------------------------------------- -- 90 | -- Compatibility 91 | 92 | #if MIN_VERSION_aeson(2,0,0) 93 | fromText ∷ T.Text → Key 94 | fromText = K.fromText 95 | #else 96 | fromText ∷ T.Text → T.Text 97 | fromText = id 98 | #endif 99 | 100 | -- | A JSON 'Value' parser for a property of a given 101 | -- 'Object' that updates a setter with the parsed value. 102 | -- 103 | -- > data Auth = Auth 104 | -- > { _userId ∷ !Int 105 | -- > , _pwd ∷ !String 106 | -- > } 107 | -- > 108 | -- > userId ∷ Functor f ⇒ (Int → f Int) → Auth → f Auth 109 | -- > userId f s = (\u → s { _userId = u }) <$> f (_userId s) 110 | -- > 111 | -- > pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth 112 | -- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s) 113 | -- > 114 | -- > -- or with lenses and TemplateHaskell just: 115 | -- > -- $(makeLenses ''Auth) 116 | -- > 117 | -- > instance FromJSON (Auth → Auth) where 118 | -- > parseJSON = withObject "Auth" $ \o → id 119 | -- > <$< setProperty user "user" p o 120 | -- > <*< setProperty pwd "pwd" parseJSON o 121 | -- > where 122 | -- > p = withText "user" $ \case 123 | -- > "alice" → pure (0 ∷ Int) 124 | -- > "bob" → pure 1 125 | -- > e → fail $ "unrecognized user " ⊕ e 126 | -- 127 | setProperty 128 | ∷ Setter' a b -- ^ a lens into the target that is updated by the parser 129 | → T.Text -- ^ the JSON property name 130 | → (Value → Parser b) -- ^ the JSON 'Value' parser that is used to parse the value of the property 131 | → Object -- ^ the parsed JSON 'Value' 'Object' 132 | → Parser (a → a) 133 | setProperty s k p o = case H.lookup (fromText k) o of 134 | Nothing → pure id 135 | Just v → set s <$> p v 136 | 137 | -- | A variant of the 'setProperty' that uses the default 'parseJSON' method from the 138 | -- 'FromJSON' instance to parse the value of the property. Its usage pattern mimics the 139 | -- usage pattern of the '.:' operator from the aeson library. 140 | -- 141 | -- > data Auth = Auth 142 | -- > { _user ∷ !String 143 | -- > , _pwd ∷ !String 144 | -- > } 145 | -- > 146 | -- > user ∷ Functor f ⇒ (String → f String) → Auth → f Auth 147 | -- > user f s = (\u → s { _user = u }) <$> f (_user s) 148 | -- > 149 | -- > pwd ∷ Functor f ⇒ (String → f String) → Auth → f Auth 150 | -- > pwd f s = (\p → s { _pwd = p }) <$> f (_pwd s) 151 | -- > 152 | -- > -- or with lenses and TemplateHaskell just: 153 | -- > -- $(makeLenses ''Auth) 154 | -- > 155 | -- > instance FromJSON (Auth → Auth) where 156 | -- > parseJSON = withObject "Auth" $ \o → id 157 | -- > <$< user ..: "user" % o 158 | -- > <*< pwd ..: "pwd" % o 159 | -- 160 | (..:) ∷ FromJSON b ⇒ Setter' a b → T.Text → Object → Parser (a → a) 161 | (..:) s k = setProperty s k parseJSON 162 | infix 6 ..: 163 | {-# INLINE (..:) #-} 164 | 165 | -- | A JSON parser for a function that modifies a property 166 | -- of a given 'Object' and updates a setter with the parsed 167 | -- function. 168 | -- 169 | -- This function is useful when a 'FromJSON' instance isn't available. 170 | -- When a 'FromJSON' instance exists, the '%.:' provides a more 171 | -- ideomatic alternative. 172 | -- 173 | -- > data HttpURL = HttpURL 174 | -- > { _auth ∷ !Auth 175 | -- > , _domain ∷ !String 176 | -- > } 177 | -- > 178 | -- > auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL 179 | -- > auth f s = (\u → s { _auth = u }) <$> f (_auth s) 180 | -- > 181 | -- > domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL 182 | -- > domain f s = (\u → s { _domain = u }) <$> f (_domain s) 183 | -- > 184 | -- > path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL 185 | -- > path f s = (\u → s { _path = u }) <$> f (_path s) 186 | -- > 187 | -- > -- or with lenses and TemplateHaskell just: 188 | -- > -- $(makeLenses ''HttpURL) 189 | -- > 190 | -- > instance FromJSON (HttpURL → HttpURL) where 191 | -- > parseJSON = withObject "HttpURL" $ \o → id 192 | -- > <$< updateProperty auth "auth" parseJSON o 193 | -- > <*< setProperty domain "domain" parseJSON o 194 | -- 195 | updateProperty 196 | ∷ Setter' a b 197 | → T.Text 198 | → (Value → Parser (b → b)) 199 | → Object 200 | → Parser (a → a) 201 | updateProperty s k p o = case H.lookup (fromText k) o of 202 | Nothing → pure id 203 | Just v → over s <$> p v 204 | {-# INLINE updateProperty #-} 205 | 206 | -- | A variant of 'updateProperty' that uses the 'FromJSON' instance 207 | -- for the update function. It mimics the aeson operator '.:'. 208 | -- It creates a parser that modifies a setter with a parsed function. 209 | -- 210 | -- > data HttpURL = HttpURL 211 | -- > { _auth ∷ !Auth 212 | -- > , _domain ∷ !String 213 | -- > } 214 | -- > 215 | -- > auth ∷ Functor f ⇒ (Auth → f Auth) → HttpURL → f HttpURL 216 | -- > auth f s = (\u → s { _auth = u }) <$> f (_auth s) 217 | -- > 218 | -- > domain ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL 219 | -- > domain f s = (\u → s { _domain = u }) <$> f (_domain s) 220 | -- > 221 | -- > path ∷ Functor f ⇒ (String → f String) → HttpURL → f HttpURL 222 | -- > path f s = (\u → s { _path = u }) <$> f (_path s) 223 | -- > 224 | -- > -- or with lenses and TemplateHaskell just: 225 | -- > -- $(makeLenses ''HttpURL) 226 | -- > 227 | -- > instance FromJSON (HttpURL → HttpURL) where 228 | -- > parseJSON = withObject "HttpURL" $ \o → id 229 | -- > <$< auth %.: "auth" % o 230 | -- > <*< domain ..: "domain" % o 231 | -- 232 | (%.:) ∷ FromJSON (b → b) ⇒ Setter' a b → T.Text → Object → Parser (a → a) 233 | (%.:) s k = updateProperty s k parseJSON 234 | infix 6 %.: 235 | {-# INLINE (%.:) #-} 236 | 237 | -- | This operator requires that a value is explicitly provided in a 238 | -- configuration file, thus preventing the default value from being used. 239 | -- Otherwise this operator does the same as '(..:)'. 240 | -- 241 | (!..:) 242 | ∷ FromJSON b 243 | ⇒ Lens' a b 244 | → T.Text 245 | → Object 246 | → Parser (a → a) 247 | (!..:) l property o = set l <$> (o .: fromText property) 248 | {-# INLINE (!..:) #-} 249 | 250 | -- -------------------------------------------------------------------------- -- 251 | -- Config File Parsing Policy 252 | 253 | data ConfigFile 254 | = ConfigFileRequired { getConfigFile ∷ !T.Text } 255 | | ConfigFileOptional { getConfigFile ∷ !T.Text } 256 | deriving (Show, Read, Eq, Ord) 257 | 258 | -- | An /internal/ type for the meta configuration that specifies how the 259 | -- configuration files are loaded and parsed. 260 | -- 261 | #if REMOTE_CONFIGS 262 | data ConfigFilesConfig = ConfigFilesConfig 263 | { _cfcHttpsPolicy ∷ !HttpsCertPolicy 264 | } 265 | deriving (Show, Eq) 266 | 267 | cfcHttpsPolicy ∷ Lens' ConfigFilesConfig HttpsCertPolicy 268 | cfcHttpsPolicy = lens _cfcHttpsPolicy $ \a b → a { _cfcHttpsPolicy = b } 269 | 270 | defaultConfigFilesConfig ∷ ConfigFilesConfig 271 | defaultConfigFilesConfig = ConfigFilesConfig 272 | { _cfcHttpsPolicy = defaultHttpsCertPolicy 273 | } 274 | 275 | pConfigFilesConfig ∷ MParser ConfigFilesConfig 276 | pConfigFilesConfig = id 277 | <$< cfcHttpsPolicy %:: pHttpsCertPolicy "config-" 278 | 279 | #else 280 | 281 | data ConfigFilesConfig = ConfigFilesConfig {} 282 | 283 | defaultConfigFilesConfig ∷ ConfigFilesConfig 284 | defaultConfigFilesConfig = ConfigFilesConfig {} 285 | 286 | pConfigFilesConfig ∷ MParser ConfigFilesConfig 287 | pConfigFilesConfig = pure id 288 | #endif 289 | 290 | -- -------------------------------------------------------------------------- -- 291 | -- Miscellaneous Utilities 292 | 293 | dropAndUncaml ∷ Int → String → String 294 | dropAndUncaml _ "" = "" 295 | dropAndUncaml i l = case drop i l of 296 | [] → l 297 | (h:t) → toLower h : concatMap (\x → if isUpper x then "-" ⊕ [toLower x] else [x]) t 298 | -------------------------------------------------------------------------------- /src/Configuration/Utils/FromJsonWithDef.hs: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------------------ -- 2 | -- Copyright © 2014 AlephCloud Systems, Inc. 3 | -- ------------------------------------------------------ -- 4 | 5 | {-# LANGUAGE UnicodeSyntax #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE DefaultSignatures #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# LANGUAGE FlexibleInstances #-} 13 | {-# LANGUAGE OverlappingInstances #-} 14 | 15 | module Configuration.Utils.FromJsonWithDef 16 | ( 17 | -- * Parsing with Default Values 18 | FromJsonWithDef(..) 19 | , decodeWithDef' 20 | , (∴) 21 | 22 | -- * Misc Utils 23 | , checkUnexpected 24 | , identifyJSON 25 | ) where 26 | 27 | import Control.Applicative 28 | import Control.Monad 29 | 30 | import Data.Aeson 31 | import Data.Aeson.Types (Parser, parseEither) 32 | import qualified Data.Attoparsec.ByteString as A 33 | import qualified Data.ByteString as B 34 | import qualified Data.ByteString.Lazy.Char8 as B8 35 | import qualified Data.HashMap.Strict as H 36 | import Data.Monoid.Unicode 37 | import qualified Data.Text as T 38 | import Data.Time.Clock (NominalDiffTime, UTCTime) 39 | import Data.Word 40 | import Data.Maybe 41 | 42 | import Prelude.Unicode 43 | 44 | -- -------------------------------------------------------------------------- -- 45 | -- Misc Utils 46 | 47 | identifyJSON ∷ B.ByteString → Either String Value 48 | identifyJSON = A.eitherResult . A.parse json' 49 | 50 | checkUnexpected ∷ String → [T.Text] → Object → Parser () 51 | checkUnexpected section props o = 52 | if H.null unexpected 53 | then return () 54 | else fail $ "Unexpected properties in " ⊕ section ⊕ " : " ⊕ showUnexpected 55 | where 56 | unexpected = o `H.difference` (H.fromList ∘ map (,()) $ props) 57 | showUnexpected = B8.unpack ∘ encode ∘ Object $ unexpected 58 | 59 | -- -------------------------------------------------------------------------- -- 60 | -- Parse With Default Values 61 | 62 | decodeWithDef' ∷ FromJsonWithDef b ⇒ b → B.ByteString → Either String b 63 | decodeWithDef' base s = do 64 | v ← identifyJSON s 65 | parseEither (parseJsonWithDef $ Just base) v 66 | 67 | -- | The purpose of this class is to decode JSON objects that are missing some 68 | -- properties. 69 | -- 70 | -- The Aeson library provides the @.:?@ and @.!=@ operators for this purpose. 71 | -- However usage of those operators requires static (a-priory known) default 72 | -- value. 73 | -- 74 | -- NOTE that the purpose is /NOT/ to compensate for parsing failures, but solely 75 | -- to provide default values for omitted fields. In particular a field value of 76 | -- @null@ is /NOT/ an omitted value. Of cource the parser invokes 77 | -- 'parseJsonWithDefault' only on values that arn't ommited. This means that only 78 | -- for types with some sort of indexed components there are meaningful 79 | -- instances. For other types, in particular for types with strictly less the 80 | -- two parameters in all constructors, the only meaningful instances omit any 81 | -- given default value and fall back to 'parseJSON'. 82 | -- 83 | -- For values with a 'FromJSON' instance there is a default implementation 84 | -- that simply ignores the given default value. 85 | -- 86 | -- Primitive types and types without a reasonable default logic instances should 87 | -- satisfy 88 | -- 89 | -- > parseJsonWithDef _ ≡ parseJSON 90 | -- 91 | -- For types with fromJSON instances that are objects instances should replace 92 | -- missing properties with the respective property of the default value. 93 | -- 94 | -- For sum types 95 | -- 96 | -- TODO: It would be possible to generate instances for types with an FromJSON 97 | -- isntance generically: 'parseJsonWithDef' would map the default tree onto 98 | -- the parser structure such that if the parse "deviates" from the construction 99 | -- of the default value, the default value wouldn't be used and any missing 100 | -- value would result in a failure. 101 | -- 102 | class FromJsonWithDef a where 103 | parseJsonWithDef ∷ Maybe a → Value → Parser a 104 | 105 | default parseJsonWithDef ∷ FromJSON a ⇒ Maybe a → Value → Parser a 106 | parseJsonWithDef _ = parseJSON 107 | 108 | instance FromJsonWithDef () 109 | instance FromJsonWithDef Bool 110 | instance FromJsonWithDef Int 111 | instance FromJsonWithDef Integer 112 | instance FromJsonWithDef Float 113 | instance FromJsonWithDef Double 114 | instance FromJsonWithDef Rational 115 | instance FromJsonWithDef Word8 116 | instance FromJsonWithDef Word16 117 | instance FromJsonWithDef Word32 118 | instance FromJsonWithDef Word64 119 | instance FromJsonWithDef UTCTime 120 | instance FromJSON NominalDiffTime ⇒ FromJsonWithDef NominalDiffTime 121 | instance FromJsonWithDef String 122 | instance FromJsonWithDef T.Text 123 | 124 | instance (FromJSON a, FromJsonWithDef a) ⇒ FromJsonWithDef (Maybe a) where 125 | parseJsonWithDef (Just a) = parseJSON >=> \case 126 | Nothing → pure Nothing 127 | Just a_ → Just <$> parseJsonWithDef a a_ 128 | parseJsonWithDef Nothing = parseJSON 129 | 130 | instance 131 | ( FromJSON a, FromJsonWithDef a 132 | , FromJSON b, FromJsonWithDef b 133 | ) 134 | ⇒ FromJsonWithDef (a, b) 135 | where 136 | parseJsonWithDef (Just (a,b)) = parseJSON >=> \(a_ ::Value, b_ ::Value) → (,) 137 | <$> parseJsonWithDef (Just a) a_ 138 | <*> parseJsonWithDef (Just b) b_ 139 | parseJsonWithDef Nothing = parseJSON 140 | 141 | instance 142 | ( FromJSON a, FromJsonWithDef a 143 | , FromJSON b, FromJsonWithDef b 144 | , FromJSON c, FromJsonWithDef c 145 | ) 146 | ⇒ FromJsonWithDef (a, b, c) 147 | where 148 | parseJsonWithDef (Just (a,b,c)) = parseJSON >=> \(a_,b_,c_) → (,,) 149 | <$> parseJsonWithDef (Just a) a_ 150 | <*> parseJsonWithDef (Just b) b_ 151 | <*> parseJsonWithDef (Just c) c_ 152 | parseJsonWithDef Nothing = parseJSON 153 | 154 | instance 155 | ( FromJSON a, FromJsonWithDef a 156 | , FromJSON b, FromJsonWithDef b 157 | ) 158 | ⇒ FromJsonWithDef (Either a b) 159 | where 160 | parseJsonWithDef (Just (Right a)) = parseJSON >=> \case 161 | Right a_ → Right <$> parseJsonWithDef (Just a) a_ 162 | Left b_ → Left <$> parseJsonWithDef Nothing b_ 163 | parseJsonWithDef (Just (Left b)) = parseJSON >=> \case 164 | Right a_ → Right <$> parseJsonWithDef Nothing a_ 165 | Left b_ → Left <$> parseJsonWithDef (Just b) b_ 166 | parseJsonWithDef Nothing = parseJSON 167 | 168 | 169 | -- | This instance applies the default values in order to the parsed list. If 170 | -- the parse list is shorter than the default list, the missing trailing values 171 | -- in the parse result a filled in from the default values. 172 | -- 173 | instance (FromJSON a, FromJsonWithDef a) ⇒ FromJsonWithDef [a] where 174 | parseJsonWithDef (Just l) = parseJSON >=> \l_ → g <$> zipWithM 175 | f 176 | (map Just l ⊕ repeat Nothing) 177 | (map Just l_ ⊕ repeat Nothing) 178 | where 179 | f Nothing Nothing = pure Nothing 180 | f (Just a) Nothing = Just <$> pure a 181 | f a (Just a_) = Just <$> parseJsonWithDef a a_ 182 | g = map (\(Just x) → x) ∘ takeWhile isJust 183 | parseJsonWithDef Nothing = parseJSON 184 | 185 | -- TODO provide instances for Maps, and Sets. 186 | 187 | -- | Parse an object field with a default value. 188 | -- For using this ternary operator within ideomatic 189 | -- applicative style code it can be combined with the '%' 190 | -- operator that is defined below 191 | -- 192 | -- @ 193 | -- data A = A { a ∷ Int, b ∷ Int } 194 | -- 195 | -- instance FromJsonWithDef A where 196 | -- parseJsonWithDef d = withObject "A" $ \o → A 197 | -- <$> o ∴ "a" % fmap a d 198 | -- <*> o ∴ "b" % fmap b d 199 | -- @ 200 | -- 201 | -- The hex value of the UTF-8 character ∴ is 0x2234. 202 | -- 203 | -- In vim type: @Ctrl-k .:@ 204 | -- 205 | (∴) ∷ (FromJsonWithDef a) ⇒ Object → T.Text → Maybe a → Parser a 206 | (∴) o js d = case H.lookup js o of 207 | Nothing → maybe err return d 208 | Just v → parseJsonWithDef d v 209 | where 210 | err = fail $ "missing property " ⊕ T.unpack js 211 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Http.hs: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------------------ -- 2 | -- Copyright © 2014 AlephCloud Systems, Inc. 3 | -- ------------------------------------------------------ -- 4 | 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE OverloadedLists #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE UnicodeSyntax #-} 13 | 14 | {-# OPTIONS_HADDOCK show-extensions #-} 15 | 16 | module Configuration.Utils.Http 17 | ( 18 | -- * HTTP Service TLS Configuration 19 | HttpServiceTLSConfiguration 20 | , hstcCertFile 21 | , hstcKeyFile 22 | , defaultHttpServiceTLSConfiguration 23 | , pHttpServiceTLSConfiguration 24 | , validateHttpServiceTLSConfiguration 25 | 26 | -- * HTTP Service Configuration 27 | , HttpServiceConfiguration 28 | , hscHost 29 | , hscPort 30 | , hscUseTLS 31 | , defaultHttpServiceConfiguration 32 | , pHttpServiceConfiguration 33 | , validateHttpServiceConfiguration 34 | 35 | -- * Http Client Configuration 36 | , HttpClientConfiguration 37 | , hccHost 38 | , hccPort 39 | , hccUseTLS 40 | , defaultHttpClientConfiguration 41 | , pHttpClientConfiguration 42 | , validateHttpClientConfiguration 43 | , httpService2clientConfiguration 44 | ) where 45 | 46 | import Configuration.Utils 47 | import Configuration.Utils.Internal 48 | import Configuration.Utils.Validation 49 | 50 | import Control.Monad (when) 51 | import Control.Monad.Writer.Class (tell) 52 | 53 | import qualified Data.ByteString.Char8 as B8 54 | import qualified Data.DList as DL 55 | import Data.Maybe (isJust) 56 | import Data.Monoid.Unicode 57 | 58 | import Prelude.Unicode hiding ((×)) 59 | 60 | -- -------------------------------------------------------------------------- -- 61 | -- Http Service TLS Configuration 62 | 63 | -- | In order to make TLS optional this type should be used 64 | -- wrapped into a Maybe. 65 | -- 66 | data HttpServiceTLSConfiguration = HttpServiceTLSConfiguration 67 | { _hstcCertFile ∷ !FilePath 68 | , _hstcKeyFile ∷ !FilePath 69 | } 70 | deriving (Show, Read, Eq, Ord) 71 | 72 | hstcCertFile ∷ Lens' HttpServiceTLSConfiguration FilePath 73 | hstcCertFile = lens _hstcCertFile $ \s a → s { _hstcCertFile = a} 74 | 75 | hstcKeyFile ∷ Lens' HttpServiceTLSConfiguration FilePath 76 | hstcKeyFile = lens _hstcKeyFile $ \s a → s { _hstcKeyFile = a} 77 | 78 | defaultHttpServiceTLSConfiguration ∷ HttpServiceTLSConfiguration 79 | defaultHttpServiceTLSConfiguration = HttpServiceTLSConfiguration 80 | { _hstcCertFile = "cert.pem" 81 | , _hstcKeyFile = "key.pem" 82 | } 83 | 84 | validateHttpServiceTLSConfiguration 85 | ∷ ConfigValidation HttpServiceTLSConfiguration f 86 | validateHttpServiceTLSConfiguration conf = do 87 | validateFileReadable "cert-file" $ _hstcCertFile conf 88 | validateFileReadable "key-file" $ _hstcKeyFile conf 89 | 90 | instance FromJSON (HttpServiceTLSConfiguration → HttpServiceTLSConfiguration) where 91 | parseJSON = withObject "HttpServiceTLSConfiguration" $ \o → id 92 | <$< hstcCertFile ..: "cert-file" % o 93 | <*< hstcKeyFile ..: "pem-file" % o 94 | 95 | -- | This is used as default when wrapped into Maybe and 96 | -- 97 | -- 1. the parsed value is not 'Null' and 98 | -- 2. the given default is not 'Nothing'. 99 | -- 100 | instance FromJSON HttpServiceTLSConfiguration where 101 | parseJSON v = parseJSON v <*> pure defaultHttpServiceTLSConfiguration 102 | 103 | instance ToJSON HttpServiceTLSConfiguration where 104 | toJSON HttpServiceTLSConfiguration{..} = object 105 | [ "cert-file" .= _hstcCertFile 106 | , "key-file" .= _hstcKeyFile 107 | ] 108 | 109 | -- | This option parser does not allow to enable or disable 110 | -- usage of TLS. The option will have effect only when TLS 111 | -- usage is configured in the configuration file or the default 112 | -- configuration. 113 | -- 114 | -- FIXME: print a warning and exit when one of these options is 115 | -- provided even though TLS is turned off. 116 | -- 117 | pHttpServiceTLSConfiguration ∷ String → MParser HttpServiceTLSConfiguration 118 | pHttpServiceTLSConfiguration prefix = id 119 | <$< hstcCertFile .:: strOption 120 | % long (prefix ⊕ "cert-file") 121 | ⊕ help "File with PEM encoded TLS Certificate" 122 | <*< hstcKeyFile .:: strOption 123 | % long (prefix ⊕ "key-file") 124 | ⊕ help "File with PEM encoded TLS key" 125 | 126 | -- -------------------------------------------------------------------------- -- 127 | -- Http Service Configuration 128 | 129 | -- | We restrict services to use either HTTP or HTTPS but not both. 130 | -- 131 | -- TLS can be turned off explicitely in the configuration file by 132 | -- setting the respective section to @null@. It can not be 133 | -- turned on or off via command line options. But once it is turned 134 | -- on the values for the certificate and key file can be changed 135 | -- by command line options. 136 | -- 137 | data HttpServiceConfiguration = HttpServiceConfiguration 138 | { _hscHost ∷ !B8.ByteString 139 | , _hscPort ∷ !Int 140 | , _hscInterface ∷ !B8.ByteString 141 | , _hscUseTLS ∷ !(Maybe HttpServiceTLSConfiguration) 142 | } 143 | deriving (Show, Read, Eq, Ord) 144 | 145 | hscHost ∷ Lens' HttpServiceConfiguration B8.ByteString 146 | hscHost = lens _hscHost $ \s a → s { _hscHost = a} 147 | 148 | hscPort ∷ Lens' HttpServiceConfiguration Int 149 | hscPort = lens _hscPort $ \s a → s { _hscPort = a} 150 | 151 | hscInterface ∷ Lens' HttpServiceConfiguration B8.ByteString 152 | hscInterface = lens _hscInterface $ \s a → s { _hscInterface = a} 153 | 154 | hscUseTLS ∷ Lens' HttpServiceConfiguration (Maybe HttpServiceTLSConfiguration) 155 | hscUseTLS = lens _hscUseTLS $ \s a → s { _hscUseTLS = a} 156 | 157 | defaultHttpServiceConfiguration ∷ HttpServiceConfiguration 158 | defaultHttpServiceConfiguration = HttpServiceConfiguration 159 | { _hscHost = "localhost" 160 | , _hscPort = 80 161 | , _hscInterface = "0.0.0.0" 162 | , _hscUseTLS = Nothing 163 | } 164 | 165 | validateHttpServiceConfiguration ∷ ConfigValidation HttpServiceConfiguration DL.DList 166 | validateHttpServiceConfiguration conf = do 167 | maybe (return ()) validateHttpServiceTLSConfiguration $ _hscUseTLS conf 168 | validatePort "port" $ _hscPort conf 169 | when (_hscPort conf < 1024) $ 170 | tell ["listening on a priviledged port requires super user rights"] 171 | validateNonEmpty "host" $ _hscHost conf 172 | validateIPv4 "interface" . B8.unpack $ _hscInterface conf 173 | 174 | instance FromJSON (HttpServiceConfiguration → HttpServiceConfiguration) where 175 | parseJSON = withObject "HttpServiceConfiguration" $ \o → id 176 | <$< hscHost ∘ bs ..: "host" % o 177 | <*< hscPort ..: "port" % o 178 | <*< hscInterface ∘ bs ..: "interface" % o 179 | <*< hscUseTLS %.: "use-tls" % o 180 | where 181 | bs ∷ Iso' B8.ByteString String 182 | bs = iso B8.unpack B8.pack 183 | 184 | instance ToJSON HttpServiceConfiguration where 185 | toJSON HttpServiceConfiguration{..} = object 186 | [ "host" .= B8.unpack _hscHost 187 | , "port" .= _hscPort 188 | , "interface" .= B8.unpack _hscInterface 189 | , "use-tls" .= _hscUseTLS 190 | ] 191 | 192 | pHttpServiceConfiguration ∷ String → MParser HttpServiceConfiguration 193 | pHttpServiceConfiguration prefix = id 194 | <$< hscHost ∘ bs .:: strOption 195 | % long (prefix ⊕ "host") 196 | ⊕ help "Hostname of the service" 197 | <*< hscPort .:: option auto 198 | % long (prefix ⊕ "port") 199 | ⊕ help "Port of the service" 200 | <*< hscInterface ∘ bs .:: option auto 201 | % long (prefix ⊕ "interface") 202 | ⊕ help "Interface of the service" 203 | <*< (hscUseTLS %:: (fmap <$> pHttpServiceTLSConfiguration prefix)) 204 | where 205 | bs ∷ Iso' B8.ByteString String 206 | bs = iso B8.unpack B8.pack 207 | 208 | -- -------------------------------------------------------------------------- -- 209 | -- Http Client Configuration 210 | 211 | data HttpClientConfiguration = HttpClientConfiguration 212 | { _hccHost ∷ !B8.ByteString 213 | , _hccPort ∷ !Int 214 | , _hccUseTLS ∷ !Bool 215 | } 216 | deriving (Show, Read, Eq, Ord) 217 | 218 | hccHost ∷ Lens' HttpClientConfiguration B8.ByteString 219 | hccHost = lens _hccHost $ \s a → s { _hccHost = a} 220 | 221 | hccPort ∷ Lens' HttpClientConfiguration Int 222 | hccPort = lens _hccPort $ \s a → s { _hccPort = a} 223 | 224 | hccUseTLS ∷ Lens' HttpClientConfiguration Bool 225 | hccUseTLS = lens _hccUseTLS $ \s a → s { _hccUseTLS = a} 226 | 227 | defaultHttpClientConfiguration ∷ HttpClientConfiguration 228 | defaultHttpClientConfiguration = HttpClientConfiguration 229 | { _hccHost = "localhost" 230 | , _hccPort = 80 231 | , _hccUseTLS = False 232 | } 233 | 234 | validateHttpClientConfiguration ∷ ConfigValidation HttpClientConfiguration f 235 | validateHttpClientConfiguration conf = do 236 | validatePort "port" $ _hccPort conf 237 | validateNonEmpty "host" $ _hccHost conf 238 | 239 | instance FromJSON (HttpClientConfiguration → HttpClientConfiguration) where 240 | parseJSON = withObject "HttpClientConfiguration" $ \o → id 241 | <$< hccHost ∘ bs ..: "host" % o 242 | <*< hccPort ..: "port" % o 243 | <*< hccUseTLS ..: "use-tls" % o 244 | where 245 | bs ∷ Iso' B8.ByteString String 246 | bs = iso B8.unpack B8.pack 247 | 248 | instance ToJSON HttpClientConfiguration where 249 | toJSON HttpClientConfiguration{..} = object 250 | [ "host" .= B8.unpack _hccHost 251 | , "port" .= _hccPort 252 | , "use-tls" .= _hccUseTLS 253 | ] 254 | 255 | pHttpClientConfiguration ∷ String → MParser HttpClientConfiguration 256 | pHttpClientConfiguration serviceName = id 257 | <$< hccHost ∘ bs .:: strOption 258 | % long (serviceName ⊕ "-host") 259 | ⊕ help ("Hostname of " ⊕ serviceName) 260 | <*< hccPort .:: option auto 261 | % long (serviceName ⊕ "-port") 262 | ⊕ help ("Port of " ⊕ serviceName) 263 | <*< hccUseTLS .:: switch 264 | % long (serviceName ⊕ "-use-tls") 265 | ⊕ help ("Connect to " ⊕ serviceName ⊕ " via TLS") 266 | where 267 | bs ∷ Iso' B8.ByteString String 268 | bs = iso B8.unpack B8.pack 269 | 270 | httpService2clientConfiguration ∷ HttpServiceConfiguration → HttpClientConfiguration 271 | httpService2clientConfiguration HttpServiceConfiguration{..} = HttpClientConfiguration 272 | { _hccHost = _hscHost 273 | , _hccPort = _hscPort 274 | , _hccUseTLS = isJust _hscUseTLS 275 | } 276 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE UnicodeSyntax #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | 7 | -- | 8 | -- Module: Configuration.Utils.Interal 9 | -- Description: Internal utilities of the configuration-tools package 10 | -- Copyright: Copyright © 2014-2015 PivotCloud, Inc. 11 | -- License: MIT 12 | -- Maintainer: Lars Kuhtz 13 | -- Stability: experimental 14 | -- 15 | module Configuration.Utils.Internal 16 | ( 17 | -- * Lenses 18 | lens 19 | , over 20 | , set 21 | , view 22 | , Lens' 23 | , Lens 24 | , Setter' 25 | , Setter 26 | , Iso' 27 | , Iso 28 | , iso 29 | 30 | -- * Misc Utils 31 | , (&) 32 | , (<&>) 33 | , sshow 34 | , exceptT 35 | , errorT 36 | ) where 37 | 38 | import Control.Applicative (Const(..)) 39 | import Control.Monad 40 | import Control.Monad.Reader.Class 41 | import Control.Monad.Except 42 | 43 | import Data.Function ((&)) 44 | import Data.Functor ((<&>)) 45 | import Data.Functor.Identity 46 | import Data.Monoid.Unicode 47 | import Data.Profunctor 48 | import Data.Profunctor.Unsafe 49 | import Data.String 50 | import qualified Data.Text as T 51 | 52 | import Prelude.Unicode 53 | 54 | -- -------------------------------------------------------------------------- -- 55 | -- Lenses 56 | 57 | -- Just what we need of van Laarhoven Lenses 58 | -- 59 | -- These few lines of code do safe us a lot of dependencies 60 | 61 | -- | This is the same type as the type from the lens library with the same name. 62 | -- 63 | -- In case it is already import from the lens package this should be hidden 64 | -- from the import. 65 | -- 66 | type Lens s t a b = ∀ f . Functor f ⇒ (a → f b) → s → f t 67 | 68 | -- | This is the same type as the type from the lens library with the same name. 69 | -- 70 | -- In case it is already import from the lens package this should be hidden 71 | -- from the import. 72 | -- 73 | type Lens' s a = Lens s s a a 74 | 75 | -- | This is almost the same type as the type from the lens library with the same name. 76 | -- 77 | -- In case it is already import from the lens package this should be hidden 78 | -- from the import. 79 | -- 80 | type Setter s t a b = (a -> Identity b) -> s -> Identity t 81 | 82 | -- | This is almost the same type as the type from the lens library with the same name. 83 | -- 84 | -- In case it is already import from the lens package this should be hidden 85 | -- from the import. 86 | -- 87 | type Setter' s a = Setter s s a a 88 | 89 | lens ∷ (s → a) → (s → b → t) → Lens s t a b 90 | lens getter setter lGetter s = setter s `fmap` lGetter (getter s) 91 | {-# INLINE lens #-} 92 | 93 | over ∷ Setter s t a b → (a → b) → s → t 94 | over s f = runIdentity . s (Identity . f) 95 | {-# INLINE over #-} 96 | 97 | set ∷ Setter s t a b → b → s → t 98 | set s a = runIdentity . s (const $ Identity a) 99 | {-# INLINE set #-} 100 | 101 | view ∷ MonadReader r m ⇒ ((a → Const a a) → r → Const a r) → m a 102 | view l = asks (getConst #. l Const) 103 | {-# INLINE view #-} 104 | 105 | -- | This is the same type as the type from the lens library with the same name. 106 | -- 107 | -- In case it is already import from the lens package this should be hidden 108 | -- from the import. 109 | -- 110 | type Iso s t a b = ∀ p f . (Profunctor p, Functor f) ⇒ p a (f b) → p s (f t) 111 | type Iso' s a = Iso s s a a 112 | 113 | iso ∷ (s → a) → (b → t) → Iso s t a b 114 | iso f g = dimap f (fmap g) 115 | {-# INLINE iso #-} 116 | 117 | -- -------------------------------------------------------------------------- -- 118 | -- Misc Utils 119 | 120 | sshow 121 | ∷ (Show a, IsString s) 122 | ⇒ a 123 | → s 124 | sshow = fromString ∘ show 125 | {-# INLINE sshow #-} 126 | 127 | exceptT 128 | ∷ Monad m 129 | ⇒ (e → m b) 130 | → (a → m b) 131 | → ExceptT e m a 132 | → m b 133 | exceptT a b = runExceptT >=> either a b 134 | {-# INLINE exceptT #-} 135 | 136 | errorT 137 | ∷ Monad m 138 | ⇒ ExceptT T.Text m a 139 | → m a 140 | errorT = exceptT (\e → error ∘ T.unpack $ "Error: " ⊕ e) return 141 | {-# INLINE errorT #-} 142 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Internal/ConfigFileReader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE UnicodeSyntax #-} 10 | 11 | -- | 12 | -- Module: Configuration.Utils.Internal.ConfigFileReader 13 | -- Description: Internal Tools for Parsing Configuration Files 14 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 15 | -- License: MIT 16 | -- Maintainer: Lars Kuhtz 17 | -- Stability: experimental 18 | -- 19 | module Configuration.Utils.Internal.ConfigFileReader 20 | ( 21 | parseConfigFiles 22 | , readConfigFile 23 | , ConfigFileFormat(..) 24 | 25 | -- * Local Config Files 26 | , loadLocal 27 | 28 | #ifdef REMOTE_CONFIGS 29 | -- * Remote Config Files 30 | , isRemote 31 | , loadRemote 32 | , yamlMimeType 33 | , jsonMimeType 34 | , contentType 35 | , requestHeaders 36 | #endif 37 | ) where 38 | 39 | import Configuration.Utils.ConfigFile 40 | import Configuration.Utils.Internal 41 | import Configuration.Utils.Validation 42 | 43 | import Control.Applicative 44 | import Control.DeepSeq (NFData) 45 | import Control.Monad 46 | import Control.Monad.Error.Class 47 | import Control.Monad.IO.Class 48 | 49 | import Data.Bifunctor 50 | import qualified Data.ByteString.Char8 as B8 51 | import Data.Monoid.Unicode 52 | import qualified Data.Text as T 53 | import qualified Data.Yaml as Yaml 54 | 55 | import GHC.Generics 56 | 57 | import Prelude hiding (any, concatMap, mapM_) 58 | import Prelude.Unicode 59 | 60 | #ifdef REMOTE_CONFIGS 61 | import Configuration.Utils.Internal.HttpsCertPolicy 62 | 63 | import Control.Exception.Enclosed 64 | import Control.Monad.Trans.Control 65 | 66 | import qualified Data.ByteString.Lazy as LB 67 | import qualified Data.CaseInsensitive as CI 68 | import qualified Data.List as L 69 | import Data.String 70 | import qualified Data.Text.IO as T 71 | 72 | import qualified Network.HTTP.Client as HTTP 73 | import qualified Network.HTTP.Types.Header as HTTP 74 | 75 | import System.IO 76 | #endif 77 | 78 | -- -------------------------------------------------------------------------- -- 79 | -- Tools for parsing configuration files 80 | 81 | #ifdef REMOTE_CONFIGS 82 | type ConfigFileParser m = 83 | ( Functor m 84 | , Applicative m 85 | , MonadIO m 86 | , MonadBaseControl IO m 87 | , MonadError T.Text m 88 | ) 89 | #else 90 | type ConfigFileParser m = 91 | ( Functor m 92 | , Applicative m 93 | , MonadIO m 94 | , MonadError T.Text m 95 | ) 96 | #endif 97 | 98 | parseConfigFiles 99 | ∷ (ConfigFileParser m, FromJSON (a → a)) 100 | ⇒ ConfigFilesConfig 101 | → a 102 | -- ^ default configuration value 103 | → [ConfigFile] 104 | -- ^ list of configuration file paths 105 | → m a 106 | parseConfigFiles conf = foldM $ \val file → 107 | readConfigFile conf file <*> pure val 108 | 109 | readConfigFile 110 | ∷ (ConfigFileParser m, FromJSON (a → a)) 111 | ⇒ ConfigFilesConfig 112 | → ConfigFile 113 | -- ^ file path 114 | → m (a → a) 115 | readConfigFile _conf file = 116 | #ifdef REMOTE_CONFIGS 117 | if isRemote file then loadRemote _conf file else loadLocal file 118 | #else 119 | loadLocal file 120 | #endif 121 | 122 | fileType ∷ T.Text → ConfigFileFormat 123 | fileType f 124 | | ".yaml" `T.isSuffixOf` T.toLower f = Yaml 125 | | ".yml" `T.isSuffixOf` T.toLower f = Yaml 126 | | ".json" `T.isSuffixOf` T.toLower f = Json 127 | | ".js" `T.isSuffixOf` T.toLower f = Json 128 | | otherwise = Other 129 | 130 | loadLocal 131 | ∷ (Functor m, MonadIO m, MonadError T.Text m, FromJSON (a → a)) 132 | ⇒ ConfigFile 133 | -- ^ file path 134 | → m (a → a) 135 | loadLocal path = do 136 | validateFilePath "config-file" (T.unpack file) 137 | exists ← (True <$ validateFile "config-file" (T.unpack file)) `catchError` \e → case path of 138 | ConfigFileOptional _ → return False 139 | ConfigFileRequired _ → throwError $ "failed to read config file: " ⊕ e 140 | if exists 141 | then 142 | liftIO (parser (fileType file) file) >>= \case 143 | Left e → throwError $ "failed to parse configuration file " ⊕ file ⊕ ": " ⊕ sshow e 144 | Right r → return r 145 | else 146 | return id 147 | where 148 | file = getConfigFile path 149 | 150 | parser Json f = first T.pack ∘ eitherDecodeStrict' <$> B8.readFile (T.unpack f) 151 | parser _ f = first sshow <$> Yaml.decodeFileEither (T.unpack f) 152 | 153 | data ConfigFileFormat 154 | = Yaml 155 | | Json 156 | | Other 157 | deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) 158 | 159 | instance NFData ConfigFileFormat 160 | 161 | #ifdef REMOTE_CONFIGS 162 | isRemote 163 | ∷ ConfigFile 164 | → Bool 165 | isRemote path = L.any (`T.isPrefixOf` getConfigFile path) ["http://", "https://"] 166 | 167 | yamlMimeType ∷ IsString s ⇒ [s] 168 | yamlMimeType = map fromString ["application/x-yaml", "text/yaml"] 169 | 170 | -- | Defined in RFC 4627 171 | -- 172 | jsonMimeType ∷ IsString s ⇒ [s] 173 | jsonMimeType = map fromString ["application/json"] 174 | 175 | contentType 176 | ∷ B8.ByteString 177 | -- ^ value of an HTTP @Content-Type@ header 178 | → ConfigFileFormat 179 | contentType headerValue 180 | | CI.foldCase "yaml" `B8.isInfixOf` CI.foldCase headerValue = Yaml 181 | | CI.foldCase "json" `B8.isInfixOf` CI.foldCase headerValue = Json 182 | | otherwise = Other 183 | 184 | loadRemote 185 | ∷ (ConfigFileParser m, FromJSON (a → a)) 186 | ⇒ ConfigFilesConfig 187 | → ConfigFile 188 | -- ^ URL 189 | → m (a → a) 190 | loadRemote conf path = do 191 | validateHttpOrHttpsUrl "config-file" (T.unpack url) 192 | result ← (Just <$> doHttp) `catchAnyDeep` \e → 193 | case path of 194 | ConfigFileOptional _ → do 195 | liftIO ∘ T.hPutStrLn stderr $ "WARNING: failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e 196 | return Nothing 197 | ConfigFileRequired _ → throwError $ "failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e 198 | 199 | case result of 200 | Nothing → return id 201 | Just (format, d) → case (parser format) d of 202 | Left e → throwError $ "failed to parse remote configuration " ⊕ url ⊕ ": " ⊕ e 203 | Right r → return r 204 | where 205 | parser Json = first T.pack ∘ eitherDecodeStrict' 206 | parser _ = first sshow ∘ Yaml.decodeEither' 207 | 208 | url = getConfigFile path 209 | policy = _cfcHttpsPolicy conf 210 | doHttp = liftIO $ do 211 | request ← (HTTP.parseUrlThrow $ T.unpack url) 212 | <&> over requestHeaders ((:) acceptHeader) 213 | resp ← httpWithValidationPolicy request policy 214 | let format = maybe Other contentType ∘ L.lookup HTTP.hContentType $ HTTP.responseHeaders resp 215 | return (format, LB.toStrict (HTTP.responseBody resp)) 216 | 217 | acceptHeader = (HTTP.hAccept, B8.intercalate "," (yamlMimeType ⊕ jsonMimeType)) 218 | 219 | requestHeaders ∷ Lens' HTTP.Request HTTP.RequestHeaders 220 | requestHeaders = lens HTTP.requestHeaders $ \s a → s { HTTP.requestHeaders = a } 221 | 222 | #endif 223 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Internal/HttpsCertPolicy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE UnicodeSyntax #-} 6 | 7 | -- | 8 | -- Module: Configuration.Utils.Internal.HttpsCertPolicy 9 | -- Description: HTTPS certificate validation policy 10 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 11 | -- License: MIT 12 | -- Maintainer: Lars Kuhtz 13 | -- Stability: experimental 14 | -- 15 | -- This module provides means for defining and using HTTPS 16 | -- certificate validation polices for HTTPS requests. 17 | -- 18 | module Configuration.Utils.Internal.HttpsCertPolicy 19 | ( 20 | -- * HTTPS Certificate Validation Policy 21 | HttpsCertPolicy(..) 22 | , certPolicyInsecure 23 | , certPolicyHostFingerprints 24 | , defaultHttpsCertPolicy 25 | , pHttpsCertPolicy 26 | 27 | -- * HTTP Requests With Certificate Validation Policy 28 | , simpleHttpWithValidationPolicy 29 | , httpWithValidationPolicy 30 | , VerboseTlsException(..) 31 | ) where 32 | 33 | import Configuration.Utils.CommandLine 34 | import Configuration.Utils.Internal 35 | import Configuration.Utils.Monoid 36 | import Configuration.Utils.Operators 37 | import Configuration.Utils.Validation 38 | 39 | import Control.Exception (Exception, Handler(..), catches, throwIO) 40 | import Control.Monad.State 41 | 42 | import Data.Bifunctor 43 | import qualified Data.ByteString.Base64 as B64 44 | import qualified Data.ByteString.Char8 as B8 45 | import qualified Data.ByteString.Lazy as LB 46 | import Data.Default (def) 47 | import qualified Data.HashMap.Strict as HM 48 | import Data.IORef 49 | import qualified Data.List as L 50 | import Data.Maybe 51 | import Data.Monoid.Unicode 52 | import Data.String 53 | import qualified Data.Text as T 54 | import qualified Data.Text.Encoding as T 55 | import qualified Data.X509 as TLS 56 | import qualified Data.X509.Validation as TLS 57 | 58 | import qualified Options.Applicative as O 59 | 60 | import Prelude hiding (any, concatMap, mapM_) 61 | import Prelude.Unicode hiding ((×)) 62 | 63 | import qualified Network.Connection as HTTP 64 | import qualified Network.HTTP.Client as HTTP 65 | import qualified Network.HTTP.Client.TLS as HTTP 66 | import qualified Network.TLS as TLS hiding (HashSHA256) 67 | import qualified Network.TLS.Extra as TLS 68 | 69 | import qualified System.X509 as TLS 70 | 71 | import Text.Read (readEither) 72 | 73 | -- -------------------------------------------------------------------------- -- 74 | -- HTTPS Certificate Validation Policy 75 | 76 | data HttpsCertPolicy = HttpsCertPolicy 77 | { _certPolicyInsecure ∷ !Bool 78 | -- ^ disable certificate validation 79 | , _certPolicyHostFingerprints ∷ !(HM.HashMap TLS.ServiceID TLS.Fingerprint) 80 | -- ^ a whitelist for services with trusted certificates 81 | } 82 | deriving (Show, Eq) 83 | 84 | certPolicyInsecure ∷ Lens' HttpsCertPolicy Bool 85 | certPolicyInsecure = lens _certPolicyInsecure $ \s a → s { _certPolicyInsecure = a } 86 | 87 | certPolicyHostFingerprints ∷ Lens' HttpsCertPolicy (HM.HashMap TLS.ServiceID TLS.Fingerprint) 88 | certPolicyHostFingerprints = lens _certPolicyHostFingerprints $ \s a → s { _certPolicyHostFingerprints = a } 89 | 90 | defaultHttpsCertPolicy ∷ HttpsCertPolicy 91 | defaultHttpsCertPolicy = HttpsCertPolicy 92 | { _certPolicyInsecure = False 93 | , _certPolicyHostFingerprints = mempty 94 | } 95 | 96 | pHttpsCertPolicy 97 | ∷ T.Text 98 | -- ^ prefix for the command line options 99 | → MParser HttpsCertPolicy 100 | pHttpsCertPolicy prefix = id 101 | <$< certPolicyInsecure .:: boolOption_ 102 | % O.long (T.unpack prefix ⊕ "https-insecure") 103 | ⊕ O.help "Bypass certificate validation for all HTTPS connections to all services. ONLY USE THIS WHEN YOU UNDERSTAND WHAT YOU DO." 104 | <*< certPolicyHostFingerprints %:: pLeftMonoidalUpdate % pRule 105 | where 106 | pRule = O.option (O.eitherReader readFingerprint) 107 | % O.long (T.unpack prefix ⊕ "https-allow-cert") 108 | ⊕ O.help "Unconditionally trust the certificate for connecting to the service. ONLY USE THIS WHEN YOU ARE SURE THAT THE CERTIFICATE CAN BE TRUSTED." 109 | ⊕ O.metavar "HOSTNAME:PORT:FINGERPRINT" 110 | readFingerprint = evalStateT $ do 111 | hostname ∷ String ← next 112 | x $ validateNonEmpty "hostname" hostname 113 | port ∷ Int ← lift ∘ readEither =<< next 114 | x $ validatePort "port" port 115 | fingerprint ← lift ∘ B64.decode ∘ B8.pack =<< next 116 | x $ validateNonEmpty "fingerprint" fingerprint -- FIXME we should evaluate the length 117 | return $ HM.singleton (hostname, sshow port) (TLS.Fingerprint fingerprint) 118 | 119 | next = state $ second (drop 1) ∘ break (≡ ':') 120 | 121 | x = lift ∘ first T.unpack 122 | 123 | -- -------------------------------------------------------------------------- -- 124 | -- HTTP Requests With Certificate Validation Policy 125 | 126 | 127 | -- | Make an HTTP request with a given certificate validation policy. 128 | -- 129 | -- NOTE that the HTTP request is strictly loaded into memory. 130 | -- 131 | -- NOTE that this implementation opens a new TCP connection for each single 132 | -- request. HTTPS certificates validation results are not cached between different 133 | -- requests. 134 | -- 135 | simpleHttpWithValidationPolicy 136 | ∷ T.Text 137 | -- ^ HTTP or HTTPS URL 138 | → HttpsCertPolicy 139 | → IO (HTTP.Response LB.ByteString) 140 | simpleHttpWithValidationPolicy url policy = do 141 | request ← HTTP.parseUrlThrow $ T.unpack url 142 | httpWithValidationPolicy request policy 143 | 144 | httpWithValidationPolicy 145 | ∷ HTTP.Request 146 | → HttpsCertPolicy 147 | → IO (HTTP.Response LB.ByteString) 148 | httpWithValidationPolicy request policy = do 149 | certVar ← newIORef Nothing 150 | settings ← getSettings policy certVar 151 | mgr ← HTTP.newManager settings 152 | HTTP.httpLbs request mgr `catches` 153 | [ Handler $ \(e ∷ TLS.TLSException) → do 154 | cert ← readIORef certVar 155 | handleTlsException request cert e 156 | ] 157 | 158 | -- -------------------------------------------------------------------------- -- 159 | -- Verbose TLS exceptions 160 | 161 | -- | The Haskell @tls@ library provides only limited means for providing 162 | -- user friendly error messages. In particular we'd like to provide the 163 | -- user with fingerprints of the reject certificate for self-signed 164 | -- certificates. Also we want to provide the user with some guidance what 165 | -- a particular failure may indicate with respect to security of the 166 | -- connection. 167 | -- 168 | -- Here we employ a /hack/ for better error handling: Based on the assumption 169 | -- that we initialize a new connection 'Manager' and also a new certificate 170 | -- cache for each request, we write the certificate that is received 171 | -- from the server in the TLS handshake to an 'IORef'. If the handshakes 172 | -- fails later on because the certificate is rejected we can recover the 173 | -- rejected certificate from the 'IORef'. 174 | -- 175 | -- What we really want are exceptions that can be consumed programatically. 176 | -- In particular exceptions should include rejected certificates. 177 | -- 178 | newtype VerboseTlsException = VerboseTlsException T.Text 179 | deriving (Eq, Ord) 180 | 181 | instance Show VerboseTlsException where 182 | show (VerboseTlsException msg) = "TLS exception: " ⊕ T.unpack msg 183 | 184 | instance Exception VerboseTlsException 185 | 186 | handleTlsException 187 | ∷ HTTP.Request 188 | → Maybe (TLS.SignedExact TLS.Certificate) 189 | → TLS.TLSException 190 | → IO a 191 | handleTlsException request cert e@(TLS.HandshakeFailed (TLS.Error_Protocol msg _)) 192 | | "certificate rejected: [SelfSigned]" `L.isPrefixOf` msg = throwIO ∘ VerboseTlsException 193 | $ "The server uses a self-signed certificate. If you are sure that no-one" 194 | ⊕ " is intercepting the connection and this is the correct certificate you" 195 | ⊕ " may enable usage of this certificate with the following command line option:" 196 | ⊕ "\n\n" 197 | ⊕ " " ⊕ allowCertOption 198 | ⊕ "\n" 199 | 200 | | "certificate rejected: [CacheSaysNo" `L.isPrefixOf` msg = throwIO ∘ VerboseTlsException 201 | $ "There is a mismatch between the expected certificate provided for" 202 | ⊕ " this service and the certificate provided by the service. You may try to remove" 203 | ⊕ " the expected certificate fingerprint and check if the certificate that is" 204 | ⊕ " offered by the service validates cleanly. If that is not the case this could" 205 | ⊕ " mean that someone is intercepting the connections. In this case YOU SHOULD ONLY" 206 | ⊕ " PROCEED WHEN YOU ARE SURE THAT IT IS SAFE. If you still want to proceed you may" 207 | ⊕ " accept the new certificate by using following command line option:" 208 | ⊕ "\n\n" 209 | ⊕ " " ⊕ allowCertOption 210 | ⊕ "\n\n" 211 | ⊕ " The error message was: " ⊕ T.pack msg 212 | ⊕ "\n" 213 | 214 | | "certificate rejected: [NameMismatch" `L.isPrefixOf` msg = throwIO ∘ VerboseTlsException 215 | $ "There is a mismatch between the certificate name and the server name. This" 216 | ⊕ " could mean that someone is intercepting the connection or that you are not" 217 | ⊕ " connected to the correct service. YOU SHOULD ONLY PROCEED WHEN YOU ARE SURE" 218 | ⊕ " THAT IT IS SAFE TO DO SO. If you still want to proceed you may" 219 | ⊕ " accept the certificate by using following command line option:" 220 | ⊕ "\n\n" 221 | ⊕ " " ⊕ allowCertOption 222 | ⊕ "\n\n" 223 | ⊕ " The error message was: " ⊕ T.pack msg 224 | ⊕ "\n" 225 | 226 | | "certificate rejected:" `L.isPrefixOf` msg = throwIO ∘ VerboseTlsException 227 | $ "The certificate that was offered by the service was rejected. This" 228 | ⊕ " could mean that someone is intercepting the connection or that you are not" 229 | ⊕ " connected to the correct service. YOU SHOULD ONLY PROCEED WHEN YOU ARE SURE" 230 | ⊕ " THAT IT IS SAFE TO DO SO. If you still want to proceed you may" 231 | ⊕ " accept the certificate by using following command line option:" 232 | ⊕ "\n\n" 233 | ⊕ " " ⊕ allowCertOption 234 | ⊕ "\n\n" 235 | ⊕ " The error message was: " ⊕ T.pack msg 236 | ⊕ "\n" 237 | | otherwise = throwIO e 238 | where 239 | printFingerprint (TLS.Fingerprint f) = fromString ∘ B8.unpack ∘ B64.encode $ f 240 | printCertF c = printFingerprint (TLS.getFingerprint c fingerprintAlg) 241 | fingerprintAlg = TLS.HashSHA256 242 | hostText = T.decodeUtf8 $ HTTP.host request 243 | portText = sshow $ HTTP.port request 244 | 245 | allowCertOption = case cert of 246 | Nothing → "--insecure-remote-config-files" 247 | (Just c) → 248 | "--remote-config-fingerprint=" ⊕ hostText ⊕ ":" ⊕ portText ⊕ ":" ⊕ printCertF c 249 | 250 | handleTlsException _ _ e = throwIO e 251 | 252 | -- -------------------------------------------------------------------------- -- 253 | -- TLS Settings 254 | 255 | -- | The usage of the 'certVar' parameter is not thread-safe! 256 | -- 257 | -- FIXME We could make this thread-safe by using a cache for 258 | -- "unvalidated" certificates. 259 | -- 260 | getSettings 261 | ∷ HttpsCertPolicy 262 | → IORef (Maybe (TLS.SignedExact TLS.Certificate)) 263 | → IO HTTP.ManagerSettings 264 | getSettings policy certVar = do 265 | certstore ← TLS.getSystemCertificateStore 266 | return $ HTTP.mkManagerSettings 267 | (HTTP.TLSSettings (tlsSettings certstore)) 268 | Nothing 269 | where 270 | -- It is safe to pass empty strings for host and port since 'TLS.connectFromHandle' 271 | -- and 'TLS.connectTo' are going to overwrite this anyways. 272 | -- 273 | tlsSettings certstore = (TLS.defaultParamsClient "" "") 274 | { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default } 275 | , TLS.clientShared = def 276 | { TLS.sharedCAStore = certstore 277 | , TLS.sharedValidationCache = validationCache 278 | } 279 | , TLS.clientHooks = def 280 | { TLS.onServerCertificate = \store cache serviceId certChain@(TLS.CertificateChain certs) → do 281 | modifyIORef' certVar (const $ listToMaybe certs) 282 | TLS.onServerCertificate def store cache serviceId certChain 283 | } 284 | } 285 | 286 | validationCache 287 | | _certPolicyInsecure policy = TLS.ValidationCache 288 | (\_ _ _ → return TLS.ValidationCachePass) 289 | (\_ _ _ → return ()) 290 | | otherwise = certCache (_certPolicyHostFingerprints policy) 291 | 292 | -- 'TLS.exceptionValidationCache' would have worked to here, but it's hard to get 293 | -- the certificate fingerprint of the failing certificate from the exceptions it 294 | -- generates. Unfortunately, the TLS package allows us to pass only a string message, 295 | -- so that we have to encode and to decode the fingerprint. 296 | -- 297 | certCache ∷ HM.HashMap TLS.ServiceID TLS.Fingerprint → TLS.ValidationCache 298 | certCache fingerprints = TLS.ValidationCache 299 | (queryCallback fingerprints) 300 | (\_ _ _ → return ()) 301 | 302 | queryCallback ∷ HM.HashMap TLS.ServiceID TLS.Fingerprint → TLS.ValidationCacheQueryCallback 303 | queryCallback cache serviceID fingerprint _ = return $ 304 | case HM.lookup serviceID cache of 305 | Nothing → TLS.ValidationCacheUnknown 306 | Just f 307 | | fingerprint ≡ f → TLS.ValidationCachePass 308 | | otherwise → TLS.ValidationCacheDenied 309 | $ "for host: " ⊕ fst serviceID ⊕ ":" ⊕ B8.unpack (snd serviceID) 310 | ⊕ " expected fingerprint: " ⊕ printFingerprint f 311 | ⊕ " but got fingerprint: " ⊕ printFingerprint fingerprint 312 | where 313 | printFingerprint (TLS.Fingerprint f) = fromString ∘ B8.unpack ∘ B64.encode $ f 314 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Internal/JsonTools.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UnicodeSyntax #-} 9 | 10 | -- | 11 | -- Module: Configuration.Utils.Internal.JsonTools 12 | -- Copyright: Copyright © 2020 Lars Kuhtz 13 | -- License: MIT 14 | -- Maintainer: Lars Kuhtz 15 | -- Stability: experimental 16 | -- 17 | -- The difference algorithms uses the following identies on JSON Values: 18 | -- 19 | -- * An array equals the same array with all Null entries removed. 20 | -- * An object equals the same object with all Null valued properties removed. 21 | -- 22 | module Configuration.Utils.Internal.JsonTools 23 | ( Diff(..) 24 | , diff 25 | , resolve 26 | 27 | -- * Conflict Resoluation Strategies 28 | , merge 29 | , mergeLeft 30 | , mergeRight 31 | , resolveLeft 32 | , resolveOnlyLeft 33 | , resolveRight 34 | , resolveOnlyRight 35 | ) where 36 | 37 | import Control.Applicative 38 | 39 | import Data.Aeson 40 | import Data.Aeson.Types 41 | import Data.Foldable 42 | #if MIN_VERSION_aeson(2,0,0) 43 | import qualified Data.Aeson.KeyMap as HM 44 | #else 45 | import qualified Data.HashMap.Strict as HM 46 | #endif 47 | import qualified Data.Vector as V 48 | 49 | import GHC.Generics 50 | 51 | -- -------------------------------------------------------------------------- -- 52 | -- Representation of Difference between to Values 53 | 54 | -- | Represent differences between two values 55 | -- 56 | data Diff a 57 | = OnlyLeft a 58 | | OnlyRight a 59 | | Conflict a a 60 | | Both a 61 | deriving (Eq, Ord, Generic) 62 | 63 | instance ToJSON a ⇒ ToJSON (Diff a) where 64 | toJSON (OnlyLeft a) = object ["$left" .= a] 65 | toJSON (OnlyRight a) = object ["$right" .= a] 66 | toJSON (Both a) = object ["$both" .= a] 67 | toJSON (Conflict a b) = object ["$left" .= a, "$right" .= b] 68 | {-# INLINE toJSON #-} 69 | 70 | instance FromJSON a ⇒ FromJSON (Diff a) where 71 | parseJSON a = conflict a <|> right a <|> left a <|> both a 72 | where 73 | conflict = withObject "Diff.Conflict" $ \o → Conflict 74 | <$> o .: "$left" 75 | <*> o .: "$right" 76 | right = withObject "Diff.OnlyRight" $ \o → OnlyRight 77 | <$> o .: "$right" 78 | left = withObject "Diff.OnlyLeft" $ \o → OnlyLeft 79 | <$> o .: "$left" 80 | both = withObject "Diff.Both" $ \o → Both 81 | <$> o .: "$both" 82 | {-# INLINE parseJSON #-} 83 | 84 | -- -------------------------------------------------------------------------- -- 85 | -- Resolve Diff Value 86 | 87 | -- | Resolve differences between two JSON values using the provided conflict 88 | -- resolution function. 89 | -- 90 | resolve ∷ (Diff Value → Value) → Value → Value 91 | resolve f = go 92 | where 93 | go v = case f <$> parseMaybe parseJSON v of 94 | Just x → x 95 | Nothing → case v of 96 | (Object a) → Object $ HM.filter (/= Null) $ go <$> a 97 | (Array a) → Array $ V.filter (/= Null) $ go <$> a 98 | a → a 99 | 100 | -- | Merge all non-conflicting differences. Leave the conflict annotations in 101 | -- the result. 102 | -- 103 | merge ∷ Diff Value → Value 104 | merge (OnlyLeft a) = a 105 | merge (OnlyRight a) = a 106 | merge (Conflict a b) = toJSON $ Conflict a b 107 | merge (Both a) = a 108 | 109 | -- | Merge all differences. Pick the left value in case of a conflict. 110 | -- 111 | mergeLeft ∷ Diff Value → Value 112 | mergeLeft (OnlyLeft a) = a 113 | mergeLeft (OnlyRight a) = a 114 | mergeLeft (Conflict a _) = a 115 | mergeLeft (Both a) = a 116 | 117 | -- | Merge all differences. Pick the right value in case of a conflict. 118 | -- 119 | mergeRight ∷ Diff Value → Value 120 | mergeRight (OnlyLeft a) = a 121 | mergeRight (OnlyRight a) = a 122 | mergeRight (Conflict _ a) = a 123 | mergeRight (Both a) = a 124 | 125 | -- | Resolve all differences by choosing the left value. 126 | -- 127 | resolveLeft ∷ Diff Value → Value 128 | resolveLeft (OnlyLeft a) = a 129 | resolveLeft (OnlyRight _) = Null 130 | resolveLeft (Conflict a _) = a 131 | resolveLeft (Both a) = a 132 | 133 | -- | Keep values that /only/ occure in the left value. Remove all values that 134 | -- occur in the right value or in both. 135 | -- 136 | -- The result is the left value minus the right value. 137 | -- 138 | resolveOnlyLeft ∷ Diff Value → Value 139 | resolveOnlyLeft (OnlyLeft a) = a 140 | resolveOnlyLeft (OnlyRight _) = Null 141 | resolveOnlyLeft (Conflict a _) = a 142 | resolveOnlyLeft (Both _) = Null 143 | 144 | -- | Resolve all differences by choosing the right value. 145 | -- 146 | resolveRight ∷ Diff Value → Value 147 | resolveRight (OnlyLeft _) = Null 148 | resolveRight (OnlyRight a) = a 149 | resolveRight (Conflict _ a) = a 150 | resolveRight (Both a) = a 151 | 152 | -- | Keep values that /only/ occure in the right value. Remove all values that 153 | -- occur in the left value or in both. 154 | -- 155 | -- The result is the right value minus the left value. 156 | -- 157 | resolveOnlyRight ∷ Diff Value → Value 158 | resolveOnlyRight (OnlyLeft _) = Null 159 | resolveOnlyRight (OnlyRight a) = a 160 | resolveOnlyRight (Conflict _ a) = a 161 | resolveOnlyRight (Both _) = Null 162 | 163 | -- -------------------------------------------------------------------------- -- 164 | -- Compute Difference between two JSON Values 165 | 166 | -- | Merge two JSON values and annotate the result with the differences. 167 | -- 168 | diff ∷ Value → Value → Value 169 | diff a b | a == b = toJSON $ Both a 170 | diff (Object a) (Object b) = Object $ mergeObjects a b 171 | diff (Array a) (Array b) = Array $ mergeVectors a b 172 | diff a b 173 | | a == Null = toJSON $ OnlyRight b 174 | | b == Null = toJSON $ OnlyLeft a 175 | | otherwise = toJSON $ Conflict a b 176 | 177 | mergeObjects ∷ Object → Object → Object 178 | mergeObjects l r 179 | = (toJSON . OnlyLeft <$> HM.difference l r) 180 | <> (toJSON . OnlyRight <$> HM.difference r l) 181 | <> HM.intersectionWith diff l r 182 | 183 | -- | A naive list merge with a lookAhead of 1 184 | -- 185 | mergeVectors ∷ Array → Array → Array 186 | mergeVectors a b = V.fromList $ toJSON <$> go (toList a) (toList b) 187 | where 188 | go a' [] = OnlyLeft <$> a' 189 | go [] b' = OnlyRight <$> b' 190 | go al@(ha0 : ha1 : ta) bl@(hb0 : hb1 : tb) 191 | | ha0 == hb0 = Both ha0 : go (ha1 : ta) (hb1 : tb) 192 | | ha0 == hb1 = OnlyRight hb0 : go al (hb1 : tb) 193 | | ha1 == hb0 = OnlyLeft ha0 : go (ha1 : ta) bl 194 | | otherwise = Conflict ha0 hb0 : go (ha1 : ta) (hb1 : tb) 195 | go (ha0 : ta) (hb0 : tb) 196 | | ha0 == hb0 = Both ha0 : go ta tb 197 | | otherwise = Conflict ha0 hb0 : go ta tb 198 | 199 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Maybe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE UnicodeSyntax #-} 6 | 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | 9 | -- | 10 | -- Module: Configuration.Utils.Maybe 11 | -- Description: Configuration of Optional Values 12 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 13 | -- License: MIT 14 | -- Maintainer: Lars Kuhtz 15 | -- Stability: experimental 16 | -- 17 | -- This module provides tools for defining Maybe configuration types. 18 | -- 19 | module Configuration.Utils.Maybe 20 | ( 21 | -- * Simple Maybe Values 22 | -- $simplemaybe 23 | 24 | -- * Record Maybe Values 25 | -- $recordmaybe 26 | maybeOption 27 | 28 | ) where 29 | 30 | import Data.Aeson 31 | 32 | -- -------------------------------------------------------------------------- -- 33 | -- Simple Maybe Value 34 | 35 | -- $simplemaybe 36 | -- Optional configuration values are supposed to be encoded by wrapping 37 | -- the respective type with 'Maybe'. 38 | -- 39 | -- For simple values the standard 'FromJSON' instance from the aeson 40 | -- package can be used along with the '..:' operator. 41 | -- 42 | -- > data LogConfig = LogConfig 43 | -- > { _logLevel ∷ !Int 44 | -- > , _logFile ∷ !(Maybe String) 45 | -- > } 46 | -- > 47 | -- > $(makeLenses ''LogConfig) 48 | -- > 49 | -- > defaultLogConfig ∷ LogConfig 50 | -- > defaultLogConfig = LogConfig 51 | -- > { _logLevel = 1 52 | -- > , _logFile = Nothing 53 | -- > } 54 | -- > 55 | -- > instance FromJSON (LogConfig → LogConfig) where 56 | -- > parseJSON = withObject "LogConfig" $ \o → id 57 | -- > <$< logLevel ..: "LogLevel" % o 58 | -- > <*< logFile ..: "LogConfig" % o 59 | -- > 60 | -- > instance ToJSON LogConfig where 61 | -- > toJSON config = object 62 | -- > [ "LogLevel" .= _logLevel config 63 | -- > , "LogConfig" .= _logFile config 64 | -- > ] 65 | -- > 66 | -- 67 | -- When defining command line option parsers with '.::' and '%::' all 68 | -- options are optional. When an option is not present on the command 69 | -- line the default value is used. For 'Maybe' values it is therefore 70 | -- enough to wrap the parsed value into 'Just'. 71 | -- 72 | -- > pLogConfig ∷ MParser LogConfig 73 | -- > pLogConfig = id 74 | -- > <$< logLevel .:: option auto 75 | -- > % long "log-level" 76 | -- > % metavar "INTEGER" 77 | -- > % help "log level" 78 | -- > <*< logFile .:: fmap Just % strOption 79 | -- > % long "log-file" 80 | -- > % metavar "FILENAME" 81 | -- > % help "log file name" 82 | -- 83 | 84 | -- $recordmaybe 85 | -- 86 | -- For 'Maybe' types that wrap product (record) types the following orphan 'FromJSON' 87 | -- instance is provided: 88 | -- 89 | -- > instance (FromJSON (a → a), FromJSON a) ⇒ FromJSON (Maybe a → Maybe a) 90 | -- > parseJSON Null = pure (const Nothing) 91 | -- > parseJSON v = f <$> parseJSON v <*> parseJSON v 92 | -- > where 93 | -- > f g _ Nothing = Just g 94 | -- > f _ g (Just x) = Just (g x) 95 | -- 96 | -- (Using an orphan instance is generally problematic but convenient in 97 | -- this case. It's unlikely that an instance for this type is needed elsewhere. 98 | -- If this is an issue for you, please let me know. In that case we can define a 99 | -- new type for optional configuration values.) 100 | -- 101 | -- The semantics are as follows: 102 | -- 103 | -- * If the parsed configuration value is 'Null' the result is 'Nothing'. 104 | -- * If the parsed configuration value is not 'Null' then the result is 105 | -- an update function that 106 | -- 107 | -- * updates the given default value if this value is @Just x@ 108 | -- or 109 | -- * is a constant function that returns the value that is parsed 110 | -- from the configuration using the 'FromJSON' instance for the 111 | -- configuration type. 112 | -- 113 | -- Note, that this instance requires an 'FromJSON' instance for the 114 | -- configuration type itself as well as a 'FromJSON' instance for the update 115 | -- function of the configuration type. The former can be defined by means of the 116 | -- latter as follows: 117 | -- 118 | -- > instance FromJSON MyType where 119 | -- > parseJSON v = parseJSON v <*> pure defaultMyType 120 | -- 121 | -- This instance will cause the usage of 'defaultMyType' as default value if the 122 | -- default value that is given to the configuration parser is 'Nothing' and the 123 | -- parsed configuration is not 'Null'. 124 | -- 125 | instance (FromJSON (a → a), FromJSON a) ⇒ FromJSON (Maybe a → Maybe a) where 126 | 127 | -- | If the configuration explicitly requires 'Null' the result 128 | -- is 'Nothing'. 129 | -- 130 | parseJSON Null = pure (const Nothing) 131 | 132 | -- | If the default value is @(Just x)@ and the configuration 133 | -- provides and update function @f@ then result is @Just f@. 134 | -- 135 | -- If the default value is 'Nothing' and the configuration 136 | -- is parsed using a parser for a constant value (and not 137 | -- an update function). 138 | -- 139 | parseJSON v = f <$> parseJSON v <*> parseJSON v 140 | where 141 | f g _ Nothing = Just g 142 | f _ g (Just x) = Just (g x) 143 | 144 | -- | Command line parser for record 'Maybe' values 145 | -- 146 | -- == Example: 147 | -- 148 | -- > data Setting = Setting 149 | -- > { _setA ∷ !Int 150 | -- > , _setB ∷ !String 151 | -- > } 152 | -- > deriving (Show, Read, Eq, Ord, Typeable) 153 | -- > 154 | -- > $(makeLenses ''Setting) 155 | -- > 156 | -- > defaultSetting ∷ Setting 157 | -- > defaultSetting = Setting 158 | -- > { _setA = 0 159 | -- > , _setB = 1 160 | -- > } 161 | -- > 162 | -- > instance ToJSON Setting where 163 | -- > toJSON setting = object 164 | -- > [ "a" .= _setA setting 165 | -- > , "b" .= _setB setting 166 | -- > ] 167 | -- > 168 | -- > instance FromJSON (Setting → Setting) where 169 | -- > parseJSON = withObject "Setting" $ \o → id 170 | -- > <$< setA ..: "a" % o 171 | -- > <*< setB ..: "b" % o 172 | -- > 173 | -- > instance FromJSON Setting where 174 | -- > parseJSON v = parseJSON v <*> pure defaultSetting 175 | -- > 176 | -- > pSetting ∷ MParser Setting 177 | -- > pSetting = id 178 | -- > <$< setA .:: option auto 179 | -- > % short 'a' 180 | -- > <> metavar "INT" 181 | -- > <> help "set a" 182 | -- > <*< setB .:: option auto 183 | -- > % short 'b' 184 | -- > <> metavar "INT" 185 | -- > <> help "set b" 186 | -- > 187 | -- > -- | Use 'Setting' as 'Maybe' in a configuration: 188 | -- > -- 189 | -- > data Config = Config 190 | -- > { _maybeSetting ∷ !(Maybe Setting) 191 | -- > } 192 | -- > deriving (Show, Read, Eq, Ord, Typeable) 193 | -- > 194 | -- > $(makeLenses ''Config) 195 | -- > 196 | -- > defaultConfig ∷ Config 197 | -- > defaultConfig = Config 198 | -- > { _maybeSetting = defaultSetting 199 | -- > } 200 | -- > 201 | -- > instance ToJSON Config where 202 | -- > toJSON config = object 203 | -- > [ "setting" .= maybeSetting 204 | -- > ] 205 | -- > 206 | -- > instance FromJSON (Config → Config) where 207 | -- > parseJSON = withObject "Config" $ \o → id 208 | -- > <$< maybeSetting %.: "setting" % o 209 | -- > 210 | -- > pConfig ∷ MParser Config 211 | -- > pConfig = id 212 | -- > <$< maybeSetting %:: (maybeOption defaultSetting 213 | -- > <$> pEnableSetting 214 | -- > <*> pSetting) 215 | -- > where 216 | -- > pEnableSetting = boolOption 217 | -- > % long "setting-enable" 218 | -- > <> value False 219 | -- > <> help "Enable configuration flags for setting" 220 | -- 221 | maybeOption 222 | ∷ a 223 | -- ^ default value that is used if base configuration is 'Nothing' 224 | → Bool 225 | -- ^ whether to enable this parser or not (usually is a boolean option parser) 226 | → (a → a) 227 | -- ^ update function (usually given as applicative 'MParser a') 228 | → Maybe a 229 | -- ^ the base value that is updated (usually the result of parsing the configuration file) 230 | → Maybe a 231 | maybeOption _ False _ Nothing = Nothing -- not enabled 232 | maybeOption defA True update Nothing = Just $ update defA -- disabled in config file but enabled by command line 233 | maybeOption _ _ update (Just val) = Just $ update val -- enabled by config file and possibly by command line 234 | 235 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE UnicodeSyntax #-} 5 | 6 | -- | 7 | -- Module: Configuration.Utils.Monoid 8 | -- Description: Configuration of Monoids 9 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 10 | -- License: MIT 11 | -- Maintainer: Lars Kuhtz 12 | -- Stability: experimental 13 | -- 14 | -- The distinction between appending on the left and appending on the right is 15 | -- important for monoids that are sensitive to ordering such as 'List'. It is 16 | -- also of relevance for monoids with set semantics with non-extensional 17 | -- equality such as `HashMap`. 18 | -- 19 | module Configuration.Utils.Monoid 20 | ( LeftMonoidalUpdate 21 | , leftMonoidalUpdate 22 | , fromLeftMonoidalUpdate 23 | , pLeftMonoidalUpdate 24 | , pLeftSemigroupalUpdate 25 | , RightMonoidalUpdate 26 | , rightMonoidalUpdate 27 | , fromRightMonoidalUpdate 28 | , pRightMonoidalUpdate 29 | , pRightSemigroupalUpdate 30 | ) where 31 | 32 | import Configuration.Utils.CommandLine 33 | import Configuration.Utils.Internal 34 | 35 | import Data.Aeson 36 | import qualified Data.List.NonEmpty as NEL 37 | import Data.Semigroup 38 | import Data.Semigroup.Foldable (fold1) 39 | 40 | import qualified Options.Applicative.Types as O 41 | 42 | import Prelude hiding (any, concatMap, mapM_) 43 | import Prelude.Unicode 44 | 45 | -- | Update a value by appending on the left. Under normal 46 | -- circumstances you'll never use this type directly but only 47 | -- its 'FromJSON' instance. See the 'leftMonoidalUpdate' for an example. 48 | -- 49 | newtype LeftMonoidalUpdate a = LeftMonoidalUpdate 50 | { _getLeftMonoidalUpdate ∷ a 51 | } 52 | deriving (Semigroup, Monoid) 53 | 54 | -- | Update a value by appending on the left. 55 | -- 56 | -- > newtype RoutingTable = RoutingTable { _routingTableMap ∷ HashMap T.Text T.Text } 57 | -- > 58 | -- > $(makeLenses ''RoutingTable) 59 | -- > 60 | -- > instance FromJSON (RoutingTable → RoutingTable) where 61 | -- > parseJSON = withObject "RoutingTable" $ \o → id 62 | -- > <$< routingTableMap . from leftMonoidalUpdate %.: "route_map" % o 63 | -- 64 | leftMonoidalUpdate ∷ Iso (LeftMonoidalUpdate a) (LeftMonoidalUpdate b) a b 65 | leftMonoidalUpdate = iso _getLeftMonoidalUpdate LeftMonoidalUpdate 66 | 67 | -- | This is the same as @from leftMonoidalUpdate@ but doesn't depend on 68 | -- the lens Library. 69 | -- 70 | fromLeftMonoidalUpdate ∷ Iso a b (LeftMonoidalUpdate a) (LeftMonoidalUpdate b) 71 | fromLeftMonoidalUpdate = iso LeftMonoidalUpdate _getLeftMonoidalUpdate 72 | 73 | instance (FromJSON a, Monoid a) ⇒ FromJSON (LeftMonoidalUpdate a → LeftMonoidalUpdate a) where 74 | parseJSON = fmap (mappend ∘ LeftMonoidalUpdate) ∘ parseJSON 75 | 76 | -- | Update a value by appending on the left. 77 | -- 78 | -- > newtype RoutingTable = RoutingTable { _routingTableMap ∷ HashMap T.Text T.Text } 79 | -- > 80 | -- > $(makeLenses ''RoutingTable) 81 | -- > 82 | -- > pRoutingTable ∷ MParser RoutingTable 83 | -- > pRoutingTable = routingTableMap %:: pLeftMonoidalUpdate pRoute 84 | -- > where 85 | -- > pRoute = option (eitherReader readRoute) 86 | -- > % long "route" 87 | -- > <> help "add a route to the routing table; the APIROUTE part must not contain a colon character" 88 | -- > <> metavar "APIROUTE:APIURL" 89 | -- > 90 | -- > readRoute s = case break (== ':') s of 91 | -- > (a,':':b) → first T.unpack $ do 92 | -- > validateNonEmpty "APIROUTE" a 93 | -- > validateHttpOrHttpsUrl "APIURL" b 94 | -- > return $ HM.singleton (T.pack a) (T.pack b) 95 | -- > _ → Left "missing colon between APIROUTE and APIURL" 96 | -- > 97 | -- > first f = either (Left . f) Right 98 | -- 99 | pLeftMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a 100 | pLeftMonoidalUpdate pElement = mappend ∘ mconcat ∘ reverse <$> many pElement 101 | 102 | -- | Like `pLeftMonoidalUpdate`, but works for `Semigroup`s instead. Using this 103 | -- parser requires the input to have at least one copy (say, for flags that can 104 | -- be passed multiple times). 105 | -- 106 | pLeftSemigroupalUpdate ∷ Semigroup a ⇒ O.Parser a → MParser a 107 | pLeftSemigroupalUpdate pElement = (<>) ∘ fold1 ∘ NEL.fromList ∘ reverse <$> some pElement 108 | 109 | -- | Update a value by appending on the right. Under normal 110 | -- circumstances you'll never use this type directly but only 111 | -- its 'FromJSON' instance. See the 'leftMonoidalUpdate' for an example. 112 | -- 113 | newtype RightMonoidalUpdate a = RightMonoidalUpdate 114 | { _getRightMonoidalUpdate ∷ a 115 | } 116 | deriving (Semigroup, Monoid) 117 | 118 | -- | Update a value by appending on the right. See 'leftMonoidalUpdate' for 119 | -- an usage example. 120 | -- 121 | rightMonoidalUpdate ∷ Iso (RightMonoidalUpdate a) (RightMonoidalUpdate b) a b 122 | rightMonoidalUpdate = iso _getRightMonoidalUpdate RightMonoidalUpdate 123 | 124 | -- | This is the same as @from rightMonoidalUpdate@ but doesn't depend on 125 | -- the lens Library. 126 | -- 127 | fromRightMonoidalUpdate ∷ Iso a b (RightMonoidalUpdate a) (RightMonoidalUpdate b) 128 | fromRightMonoidalUpdate = iso RightMonoidalUpdate _getRightMonoidalUpdate 129 | 130 | instance (FromJSON a, Monoid a) ⇒ FromJSON (RightMonoidalUpdate a → RightMonoidalUpdate a) where 131 | parseJSON = fmap (flip mappend ∘ RightMonoidalUpdate) ∘ parseJSON 132 | 133 | -- | Update a value by appending on the right. See 'pLeftMonoidalUpdate' 134 | -- for an usage example. 135 | -- 136 | pRightMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a 137 | pRightMonoidalUpdate pElement = flip mappend ∘ mconcat <$> many pElement 138 | 139 | -- | Like `pRightMonoidalUpdate`, but works for `Semigroup`s instead. Using this 140 | -- parser requires the input to have at least one copy (say, for flags that can 141 | -- be passed multiple times). 142 | -- 143 | pRightSemigroupalUpdate ∷ Semigroup a ⇒ O.Parser a → MParser a 144 | pRightSemigroupalUpdate pElement = flip (<>) ∘ fold1 ∘ NEL.fromList <$> some pElement 145 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Operators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE UnicodeSyntax #-} 4 | 5 | -- | 6 | -- Module: Configuration.Utils.Operators 7 | -- Description: Useful operators for defining functions in an applicative context 8 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 9 | -- License: MIT 10 | -- Maintainer: Lars Kuhtz 11 | -- Stability: experimental 12 | -- 13 | -- Useful operators for defining functions in an applicative context 14 | -- 15 | module Configuration.Utils.Operators 16 | ( (%) 17 | , (×) 18 | , (<*<) 19 | , (>*>) 20 | , (<$<) 21 | , (>$>) 22 | ) where 23 | 24 | -- -------------------------------------------------------------------------- -- 25 | -- Useful Operators 26 | 27 | -- | This operator is an alternative for '$' with a higher precedence. It is 28 | -- suitable for usage within applicative style code without the need to add 29 | -- parenthesis. 30 | -- 31 | (%) ∷ (a → b) → a → b 32 | (%) = ($) 33 | infixr 5 % 34 | {-# INLINE (%) #-} 35 | 36 | -- | This operator is a UTF-8 version of '%' which is an alternative for '$' 37 | -- with a higher precedence. It is suitable for usage within applicative style 38 | -- code without the need to add parenthesis. 39 | -- 40 | -- The hex value of the UTF-8 character × is 0x00d7. 41 | -- 42 | -- In VIM type: @Ctrl-V u 00d7@ 43 | -- 44 | -- You may also define a key binding by adding something like the following line 45 | -- to your vim configuration file: 46 | -- 47 | -- > iabbrev >< × 48 | -- 49 | (×) ∷ (a → b) → a → b 50 | (×) = ($) 51 | infixr 5 × 52 | {-# INLINE (×) #-} 53 | {-# DEPRECATED (×) "use '%' instead" #-} 54 | 55 | -- | Functional composition for applicative functors. 56 | -- 57 | (<*<) ∷ Applicative f ⇒ f (b → c) → f (a → b) → f (a → c) 58 | (<*<) a b = ((.) <$> a) <*> b 59 | infixr 4 <*< 60 | {-# INLINE (<*<) #-} 61 | 62 | -- | Functional composition for applicative functors with its arguments 63 | -- flipped. 64 | -- 65 | (>*>) ∷ Applicative f ⇒ f (a → b) → f (b → c) → f (a → c) 66 | (>*>) = flip (<*<) 67 | infixr 4 >*> 68 | {-# INLINE (>*>) #-} 69 | 70 | -- | Applicative functional composition between a pure function 71 | -- and an applicative function. 72 | -- 73 | (<$<) ∷ Functor f ⇒ (b → c) → f (a → b) → f (a → c) 74 | (<$<) a b = (a .) <$> b 75 | infixr 4 <$< 76 | {-# INLINE (<$<) #-} 77 | 78 | -- | Applicative functional composition between a pure function 79 | -- and an applicative function with its arguments flipped. 80 | -- 81 | (>$>) ∷ Functor f ⇒ f (a → b) → (b → c) → f (a → c) 82 | (>$>) = flip (<$<) 83 | infixr 4 >$> 84 | {-# INLINE (>$>) #-} 85 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Setup.hs: -------------------------------------------------------------------------------- 1 | -- ------------------------------------------------------ -- 2 | -- Copyright © 2019 Colin Woodbury 3 | -- Copyright © 2015-2020 Lars Kuhtz 4 | -- Copyright © 2014 AlephCloud Systems, Inc. 5 | -- ------------------------------------------------------ -- 6 | 7 | {-# LANGUAGE CPP #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE MultiWayIf #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | 13 | {-# OPTIONS_HADDOCK show-extensions #-} 14 | 15 | -- | This module contains a @Setup.hs@ script that hooks into the cabal build 16 | -- process at the end of the configuration phase and generates a module with 17 | -- package information for each component of the cabal package. 18 | -- 19 | -- The modules are created in the /autogen/ build directories where also the 20 | -- @Path_@ modules are created by cabal's simple build setup. 21 | -- 22 | -- = Usage as Setup Script 23 | -- 24 | -- There are three ways how this module can be used: 25 | -- 26 | -- 1. Copy the code of this module into a file called @Setup.hs@ in the root 27 | -- directory of your package. 28 | -- 29 | -- 2. If the /configuration-tools/ package is already installed in the system 30 | -- where the build is done, following code can be used as @Setup.hs@ script: 31 | -- 32 | -- > module Main (main) where 33 | -- > 34 | -- > import Configuration.Utils.Setup 35 | -- 36 | -- 3. For usage within a more complex @Setup.hs@ script you shall import this 37 | -- module qualified and use the 'mkPkgInfoModules' function. For example: 38 | -- 39 | -- > module Main (main) where 40 | -- > 41 | -- > import qualified Configuration.Utils.Setup as ConfTools 42 | -- > 43 | -- > main :: IO () 44 | -- > main = defaultMainWithHooks (ConfTools.mkPkgInfoModules simpleUserHooks) 45 | -- > 46 | -- 47 | -- With all methods the field @Build-Type@ in the package description (cabal) file 48 | -- must be set to @Custom@: 49 | -- 50 | -- > Build-Type: Custom 51 | -- 52 | -- 53 | -- = Integration With "Configuration.Utils" 54 | -- 55 | -- You can integrate the information provided by the @PkgInfo@ modules with the 56 | -- command line interface of an application by importing the respective module 57 | -- for the component and using the 58 | -- 'Configuration.Utils.runWithPkgInfoConfiguration' function from the module 59 | -- "Configuration.Utils" as show in the following example: 60 | -- 61 | -- > {-# LANGUAGE OverloadedStrings #-} 62 | -- > {-# LANGUAGE FlexibleInstances #-} 63 | -- > 64 | -- > module Main 65 | -- > ( main 66 | -- > ) where 67 | -- > 68 | -- > import Configuration.Utils 69 | -- > import PkgInfo 70 | -- > 71 | -- > instance FromJSON (() -> ()) where parseJSON _ = pure id 72 | -- > 73 | -- > mainInfo :: ProgramInfo () 74 | -- > mainInfo = programInfo "Hello World" (pure id) () 75 | -- > 76 | -- > main :: IO () 77 | -- > main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world" 78 | -- 79 | -- With that the resulting application supports the following additional command 80 | -- line options: 81 | -- 82 | -- [@--version@, @-v@] 83 | -- prints the version of the application and exits. 84 | -- 85 | -- [@--info@, @-i@] 86 | -- prints a short info message for the application and exits. 87 | -- 88 | -- [@--long-info@] 89 | -- print a detailed info message for the application and exits. 90 | -- Beside component name, package name, version, revision, and copyright 91 | -- the message also contain information about the compiler that 92 | -- was used for the build, the build architecture, build flags, 93 | -- the author, the license type, and a list of all direct and 94 | -- indirect dependencies along with their licenses and copyrights. 95 | -- 96 | -- [@--license@] 97 | -- prints the text of the lincense of the application and exits. 98 | -- 99 | module Configuration.Utils.Setup 100 | ( main 101 | , mkPkgInfoModules 102 | ) where 103 | 104 | import qualified Distribution.Compat.Graph as Graph 105 | import qualified Distribution.InstalledPackageInfo as I 106 | import Distribution.PackageDescription 107 | import Distribution.Pretty 108 | import Distribution.Simple 109 | import Distribution.Simple.BuildPaths 110 | import Distribution.Simple.LocalBuildInfo 111 | import Distribution.Simple.PackageIndex 112 | import Distribution.Simple.Setup 113 | import Distribution.Simple.Utils (createDirectoryIfMissingVerbose) 114 | import Distribution.Text 115 | import Distribution.Utils.Path 116 | import Distribution.Utils.ShortText 117 | 118 | import System.Process 119 | 120 | import Control.Applicative 121 | import Control.Monad 122 | 123 | import qualified Data.ByteString as B 124 | import Data.ByteString.Char8 (pack) 125 | import Data.Char (isSpace) 126 | import Data.List (intercalate) 127 | import Data.Monoid 128 | 129 | import Prelude hiding (readFile, writeFile) 130 | 131 | import System.Directory 132 | ( canonicalizePath 133 | , doesDirectoryExist 134 | , doesFileExist 135 | , getCurrentDirectory 136 | ) 137 | import System.Exit (ExitCode(ExitSuccess)) 138 | #if MIN_VERSION_Cabal(3,14,0) 139 | import System.FilePath (isDrive, takeDirectory) 140 | #else 141 | import System.FilePath (isDrive, takeDirectory, ()) 142 | #endif 143 | 144 | -- | Include this function when your setup doesn't contain any 145 | -- extra functionality. 146 | -- 147 | main :: IO () 148 | main = defaultMainWithHooks (mkPkgInfoModules simpleUserHooks) 149 | 150 | -- | Modifies the given record of hooks by adding functionality that 151 | -- creates a package info module for each component of the cabal package. 152 | -- 153 | -- This function is intended for usage in more complex @Setup.hs@ scripts. 154 | -- If your setup doesn't contain any other function you can just import 155 | -- the 'main' function from this module. 156 | -- 157 | -- The modules are created in the /autogen/ build directories where also the 158 | -- @Path_@ modules are created by cabal's simple build setup. 159 | -- 160 | mkPkgInfoModules 161 | :: UserHooks 162 | -> UserHooks 163 | mkPkgInfoModules hooks = hooks 164 | { postConf = mkPkgInfoModulesPostConf (postConf hooks) 165 | } 166 | 167 | -- -------------------------------------------------------------------------- -- 168 | -- Compat Implementations 169 | 170 | prettyLicense :: I.InstalledPackageInfo -> String 171 | prettyLicense = either prettyShow prettyShow . I.license 172 | 173 | #if !MIN_VERSION_Cabal(3,14,0) 174 | interpretSymbolicPath :: Maybe () -> FilePath -> FilePath 175 | interpretSymbolicPath _ p = p 176 | #endif 177 | 178 | -- -------------------------------------------------------------------------- -- 179 | -- Cabal 2.0 180 | 181 | mkPkgInfoModulesPostConf 182 | :: (Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()) 183 | -> Args 184 | -> ConfigFlags 185 | -> PackageDescription 186 | -> LocalBuildInfo 187 | -> IO () 188 | mkPkgInfoModulesPostConf hook args flags pkgDesc bInfo = do 189 | mapM_ (updatePkgInfoModule pkgDesc bInfo flags) $ Graph.toList $ componentGraph bInfo 190 | hook args flags pkgDesc bInfo 191 | 192 | updatePkgInfoModule 193 | :: PackageDescription 194 | -> LocalBuildInfo 195 | -> ConfigFlags 196 | -> ComponentLocalBuildInfo 197 | -> IO () 198 | updatePkgInfoModule pkgDesc bInfo flags clbInfo = do 199 | createDirectoryIfMissingVerbose verbosity True dirName 200 | moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo 201 | updateFile fileName moduleBytes 202 | 203 | -- legacy module 204 | legacyModuleBytes <- pkgInfoModule legacyModuleName cName pkgDesc bInfo 205 | updateFile legacyFileName legacyModuleBytes 206 | where 207 | verbosity = fromFlag $ configVerbosity flags 208 | dirName = interpretSymbolicPath Nothing $ autogenComponentModulesDir bInfo clbInfo 209 | cName = unUnqualComponentName <$> componentNameString (componentLocalName clbInfo) 210 | moduleName = pkgInfoModuleName 211 | fileName = dirName moduleName <> ".hs" 212 | legacyModuleName = legacyPkgInfoModuleName cName 213 | legacyFileName = dirName legacyModuleName <> ".hs" 214 | 215 | -- -------------------------------------------------------------------------- -- 216 | -- Generate PkgInfo Module 217 | 218 | pkgInfoModuleName :: String 219 | pkgInfoModuleName = "PkgInfo" 220 | 221 | updateFile :: FilePath -> B.ByteString -> IO () 222 | updateFile fileName content = do 223 | x <- doesFileExist fileName 224 | if | not x -> update 225 | | otherwise -> do 226 | oldRevisionFile <- B.readFile fileName 227 | when (oldRevisionFile /= content) update 228 | where 229 | update = B.writeFile fileName content 230 | 231 | legacyPkgInfoModuleName :: Maybe String -> String 232 | legacyPkgInfoModuleName Nothing = "PkgInfo" 233 | legacyPkgInfoModuleName (Just cn) = "PkgInfo_" <> map tr cn 234 | where 235 | tr '-' = '_' 236 | tr c = c 237 | 238 | trim :: String -> String 239 | trim = f . f 240 | where f = reverse . dropWhile isSpace 241 | 242 | getVCS :: IO (Maybe KnownRepoType) 243 | getVCS = getCurrentDirectory >>= getVcsOfDir 244 | where 245 | getVcsOfDir d = do 246 | canonicDir <- canonicalizePath d 247 | doesDirectoryExist (canonicDir ".hg") >>= \x0 -> if x0 248 | then return (Just Mercurial) 249 | else doesDirectoryExist (canonicDir ".git") >>= \x1 -> if x1 250 | then return $ Just Git 251 | else if isDrive canonicDir 252 | then return Nothing 253 | else getVcsOfDir (takeDirectory canonicDir) 254 | 255 | pkgInfoModule 256 | :: String 257 | -> Maybe String 258 | -> PackageDescription 259 | -> LocalBuildInfo 260 | -> IO B.ByteString 261 | pkgInfoModule moduleName cName pkgDesc bInfo = do 262 | (tag, revision, branch) <- getVCS >>= \case 263 | Just Mercurial -> hgInfo 264 | Just Git -> gitInfo 265 | _ -> noVcsInfo 266 | 267 | let vcsBranch = if branch == "default" || branch == "master" then "" else branch 268 | vcsVersion = intercalate "-" . filter (/= "") $ [tag, revision, vcsBranch] 269 | flags = map (unFlagName . fst) . filter snd . unFlagAssignment . configConfigurationsFlags . configFlags $ bInfo 270 | 271 | licenseString <- licenseFilesText pkgDesc 272 | 273 | return $ B.intercalate "\n" 274 | [ "{-# LANGUAGE OverloadedStrings #-}" 275 | , "{-# LANGUAGE RankNTypes #-}" 276 | , "" 277 | , "module " <> pack moduleName <> " " <> deprecatedMsg <> " where" 278 | , "" 279 | , " import Data.String (IsString)" 280 | , " import Data.Monoid" 281 | , " import Prelude hiding ((<>))" 282 | , "" 283 | , " name :: IsString a => Maybe a" 284 | , " name = " <> maybe "Nothing" (\x -> "Just \"" <> pack x <> "\"") cName 285 | , "" 286 | , " tag :: IsString a => a" 287 | , " tag = \"" <> pack tag <> "\"" 288 | , "" 289 | , " revision :: IsString a => a" 290 | , " revision = \"" <> pack revision <> "\"" 291 | , "" 292 | , " branch :: IsString a => a" 293 | , " branch = \"" <> pack branch <> "\"" 294 | , "" 295 | , " branch' :: IsString a => a" 296 | , " branch' = \"" <> pack vcsBranch <> "\"" 297 | , "" 298 | , " vcsVersion :: IsString a => a" 299 | , " vcsVersion = \"" <> pack vcsVersion <> "\"" 300 | , "" 301 | , " compiler :: IsString a => a" 302 | , " compiler = \"" <> (pack . display . compilerId . compiler) bInfo <> "\"" 303 | , "" 304 | , " flags :: IsString a => [a]" 305 | , " flags = " <> (pack . show) flags 306 | , "" 307 | , " optimisation :: IsString a => a" 308 | , " optimisation = \"" <> (displayOptimisationLevel . withOptimization) bInfo <> "\"" 309 | , "" 310 | , " arch :: IsString a => a" 311 | , " arch = \"" <> (pack . display . hostPlatform) bInfo <> "\"" 312 | , "" 313 | , " license :: IsString a => a" 314 | , " license = \"" <> (pack . prettyShow . license) pkgDesc <> "\"" 315 | , "" 316 | , " licenseText :: IsString a => a" 317 | , " licenseText = " <> (pack . show) licenseString 318 | , "" 319 | , " copyright :: IsString a => a" 320 | , " copyright = " <> (pack . show . copyright) pkgDesc 321 | , "" 322 | , " author :: IsString a => a" 323 | , " author = \"" <> (pack . fromShortText . author) pkgDesc <> "\"" 324 | , "" 325 | , " homepage :: IsString a => a" 326 | , " homepage = \"" <> (pack . fromShortText . homepage) pkgDesc <> "\"" 327 | , "" 328 | , " package :: IsString a => a" 329 | , " package = \"" <> (pack . display . package) pkgDesc <> "\"" 330 | , "" 331 | , " packageName :: IsString a => a" 332 | , " packageName = \"" <> (pack . display . packageName) pkgDesc <> "\"" 333 | , "" 334 | , " packageVersion :: IsString a => a" 335 | , " packageVersion = \"" <> (pack . display . packageVersion) pkgDesc <> "\"" 336 | , "" 337 | , " dependencies :: IsString a => [a]" 338 | , " dependencies = " <> (pack . show . map (display . packageId) . allPackages . installedPkgs) bInfo 339 | , "" 340 | , " dependenciesWithLicenses :: IsString a => [a]" 341 | , " dependenciesWithLicenses = " <> (pack . show . map pkgIdWithLicense . allPackages . installedPkgs) bInfo 342 | , "" 343 | , " versionString :: (Monoid a, IsString a) => a" 344 | , " versionString = case name of" 345 | , " Nothing -> package <> \" (revision \" <> vcsVersion <> \")\"" 346 | , " Just n -> n <> \"-\" <> packageVersion <> \" (package \" <> package <> \" revision \" <> vcsVersion <> \")\"" 347 | , "" 348 | , " info :: (Monoid a, IsString a) => a" 349 | , " info = versionString <> \"\\n\" <> copyright" 350 | , "" 351 | , " longInfo :: (Monoid a, IsString a) => a" 352 | , " longInfo = info <> \"\\n\\n\"" 353 | , " <> \"Author: \" <> author <> \"\\n\"" 354 | , " <> \"License: \" <> license <> \"\\n\"" 355 | , " <> \"Homepage: \" <> homepage <> \"\\n\"" 356 | , " <> \"Build with: \" <> compiler <> \" (\" <> arch <> \")\" <> \"\\n\"" 357 | , " <> \"Build flags: \" <> mconcat (map (\\x -> \" \" <> x) flags) <> \"\\n\"" 358 | , " <> \"Optimisation: \" <> optimisation <> \"\\n\\n\"" 359 | , " <> \"Dependencies:\\n\" <> mconcat (map (\\x -> \" \" <> x <> \"\\n\") dependenciesWithLicenses)" 360 | , "" 361 | , " pkgInfo :: (Monoid a, IsString a) => (a, a, a, a)" 362 | , " pkgInfo =" 363 | , " ( info" 364 | , " , longInfo" 365 | , " , versionString" 366 | , " , licenseText" 367 | , " )" 368 | , "" 369 | ] 370 | where 371 | displayOptimisationLevel NoOptimisation = "none" 372 | displayOptimisationLevel NormalOptimisation = "normal" 373 | displayOptimisationLevel MaximumOptimisation = "maximum" 374 | 375 | deprecatedMsg = if moduleName /= pkgInfoModuleName 376 | then "{-# DEPRECATED \"Update to Cabal 2.0 or later and use just PkgInfo as module name.\" #-}" 377 | else "" 378 | 379 | licenseFilesText :: PackageDescription -> IO B.ByteString 380 | licenseFilesText pkgDesc = 381 | B.intercalate "\n------------------------------------------------------------\n" <$> mapM fileTextStr 382 | (licenseFiles pkgDesc) 383 | where 384 | fileText file = doesFileExist file >>= \x -> if x 385 | then B.readFile file 386 | else return "" 387 | fileTextStr = fileText . getSymbolicPath 388 | 389 | 390 | hgInfo :: IO (String, String, String) 391 | hgInfo = do 392 | tag <- trim <$> readProcess "hg" ["id", "-r", "max(ancestors(\".\") and tag())", "-t"] "" 393 | rev <- trim <$> readProcess "hg" ["id", "-i"] "" 394 | branch <- trim <$> readProcess "hg" ["id", "-b"] "" 395 | return (tag, rev, branch) 396 | 397 | gitInfo :: IO (String, String, String) 398 | gitInfo = do 399 | tag <- do 400 | (exitCode, out, _err) <- readProcessWithExitCode "git" ["describe", "--exact-match", "--tags", "--abbrev=0"] "" 401 | case exitCode of 402 | ExitSuccess -> return $ trim out 403 | _ -> return "" 404 | rev <- trim <$> readProcess "git" ["rev-parse", "--short", "HEAD"] "" 405 | branch <- trim <$> readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "" 406 | return (tag, rev, branch) 407 | 408 | noVcsInfo :: IO (String, String, String) 409 | noVcsInfo = return ("", "", "") 410 | 411 | pkgIdWithLicense :: I.InstalledPackageInfo -> String 412 | pkgIdWithLicense a = (display . packageId) a 413 | ++ " [" 414 | ++ prettyLicense a 415 | ++ (if cr /= "" then ", " ++ cr else "") 416 | ++ "]" 417 | where 418 | cr = (unwords . words . fromShortText . I.copyright) a 419 | -------------------------------------------------------------------------------- /src/Configuration/Utils/Validation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE UnicodeSyntax #-} 8 | 9 | -- | 10 | -- Module: Configuration.Utils.Validation 11 | -- Copyright: Copyright © 2014 AlephCloud Systems, Inc. 12 | -- License: MIT 13 | -- Maintainer: Lars Kuhtz 14 | -- Stability: experimental 15 | -- 16 | -- Utilities for validating configuration values 17 | -- 18 | module Configuration.Utils.Validation 19 | ( ConfigValidation 20 | , ConfigValidation' 21 | 22 | -- * Networking 23 | , validateHttpOrHttpsUrl 24 | , validateHttpUrl 25 | , validateHttpsUrl 26 | , validateUri 27 | , validateAbsoluteUri 28 | , validateAbsoluteUriFragment 29 | , validateIPv4 30 | , validateIPv6 31 | , validatePort 32 | 33 | -- * Monoids, Foldables and Co 34 | , validateNonEmpty 35 | , validateLength 36 | , validateMinLength 37 | , validateMaxLength 38 | , validateMinMaxLength 39 | 40 | -- * Files 41 | , validateFilePath 42 | , validateFile 43 | , validateFileReadable 44 | , validateFileWritable 45 | , validateExecutable 46 | , validateDirectory 47 | , validateConfigFile 48 | 49 | -- * Boolean Values 50 | , validateFalse 51 | , validateTrue 52 | , validateBool 53 | 54 | -- * Numeric Values 55 | , validateNonNegative 56 | , validatePositive 57 | , validateNonPositive 58 | , validateNegative 59 | , validateNonNull 60 | 61 | -- * Orders 62 | , validateLess 63 | , validateLessEq 64 | , validateGreater 65 | , validateGreaterEq 66 | , validateRange 67 | ) where 68 | 69 | import Configuration.Utils.Internal 70 | 71 | import Control.Monad.Error.Class 72 | import Control.Monad 73 | import Control.Monad.IO.Class 74 | import Control.Monad.Writer.Class 75 | 76 | import qualified Data.Foldable as F 77 | import Data.Monoid.Unicode 78 | import qualified Data.Text as T 79 | 80 | import Network.URI 81 | 82 | import Prelude.Unicode 83 | 84 | import System.Directory 85 | 86 | -- | A validation function. The type in the 'MonadWriter' is excpected to 87 | -- be a 'Foldable' structure for collecting warnings. 88 | -- 89 | type ConfigValidation a f = ConfigValidation' a f () 90 | type ConfigValidation' a f r = ∀ m . (MonadIO m, Functor m, Applicative m, MonadError T.Text m, MonadWriter (f T.Text) m) ⇒ a → m r 91 | 92 | -- -------------------------------------------------------------------------- -- 93 | -- Networking 94 | 95 | -- | Validates that a value is an HTTP or HTTPS URL 96 | -- 97 | validateHttpOrHttpsUrl 98 | ∷ MonadError T.Text m 99 | ⇒ T.Text 100 | -- ^ configuration property name that is used in the error message 101 | → String 102 | → m () 103 | validateHttpOrHttpsUrl configName uri = 104 | case parseURI uri of 105 | Nothing → throwError $ 106 | "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI" 107 | Just u → unless (uriScheme u ≡ "http:" || uriScheme u ≡ "https:") ∘ throwError $ 108 | "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not an HTTP or HTTPS URL" 109 | 110 | -- | Validates that a value is an HTTP URL 111 | -- 112 | validateHttpUrl 113 | ∷ MonadError T.Text m 114 | ⇒ T.Text 115 | -- ^ configuration property name that is used in the error message 116 | → String 117 | → m () 118 | validateHttpUrl configName uri = 119 | case parseURI uri of 120 | Nothing → throwError $ 121 | "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI" 122 | Just u → unless (uriScheme u ≡ "http:") ∘ throwError $ 123 | "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not an HTTP URL" 124 | 125 | -- | Validates that a value is an HTTPS URL 126 | -- 127 | validateHttpsUrl 128 | ∷ MonadError T.Text m 129 | ⇒ T.Text 130 | -- ^ configuration property name that is used in the error message 131 | → String 132 | → m () 133 | validateHttpsUrl configName uri = 134 | case parseURI uri of 135 | Nothing → throwError $ 136 | "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI" 137 | Just u → unless (uriScheme u ≡ "https:") ∘ throwError $ 138 | "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not an HTTPS URL" 139 | 140 | -- | Validates that a value is an URI without a fragment identifier 141 | -- 142 | validateUri 143 | ∷ MonadError T.Text m 144 | ⇒ T.Text 145 | -- ^ configuration property name that is used in the error message 146 | → String 147 | → m () 148 | validateUri configName uri = 149 | unless (isURIReference uri) ∘ throwError $ 150 | "The value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI" 151 | 152 | -- | Validates that a value is an absolute URI without a fragment identifier 153 | -- 154 | validateAbsoluteUri 155 | ∷ MonadError T.Text m 156 | ⇒ T.Text 157 | -- ^ configuration property name that is used in the error message 158 | → String 159 | → m () 160 | validateAbsoluteUri configName uri = 161 | unless (isAbsoluteURI uri) ∘ throwError $ 162 | "The value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI" 163 | 164 | -- | Validates that a value is an absolute URI with an optional fragment 165 | -- identifier 166 | -- 167 | validateAbsoluteUriFragment 168 | ∷ MonadError T.Text m 169 | ⇒ T.Text 170 | -- ^ configuration property name that is used in the error message 171 | → String 172 | → m () 173 | validateAbsoluteUriFragment configName uri = 174 | unless (isURI uri) ∘ throwError $ 175 | "The value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI" 176 | 177 | validateIPv4 178 | ∷ MonadError T.Text m 179 | ⇒ T.Text 180 | -- ^ configuration property name that is used in the error message 181 | → String 182 | → m () 183 | validateIPv4 configName ipv4 = 184 | unless (isIPv4address ipv4) ∘ throwError $ 185 | "The value " ⊕ T.pack ipv4 ⊕ " for " ⊕ configName ⊕ " is not a valid IPv4 address" 186 | 187 | validateIPv6 188 | ∷ MonadError T.Text m 189 | ⇒ T.Text 190 | -- ^ configuration property name that is used in the error message 191 | → String 192 | → m () 193 | validateIPv6 configName ipv6 = 194 | unless (isIPv6address ipv6) ∘ throwError $ 195 | "The value " ⊕ T.pack ipv6 ⊕ " for " ⊕ configName ⊕ " is not a valid IPv6 address" 196 | 197 | validatePort 198 | ∷ (MonadError T.Text m, Integral n, Show n) 199 | ⇒ T.Text 200 | -- ^ configuration property name that is used in the error message 201 | → n 202 | → m () 203 | validatePort configName p = 204 | unless (p > 1 && p < 65535) ∘ throwError $ 205 | "port value " ⊕ T.pack (show p) ⊕ " for " ⊕ configName ⊕ " is not valid port number" 206 | 207 | -- -------------------------------------------------------------------------- -- 208 | -- Monoids, Foldables, and Co 209 | 210 | validateNonEmpty 211 | ∷ (MonadError T.Text m, Eq a, Monoid a) 212 | ⇒ T.Text 213 | -- ^ configuration property name that is used in the error message 214 | → a 215 | → m () 216 | validateNonEmpty configName x = 217 | when (x ≡ mempty) ∘ throwError $ 218 | "value for " ⊕ configName ⊕ " must not be empty" 219 | 220 | validateLength 221 | ∷ (MonadError T.Text m, F.Foldable f) 222 | ⇒ T.Text 223 | -- ^ configuration property name that is used in the error message 224 | → Int 225 | -- ^ exact length of the validated value 226 | → f a 227 | → m () 228 | validateLength configName len x = 229 | unless (length (F.toList x) ≡ len) ∘ throwError $ 230 | "value for " ⊕ configName ⊕ " must be of length exactly " ⊕ sshow len 231 | 232 | validateMaxLength 233 | ∷ (MonadError T.Text m, F.Foldable f) 234 | ⇒ T.Text 235 | -- ^ configuration property name that is used in the error message 236 | → Int 237 | -- ^ maximum length of the validated value 238 | → f a 239 | → m () 240 | validateMaxLength configName u x = 241 | unless (length (F.toList x) ≤ u) ∘ throwError $ 242 | "value for " ⊕ configName ⊕ " must be of length at most " ⊕ sshow u 243 | 244 | validateMinLength 245 | ∷ (MonadError T.Text m, F.Foldable f) 246 | ⇒ T.Text 247 | -- ^ configuration property name that is used in the error message 248 | → Int 249 | -- ^ minimum length of the validated value 250 | → f a 251 | → m () 252 | validateMinLength configName l x = 253 | unless (length (F.toList x) ≥ l) ∘ throwError $ 254 | "value for " ⊕ configName ⊕ " must be of length at least " ⊕ sshow l 255 | 256 | validateMinMaxLength 257 | ∷ (MonadError T.Text m, F.Foldable f) 258 | ⇒ T.Text 259 | -- ^ configuration property name that is used in the error message 260 | → Int 261 | -- ^ minimum length of the validated value 262 | → Int 263 | -- ^ maximum length of the validated value 264 | → f a 265 | → m () 266 | validateMinMaxLength configName l u x = 267 | unless (len ≥ l && len ≤ u) ∘ throwError $ 268 | "the length of the value for " ⊕ configName ⊕ 269 | " must be at least " ⊕ sshow l ⊕ " and at most " ⊕ sshow u 270 | where 271 | len = length $ F.toList x 272 | 273 | -- -------------------------------------------------------------------------- -- 274 | -- Files 275 | 276 | validateFilePath 277 | ∷ MonadError T.Text m 278 | ⇒ T.Text 279 | -- ^ configuration property name that is used in the error message 280 | → FilePath 281 | → m () 282 | validateFilePath configName file = 283 | when (null file) ∘ throwError $ 284 | "file path for " ⊕ configName ⊕ " must not be empty" 285 | 286 | validateFile 287 | ∷ (MonadError T.Text m, MonadIO m) 288 | ⇒ T.Text 289 | -- ^ configuration property name that is used in the error message 290 | → FilePath 291 | → m () 292 | validateFile configName file = do 293 | exists ← liftIO $ doesFileExist file 294 | unless exists ∘ throwError $ 295 | "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " does not exist" 296 | 297 | validateFileReadable 298 | ∷ (MonadError T.Text m, MonadIO m) 299 | ⇒ T.Text 300 | -- ^ configuration property name that is used in the error message 301 | → FilePath 302 | → m () 303 | validateFileReadable configName file = do 304 | validateFile configName file 305 | liftIO (getPermissions file) >>= \x → unless (readable x) ∘ throwError $ 306 | "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " is not readable" 307 | 308 | validateFileWritable 309 | ∷ (MonadError T.Text m, MonadIO m) 310 | ⇒ T.Text 311 | -- ^ configuration property name that is used in the error message 312 | → FilePath 313 | → m () 314 | validateFileWritable configName file = do 315 | validateFile configName file 316 | liftIO (getPermissions file) >>= \x → unless (writable x) ∘ throwError $ 317 | "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " is not writable" 318 | 319 | validateFileExecutable 320 | ∷ (MonadError T.Text m, MonadIO m) 321 | ⇒ T.Text 322 | -- ^ configuration property name that is used in the error message 323 | → FilePath 324 | → m () 325 | validateFileExecutable configName file = do 326 | validateFile configName file 327 | liftIO (getPermissions file) >>= \x → unless (executable x) ∘ throwError $ 328 | "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " is not excutable" 329 | 330 | validateDirectory 331 | ∷ (MonadError T.Text m, MonadIO m) 332 | ⇒ T.Text 333 | -- ^ configuration property name that is used in the error message 334 | → FilePath 335 | → m () 336 | validateDirectory configName dir = do 337 | exists ← liftIO $ doesDirectoryExist dir 338 | unless exists ∘ throwError $ 339 | "the directory " ⊕ T.pack dir ⊕ " for " ⊕ configName ⊕ " does not exist" 340 | 341 | -- | Validates if the given executable name can be found in the system 342 | -- and can be executed. 343 | -- 344 | validateExecutable 345 | ∷ (Functor m, MonadError T.Text m, MonadIO m) 346 | ⇒ T.Text 347 | -- ^ configuration property name that is used in the error message 348 | → FilePath 349 | → m () 350 | validateExecutable configName file = do 351 | execFile ← (file <$ validateFile configName file) `catchError` \_ -> 352 | liftIO (findExecutable file) >>= \case 353 | Nothing → throwError $ 354 | "the executable " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " could not be found in the system;" 355 | ⊕ " you may check your SearchPath and PATH variable settings" 356 | Just f → return f 357 | validateFileExecutable configName execFile 358 | 359 | -- | Validate that the input is a config file 360 | -- 361 | validateConfigFile 362 | ∷ (MonadIO m, MonadError T.Text m) 363 | ⇒ String 364 | → m () 365 | validateConfigFile filepath = 366 | validateFileReadable "config-file" filepath 367 | #ifdef REMOTE_CONFIGS 368 | `catchError` \_ -> 369 | validateHttpOrHttpsUrl "config-file" filepath 370 | #endif 371 | 372 | -- -------------------------------------------------------------------------- -- 373 | -- Boolean Values 374 | 375 | validateFalse 376 | ∷ (MonadError T.Text m) 377 | ⇒ T.Text 378 | -- ^ configuration property name that is used in the error message 379 | → Bool 380 | → m () 381 | validateFalse configName = validateBool configName False 382 | 383 | validateTrue 384 | ∷ (MonadError T.Text m) 385 | ⇒ T.Text 386 | -- ^ configuration property name that is used in the error message 387 | → Bool 388 | → m () 389 | validateTrue configName = validateBool configName True 390 | 391 | validateBool 392 | ∷ (MonadError T.Text m) 393 | ⇒ T.Text 394 | -- ^ configuration property name that is used in the error message 395 | → Bool 396 | -- ^ expected value 397 | → Bool 398 | → m () 399 | validateBool configName expected x = unless (x ≡ expected) ∘ throwError $ 400 | "expected " ⊕ configName ⊕ " to be " ⊕ sshow expected ⊕ ", but was " ⊕ sshow x 401 | 402 | -- -------------------------------------------------------------------------- -- 403 | -- Numeric Values 404 | 405 | validateNonNegative 406 | ∷ (MonadError T.Text m, Ord a, Num a) 407 | ⇒ T.Text 408 | -- ^ configuration property name that is used in the error message 409 | → a 410 | → m () 411 | validateNonNegative configName x = 412 | when (x < 0) ∘ throwError $ 413 | "value for " ⊕ configName ⊕ " must not be negative" 414 | 415 | validatePositive 416 | ∷ (MonadError T.Text m, Ord a, Num a) 417 | ⇒ T.Text 418 | -- ^ configuration property name that is used in the error message 419 | → a 420 | → m () 421 | validatePositive configName x = 422 | when (x ≤ 0) ∘ throwError $ 423 | "value for " ⊕ configName ⊕ " must be positive" 424 | 425 | validateNonPositive 426 | ∷ (MonadError T.Text m, Ord a, Num a) 427 | ⇒ T.Text 428 | -- ^ configuration property name that is used in the error message 429 | → a 430 | → m () 431 | validateNonPositive configName x = 432 | when (x > 0) ∘ throwError $ 433 | "value for " ⊕ configName ⊕ " must not be positive" 434 | 435 | validateNegative 436 | ∷ (MonadError T.Text m, Ord a, Num a) 437 | ⇒ T.Text 438 | -- ^ configuration property name that is used in the error message 439 | → a 440 | → m () 441 | validateNegative configName x = 442 | when (x ≥ 0) ∘ throwError $ 443 | "value for " ⊕ configName ⊕ " must be negative" 444 | 445 | validateNonNull 446 | ∷ (MonadError T.Text m, Eq a, Num a) 447 | ⇒ T.Text 448 | -- ^ configuration property name that is used in the error message 449 | → a 450 | → m () 451 | validateNonNull configName x = when (x ≡ 0) ∘ throwError $ 452 | "value for " ⊕ configName ⊕ " must not be zero" 453 | 454 | -- -------------------------------------------------------------------------- -- 455 | -- Orders 456 | 457 | validateLess 458 | ∷ (MonadError T.Text m, Ord a, Show a) 459 | ⇒ T.Text 460 | -- ^ configuration property name that is used in the error message 461 | → a 462 | -- ^ a strict upper bound for the configuration value 463 | → a 464 | → m () 465 | validateLess configName upper x = unless (x < upper) ∘ throwError $ 466 | "value for " ⊕ configName ⊕ " must be strictly less than " ⊕ sshow upper ⊕ ", but was " ⊕ sshow x 467 | 468 | validateLessEq 469 | ∷ (MonadError T.Text m, Ord a, Show a) 470 | ⇒ T.Text 471 | -- ^ configuration property name that is used in the error message 472 | → a 473 | -- ^ a upper bound for the configuration value 474 | → a 475 | → m () 476 | validateLessEq configName upper x = unless (x ≤ upper) ∘ throwError $ 477 | "value for " ⊕ configName ⊕ " must be less or equal than " ⊕ sshow upper ⊕ ", but was " ⊕ sshow x 478 | 479 | validateGreater 480 | ∷ (MonadError T.Text m, Ord a, Show a) 481 | ⇒ T.Text 482 | -- ^ configuration property name that is used in the error message 483 | → a 484 | -- ^ a strict lower bound for the configuration value 485 | → a 486 | → m () 487 | validateGreater configName lower x = unless (x > lower) ∘ throwError $ 488 | "value for " ⊕ configName ⊕ " must be strictly greater than " ⊕ sshow lower ⊕ ", but was " ⊕ sshow x 489 | 490 | validateGreaterEq 491 | ∷ (MonadError T.Text m, Ord a, Show a) 492 | ⇒ T.Text 493 | -- ^ configuration property name that is used in the error message 494 | → a 495 | -- ^ a lower bound for the configuration value 496 | → a 497 | → m () 498 | validateGreaterEq configName lower x = unless (x ≥ lower) ∘ throwError $ 499 | "value for " ⊕ configName ⊕ " must be greater or equal than " ⊕ sshow lower ⊕ ", but was " ⊕ sshow x 500 | 501 | validateRange 502 | ∷ (MonadError T.Text m, Ord a, Show a) 503 | ⇒ T.Text 504 | -- ^ configuration property name that is used in the error message 505 | → (a, a) 506 | -- ^ the valid range for the configuration value 507 | → a 508 | → m () 509 | validateRange configName (lower,upper) x = unless (x ≥ lower ∧ x ≤ upper) ∘ throwError $ 510 | "value for " ⊕ configName ⊕ " must be within the range of (" ⊕ sshow lower ⊕ ", " ⊕ sshow upper ⊕ "), but was " ⊕ sshow x 511 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.6 2 | -------------------------------------------------------------------------------- /test/TestExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UnicodeSyntax #-} 9 | 10 | -- | 11 | -- Module: Main 12 | -- Copyright: Copyright © 2014-2015 AlephCloud Systems, Inc. 13 | -- License: MIT 14 | -- Maintainer: Lars Kuhtz 15 | -- Stability: experimental 16 | -- 17 | module Main 18 | ( main 19 | ) where 20 | 21 | import Tests.BoolOption 22 | import Tests.MonoidConfig 23 | import TestTools 24 | 25 | import Configuration.Utils 26 | import Configuration.Utils.Internal 27 | import Configuration.Utils.Internal.ConfigFileReader 28 | 29 | import Control.Monad 30 | 31 | import qualified Data.List as L 32 | import Data.Monoid.Unicode 33 | import qualified Data.Text as T 34 | import qualified Data.Text.IO as T 35 | 36 | import Example hiding (main) 37 | 38 | import Prelude.Unicode hiding ((×)) 39 | 40 | import PkgInfo 41 | 42 | -- -------------------------------------------------------------------------- -- 43 | -- main 44 | 45 | main ∷ IO () 46 | main = do 47 | 48 | -- run tests 49 | localResults ← sequence 50 | $ tests0 51 | ⊕ monoidUpdateTests pkgInfo 52 | ⊕ boolOptionTests pkgInfo 53 | localFileResults ← localFileTests 54 | remoteResults ← remoteTests 55 | helpResults ← helpTests 56 | 57 | -- report results 58 | let (successes, failures) = L.partition id 59 | $ localResults 60 | ⊕ remoteResults 61 | ⊕ localFileResults 62 | ⊕ helpResults 63 | 64 | T.putStrLn $ "success: " ⊕ sshow (length successes) 65 | T.putStrLn $ "failures: " ⊕ sshow (length failures) 66 | unless (length failures ≡ 0) $ error "test suite failed" 67 | 68 | -- -------------------------------------------------------------------------- -- 69 | -- Test categories 70 | 71 | helpTests ∷ IO [Bool] 72 | helpTests = 73 | withConfigFile Yaml config0 $ \tmpPath0 → 74 | withConfigFile Json config1Part $ \tmpPath1 → sequence 75 | $ testPrintHelp [tmpPath0, tmpPath1] 76 | 77 | localFileTests ∷ IO [Bool] 78 | localFileTests = concat <$> mapM run 79 | [ (Yaml, Yaml, "yaml-yaml-") 80 | , (Json, Json, "json-json-") 81 | , (Yaml, Json, "yaml-json-") 82 | , (Json, Yaml, "json-yaml-") 83 | ] 84 | where 85 | run (format1, format2, label) = 86 | withConfigFile format1 config0 $ \tmpPath0 → 87 | withConfigFile format2 config1Part $ \tmpPath1 → sequence 88 | $ testsConfigFile ("configFile-" ⊕ label) [tmpPath0, tmpPath1] 89 | ⊕ tests2Files1 ("local-" ⊕ label) [tmpPath0, tmpPath1] 90 | ⊕ tests2Files2 ("local-" ⊕ label) (tmpPath0) (tmpPath1) 91 | ⊕ tests2Files3 ("local-" ⊕ label) (tmpPath0) (tmpPath1) 92 | 93 | remoteTests ∷ IO [Bool] 94 | #ifdef REMOTE_CONFIGS 95 | remoteTests = concat <$> mapM run 96 | [ (Just Yaml, "yaml") 97 | , (Just Json, "json") 98 | ] 99 | where 100 | typedConfigs = [("config0", ConfigType config0), ("config1", ConfigType config1Part)] 101 | textConfigs = [("invalid", "invalid: invalid")] 102 | 103 | run (format, label) = withConfigFileServer typedConfigs textConfigs format $ \httpPort httpsPort → 104 | sequence 105 | % tests2Files2 ("remote-" ⊕ label) (serverUrl httpPort ⊕ "/config0") (serverUrl httpPort ⊕ "/config1") 106 | ⊕ tests2Files3 ("remote-" ⊕ label) (serverUrl httpPort ⊕ "/config0") (serverUrl httpPort ⊕ "/config1") 107 | ⊕ testsInvalidUrl httpPort 108 | ⊕ testsTlsUrl httpPort httpsPort 109 | #else 110 | remoteTests = return [] 111 | #endif 112 | 113 | -- -------------------------------------------------------------------------- -- 114 | -- Test Cases 115 | 116 | -- | This always succeeds. It prints the help message for manual 117 | -- inspection. 118 | -- 119 | testPrintHelp ∷ [T.Text] → [IO Bool] 120 | testPrintHelp files = 121 | [ runTest pkgInfo (mainInfoConfigFile configFiles) "print-help" False [trueAssertion ["-?"]] 122 | ] 123 | where 124 | configFiles = zipWith ($) (ConfigFileRequired : repeat ConfigFileOptional) files 125 | 126 | testsConfigFile ∷ T.Text → [T.Text] → [IO Bool] 127 | testsConfigFile prefix files = 128 | [ runTest pkgInfo (mainInfoConfigFile configFiles0) (prefix ⊕ "-1") True [trueAssertion []] 129 | , runTest pkgInfo (mainInfoConfigFile configFiles1) (prefix ⊕ "-2") False [trueAssertion []] 130 | ] 131 | where 132 | configFiles0 = zipWith ($) (ConfigFileRequired : repeat ConfigFileOptional) (files ⊕ ["./invalid"]) 133 | configFiles1 = zipWith ($) (ConfigFileRequired : repeat ConfigFileOptional) ("./invalid":files) 134 | 135 | #ifdef REMOTE_CONFIGS 136 | -- | Test with invalid remote URLs 137 | -- 138 | testsInvalidUrl ∷ Int → [IO Bool] 139 | testsInvalidUrl httpPort = 140 | [ runTest pkgInfo mainInfo "invalidUrl-0" False [x0, d1] 141 | , runTest pkgInfo mainInfo "invalidUrl-1" False [x1, d1] 142 | ] 143 | where 144 | x0 = trueAssertion ["--config-file=http://invalid"] 145 | x1 = trueAssertion ["--config-file=" ⊕ T.unpack (serverUrl httpPort) ⊕ "/invalid"] 146 | 147 | testsTlsUrl ∷ Int → Int → [IO Bool] 148 | testsTlsUrl httpPort httpsPort = 149 | [ runTest pkgInfo mainInfo "tlsUrl-0" True [cf0, f1 c0] 150 | , runTest pkgInfo mainInfo "tlsUrl-1" False [cf0t, f1 c0] 151 | , runTest pkgInfo mainInfo "tlsUrl-2" False [cf0tl, f1 c0] 152 | , runTest pkgInfo mainInfo "tlsUrl-3" False [cf0t, f1 c0, fingerF] 153 | , runTest pkgInfo mainInfo "tlsUrl-4" True [cf0t, f1 c0, fingerT] 154 | , runTest pkgInfo mainInfo "tlsUrl-5" True [insec, cf0, f1 c0] 155 | , runTest pkgInfo mainInfo "tlsUrl-6" True [insec, cf0t, f1 c0] 156 | ] 157 | where 158 | cf0 = trueAssertion ["--config-file=" ⊕ T.unpack (serverUrl httpPort) ⊕ "/config0"] 159 | cf0t = trueAssertion ["--config-file=" ⊕ T.unpack (serverTlsUrl httpsPort) ⊕ "/config0"] 160 | cf0tl = trueAssertion ["--config-file=" ⊕ "https://localhost:8284" ⊕ "/config0"] -- FIXME don't hardcode this 161 | insec = trueAssertion ["--config-https-insecure"] 162 | fingerF = trueAssertion ["--config-https-allow-cert=" ⊕ drop 8 (T.unpack $ serverTlsUrl httpsPort) ⊕ ":0x+SV6/D6JSIKK8pPCpaMZvMXelXb2CnJ8xWo8qi4Fo="] 163 | fingerT = trueAssertion ["--config-https-allow-cert=" ⊕ drop 8 (T.unpack $ serverTlsUrl httpsPort) ⊕ ":HK4/ZeG/3c+H5R/3eTlysmJxmrBil6w8oLdvOdHFlsg="] 164 | c0 = config0 165 | #endif 166 | 167 | -- -------------------------------------------------------------------------- -- 168 | -- Tests with two configuration files 169 | 170 | -- | Tests with two configuration files 171 | -- 172 | tests2Files1 ∷ T.Text → [T.Text] → [IO Bool] 173 | tests2Files1 prefix files = 174 | twoFileCasesC0C1 (prefix ⊕ "2files-1-") files (trueAssertion []) 175 | ⊕ twoFileCasesC1C0 (prefix ⊕ "2files-1-") selif (trueAssertion []) 176 | where 177 | selif = reverse files 178 | 179 | -- | Tests with two configuration files 180 | -- 181 | tests2Files2 182 | ∷ T.Text 183 | -- ^ test label suffix 184 | → T.Text 185 | -- ^ file for config0 186 | → T.Text 187 | -- ^ file for config1 188 | → [IO Bool] 189 | tests2Files2 suffix file0 file1 = 190 | twoFileCasesC0C1 ("2files-2-" ⊕ suffix) [file0] x1 191 | ⊕ twoFileCasesC1C0 ("2files-2-" ⊕ suffix) [file1] x0 192 | where 193 | x0 = trueAssertion ["--config-file=" ⊕ T.unpack file0] 194 | x1 = trueAssertion ["--config-file=" ⊕ T.unpack file1] 195 | 196 | -- | Tests with two configuration files 197 | -- 198 | tests2Files3 199 | ∷ T.Text 200 | -- ^ test label suffix 201 | → T.Text 202 | -- ^ file for config0 203 | → T.Text 204 | -- ^ file for config1 205 | → [IO Bool] 206 | tests2Files3 suffix file0 file1 = 207 | twoFileCasesC0C1 ("2files-3-" ⊕ suffix) [] x01 208 | ⊕ twoFileCasesC1C0 ("2files-3-" ⊕ suffix) [] x10 209 | where 210 | x01 = trueAssertion ["--config-file=" ⊕ T.unpack file0, "--config-file=" ⊕ T.unpack file1] 211 | x10 = trueAssertion ["--config-file=" ⊕ T.unpack file1, "--config-file=" ⊕ T.unpack file0] 212 | 213 | -- | Tests with two configuration files c0 then c1 214 | -- 215 | twoFileCasesC0C1 ∷ T.Text → [T.Text] → ConfAssertion HttpURL → [IO Bool] 216 | twoFileCasesC0C1 prefix files x = 217 | [ runf files (prefix ⊕ "c0c1-0") True [x, f1 c1, f2 c0, f3 c1, f4 c0] 218 | , runf files (prefix ⊕ "c0c1-1") False [x, f1 c0] 219 | , runf files (prefix ⊕ "c0c1-2") False [x, d1] 220 | , runf files (prefix ⊕ "c0c1-3") False [x, f3 c0] 221 | , runf files (prefix ⊕ "c0c1-4") False [x, d4] 222 | ] 223 | where 224 | c0 = config0 225 | c1 = config1 226 | runf = runTest pkgInfo ∘ mainInfoConfigFile ∘ map ConfigFileRequired 227 | 228 | -- | Tests with two configuration files c1 then c0 229 | -- 230 | twoFileCasesC1C0 ∷ T.Text → [T.Text] → ConfAssertion HttpURL → [IO Bool] 231 | twoFileCasesC1C0 prefix files x = 232 | [ runf files (prefix ⊕ "c1c0-0") True [x, f1 c0, f2 c0, f3 c0, f4 c0] 233 | , runf files (prefix ⊕ "c1c0-1") False [x, f1 c1] 234 | , runf files (prefix ⊕ "c1c0-2") False [x, f2 c1] 235 | , runf files (prefix ⊕ "c1c0-3") False [x, f3 c1] 236 | , runf files (prefix ⊕ "c1c0-4") False [x, f4 c1] 237 | ] 238 | where 239 | c0 = config0 240 | c1 = config1 241 | runf = runTest pkgInfo ∘ mainInfoConfigFile ∘ map ConfigFileRequired 242 | 243 | -- -------------------------------------------------------------------------- -- 244 | -- Command Line argument tests 245 | 246 | -- | Command Line argument test 247 | -- 248 | tests0 ∷ [IO Bool] 249 | tests0 = 250 | [ run "test0" False [d1, d2, d3, d4] 251 | 252 | , run "test1" True [t0, d2, d3, d4] 253 | , run "test2" True [t1, d2, d3, d4] 254 | , run "test3" True [d1, t2, d3, d4] 255 | , run "test4" False [d1, d2, t3, d4] 256 | , run "test5" False [d1, d2, d3, t4] 257 | 258 | , run "test6" False [t0, t1, d2, d3, d4] 259 | , run "test7" True [t0, t2, d3, d4] 260 | , run "test8" True [t0, d2, t3, d4] 261 | , run "test9" True [t0, d2, d3, t4] 262 | , run "test10" True [t1, t2, d3, d4] 263 | , run "test11" True [t1, d2, t3, d4] 264 | , run "test12" True [t1, d2, d3, t4] 265 | , run "test13" True [d1, t2, t3, d4] 266 | , run "test14" True [d1, t2, d3, t4] 267 | , run "test15" False [d1, d2, t3, t4] 268 | 269 | , run "test16" False [t0, t1, t2, d3, d4] 270 | , run "test17" False [t0, t1, t3, d4] 271 | , run "test18" False [t0, t1, d3, t4] 272 | , run "test19" True [t0, t2, t3, d4] 273 | , run "test20" True [t0, t2, d3, t4] 274 | , run "test21" True [t0, d2, t3, t4] 275 | , run "test22" True [t1, t2, t3, d4] 276 | , run "test23" True [t1, t2, d3, t4] 277 | , run "test24" True [t1, d2, t3, t4] 278 | , run "test25" True [d1, t2, t3, t4] 279 | 280 | , run "test26" False [t0, t1, t2, t3, d4] 281 | , run "test27" False [t0, t1, t2, d3, t4] 282 | , run "test28" False [t0, t1, d2, t3, t4] 283 | , run "test29" True [t0, t2, t3, t4] 284 | , run "test30" True [t1, t2, t3, t4] 285 | 286 | , run "test31" False [t0, t1, t2, t3, t4] 287 | ] 288 | where 289 | run = runTest pkgInfo mainInfo 290 | 291 | -- -------------------------------------------------------------------------- -- 292 | -- Test Data 293 | 294 | -- | Test configuration 0 295 | -- 296 | config0 ∷ HttpURL 297 | config0 = defaultHttpURL 298 | { _domain = "f0_localhost" 299 | , _path = "f0_path" 300 | , _auth = defaultAuth 301 | { _user = "f0_user" 302 | , _pwd = "f0_pwd" 303 | } 304 | } 305 | 306 | -- | Test configuration 1 307 | -- 308 | config1 ∷ HttpURL 309 | config1 = defaultHttpURL 310 | { _domain = "f1_localhost" 311 | , _path = "f1_path" 312 | , _auth = defaultAuth 313 | { _user = "f1_user" 314 | , _pwd = "f1_pwd" 315 | } 316 | } 317 | 318 | -- | A partial version of configuration 1 319 | -- 320 | config1Part ∷ Value 321 | config1Part = object 322 | [ "domain" .= view domain config1 323 | , "auth" .= object 324 | [ "user" .= view (auth ∘ user) config1 325 | ] 326 | ] 327 | 328 | mainInfo ∷ ProgramInfoValidate HttpURL [] 329 | mainInfo = programInfoValidate "HTTP URL" pHttpURL defaultHttpURL validateHttpURL 330 | 331 | mainInfoConfigFile 332 | ∷ [ConfigFile] 333 | → ProgramInfoValidate HttpURL [] 334 | mainInfoConfigFile files = set piConfigurationFiles files mainInfo 335 | 336 | -- -------------------------------------------------------------------------- -- 337 | -- Building blocks for tests 338 | 339 | -- assert values from given configuration 340 | 341 | f1 ∷ HttpURL → ConfAssertion HttpURL 342 | f1 conf = ConfAssertion [] domain (view domain conf) 343 | 344 | f2 ∷ HttpURL → ConfAssertion HttpURL 345 | f2 conf = ConfAssertion [] path (view path conf) 346 | 347 | f3 ∷ HttpURL → ConfAssertion HttpURL 348 | f3 conf = ConfAssertion [] (auth ∘ user) (view (auth ∘ user) conf) 349 | 350 | f4 ∷ HttpURL → ConfAssertion HttpURL 351 | f4 conf = ConfAssertion [] (auth ∘ pwd) (view (auth ∘ pwd) conf) 352 | 353 | -- assert default values 354 | 355 | d1 ∷ ConfAssertion HttpURL 356 | d1 = f1 defaultHttpURL 357 | 358 | d2 ∷ ConfAssertion HttpURL 359 | d2 = f2 defaultHttpURL 360 | 361 | d3 ∷ ConfAssertion HttpURL 362 | d3 = f3 defaultHttpURL 363 | 364 | d4 ∷ ConfAssertion HttpURL 365 | d4 = f4 defaultHttpURL 366 | 367 | -- assert values from command line 368 | 369 | -- t0 and t1 are the same option 370 | t0 ∷ ConfAssertion HttpURL 371 | t0 = ConfAssertion ["--domain=c_localhost"] domain "c_localhost" 372 | 373 | t1 ∷ ConfAssertion HttpURL 374 | t1 = ConfAssertion ["-d", "c_localhost"] domain "c_localhost" 375 | 376 | t2 ∷ ConfAssertion HttpURL 377 | t2 = ConfAssertion ["--path=c_abc"] path "c_abc" 378 | 379 | t3 ∷ ConfAssertion HttpURL 380 | t3 = ConfAssertion ["--user=c_u"] (auth ∘ user) "c_u" 381 | 382 | t4 ∷ ConfAssertion HttpURL 383 | t4 = ConfAssertion ["--pwd=c_pwd"] (auth ∘ pwd) "c_pwd" 384 | -------------------------------------------------------------------------------- /test/TestTools.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE NoMonomorphismRestriction #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE UnicodeSyntax #-} 10 | 11 | -- | 12 | -- Module: TestTools 13 | -- Description: Tools for testing program configurations 14 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 15 | -- License: MIT 16 | -- Maintainer: Lars Kuhtz 17 | -- Stability: experimental 18 | -- 19 | -- Tools for testing program configurations 20 | -- 21 | module TestTools 22 | ( 23 | -- * Very Simple Debugging 24 | enableDebug 25 | , debug 26 | 27 | -- * Configuration Assertions for Testing 28 | , ConfAssertion(..) 29 | , trueLens 30 | , trueAssertion 31 | 32 | -- * Test Execution 33 | , check 34 | , runTest 35 | 36 | -- * Test Configuration Files 37 | , withConfigFile 38 | , withConfigFileText 39 | #ifdef REMOTE_CONFIGS 40 | , ConfigType(..) 41 | , serverUrl 42 | , serverTlsUrl 43 | , withConfigFileServer 44 | #endif 45 | ) where 46 | 47 | import Configuration.Utils 48 | import Configuration.Utils.Internal 49 | import Configuration.Utils.Internal.ConfigFileReader 50 | 51 | import Control.Exception 52 | import Control.Monad 53 | 54 | import qualified Data.ByteString.Char8 as B8 55 | import qualified Data.ByteString.Lazy as LB 56 | import Data.IORef 57 | import Data.Monoid.Unicode 58 | import qualified Data.Text as T 59 | import qualified Data.Text.IO as T 60 | import qualified Data.Yaml as Yaml 61 | 62 | import Distribution.Simple.Utils (withTempFile) 63 | 64 | import Prelude.Unicode hiding ((×)) 65 | 66 | import System.Environment 67 | import System.IO 68 | 69 | #ifdef REMOTE_CONFIGS 70 | import Control.Concurrent 71 | import qualified Data.List as L 72 | import Data.Maybe 73 | import qualified Data.Text.Encoding as T 74 | import qualified Network.Wai as WAI 75 | import qualified Network.Wai.Handler.Warp as WARP 76 | import qualified Network.Wai.Handler.WarpTLS as WARP 77 | import qualified Network.HTTP.Types as HTTP 78 | import Network.Socket (close) 79 | #endif 80 | 81 | -- -------------------------------------------------------------------------- -- 82 | -- Very Simple Debugging 83 | 84 | enableDebug ∷ Bool 85 | enableDebug = False 86 | 87 | debug 88 | ∷ Monad m 89 | ⇒ m () 90 | → m () 91 | debug a 92 | | enableDebug = a 93 | | otherwise = return () 94 | 95 | -- -------------------------------------------------------------------------- -- 96 | -- Configuration Assertions for Testing 97 | 98 | -- | Specify a assertion about the parsed configuration 99 | -- 100 | -- The parameters are 101 | -- 102 | -- 1. list of command line arguments, 103 | -- 2. lens for the configuration value 104 | -- 3. the expected value 105 | -- 106 | data ConfAssertion b = ∀ a . Eq a ⇒ ConfAssertion [String] (Lens' b a) a 107 | 108 | trueLens ∷ Lens' b () 109 | trueLens = lens (const ()) const 110 | 111 | trueAssertion ∷ [String] → ConfAssertion b 112 | trueAssertion args = ConfAssertion args trueLens () 113 | 114 | -- -------------------------------------------------------------------------- -- 115 | -- Test execution 116 | 117 | -- Check the given list of assertions for the given configuration value 118 | -- 119 | check 120 | ∷ a 121 | → [ConfAssertion a] 122 | → IO Bool 123 | check conf assertions = 124 | foldM (\a (b,n) → (&& a) <$> go b n) True $ zip assertions [0 ∷ Int ..] 125 | where 126 | go (ConfAssertion _ l v) n = 127 | if view l conf ≡ v 128 | then do 129 | debug ∘ T.putStrLn $ "DEBUG: assertion " ⊕ sshow n ⊕ " succeeded" 130 | return True 131 | else do 132 | debug ∘ T.putStrLn $ "DEBUG: assertion " ⊕ sshow n ⊕ " failed" 133 | return False 134 | 135 | -- | Run a test with an expected outcome ('True' or 'False') 136 | -- for a given that of assertions. 137 | -- 138 | runTest 139 | ∷ (FromJSON (a → a), ToJSON a) 140 | ⇒ PkgInfo 141 | → ProgramInfoValidate a [] 142 | → T.Text 143 | -- ^ label for the test case 144 | → Bool 145 | -- ^ expected outcome 146 | → [ConfAssertion a] 147 | -- ^ test assertions 148 | → IO Bool 149 | runTest pkgInfo mInfo label succeed assertions = do 150 | 151 | debug ∘ T.putStrLn $ "\nDEBUG: ======> " ⊕ label 152 | 153 | debug ∘ T.putStrLn $ "DEBUG: runWithPkgInfoConfiguration" 154 | a ← run $ runWithPkgInfoConfiguration mInfo pkgInfo 155 | 156 | debug ∘ T.putStrLn $ "DEBUG: runWithConfiguration" 157 | b ← run $ runWithConfiguration mInfo 158 | 159 | if a ≡ b && succeed ≡ (a && b) 160 | then 161 | return True 162 | else do 163 | T.putStrLn $ "WARNING: test " ⊕ label ⊕ " failed" 164 | return False 165 | where 166 | run f = do 167 | ref ← newIORef False 168 | handle (handler ref) $ withArgs args ∘ f $ \conf → 169 | writeIORef ref =<< check conf assertions 170 | readIORef ref 171 | 172 | args = concatMap (\(ConfAssertion x _ _) → x) assertions 173 | 174 | handler ref (e ∷ SomeException) = do 175 | writeIORef ref False 176 | debug ∘ T.putStrLn $ "DEBUG: caught exception: " ⊕ sshow e 177 | 178 | -- -------------------------------------------------------------------------- -- 179 | -- Test Config Files 180 | -- 181 | 182 | withConfigFile 183 | ∷ ToJSON b 184 | ⇒ ConfigFileFormat 185 | → b 186 | → (T.Text → IO a) 187 | → IO a 188 | withConfigFile format config inner = 189 | withTempFile "." ("tmp_TestExample." ⊕ suffix format) $ \tmpPath tmpHandle → do 190 | B8.hPutStrLn tmpHandle ∘ formatter format $ config 191 | hClose tmpHandle 192 | inner $ T.pack tmpPath 193 | where 194 | suffix Json = "json" 195 | suffix _ = "yaml" 196 | formatter Json = LB.toStrict ∘ encode 197 | formatter _ = Yaml.encode 198 | 199 | withConfigFileText 200 | ∷ T.Text 201 | → (T.Text → IO a) 202 | → IO a 203 | withConfigFileText configText inner = 204 | withTempFile "." "tmp_TestExample.txt" $ \tmpPath tmpHandle → do 205 | T.hPutStrLn tmpHandle configText 206 | hClose tmpHandle 207 | inner $ T.pack tmpPath 208 | 209 | 210 | #ifdef REMOTE_CONFIGS 211 | data ConfigType = ∀ a . ToJSON a ⇒ ConfigType a 212 | 213 | instance ToJSON ConfigType where 214 | toJSON (ConfigType a) = toJSON a 215 | 216 | withConfigFileServer 217 | ∷ [(T.Text, ConfigType)] 218 | → [(T.Text, T.Text)] 219 | → Maybe ConfigFileFormat 220 | → (Int → Int → IO a) 221 | → IO a 222 | withConfigFileServer configs configTexts maybeFormat inner = 223 | WARP.testWithApplication (return app) $ \httpPort → 224 | bracket WARP.openFreePort (close ∘ snd) $ \(httpsPort, sock) → do 225 | s ← forkIO $ WARP.runTLSSocket tlsSettings (warpSettings httpsPort) sock app 226 | inner httpPort httpsPort `finally` killThread s 227 | where 228 | app req respond = do 229 | 230 | let format = fromMaybe Other $ maybeFormat 231 | <|> (contentType <$> L.lookup HTTP.hAccept % WAI.requestHeaders req) 232 | 233 | maybeBody = LB.fromStrict <$> do 234 | p ← listToMaybe $ WAI.pathInfo req 235 | do 236 | formatter format <$> lookup p configs 237 | <|> 238 | (T.encodeUtf8 <$> lookup p configTexts) 239 | 240 | respond $ case maybeBody of 241 | Just body → WAI.responseLBS HTTP.status200 [] body 242 | Nothing → WAI.responseLBS HTTP.status404 [contentTypeHeader format] "resource not found" 243 | 244 | formatter Json = LB.toStrict ∘ encode 245 | formatter _ = Yaml.encode 246 | 247 | contentTypeHeader Json = (HTTP.hContentType, head jsonMimeType) 248 | contentTypeHeader _ = (HTTP.hContentType, head yamlMimeType) 249 | 250 | serverUrl ∷ Int → T.Text 251 | serverUrl serverPort = "http://127.0.0.1:" ⊕ sshow serverPort 252 | 253 | serverTlsUrl ∷ Int → T.Text 254 | serverTlsUrl serverTlsPort = "https://127.0.0.1:" ⊕ sshow serverTlsPort 255 | 256 | tlsSettings ∷ WARP.TLSSettings 257 | tlsSettings = WARP.tlsSettingsMemory serverCert serverKey 258 | 259 | warpSettings ∷ Int → WARP.Settings 260 | warpSettings port = WARP.setPort port WARP.defaultSettings 261 | 262 | serverCert ∷ B8.ByteString 263 | serverCert = B8.unlines 264 | [ "-----BEGIN CERTIFICATE-----" 265 | , "MIIF5TCCA82gAwIBAgIJAPT8MspOLMHrMA0GCSqGSIb3DQEBCwUAMFQxCzAJBgNV" 266 | , "BAYTAlVTMRMwEQYDVQQIEwpTb21lLVN0YXRlMRwwGgYDVQQKExNjb25maWd1cmF0" 267 | , "aW9uLXRvb2xzMRIwEAYDVQQDEwlsb2NhbGhvc3QwIBcNMTUwMjAzMjMzNjIyWhgP" 268 | , "MjExNTAxMTAyMzM2MjJaMFQxCzAJBgNVBAYTAlVTMRMwEQYDVQQIEwpTb21lLVN0" 269 | , "YXRlMRwwGgYDVQQKExNjb25maWd1cmF0aW9uLXRvb2xzMRIwEAYDVQQDEwlsb2Nh" 270 | , "bGhvc3QwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCtXCeoaw1m+JaX" 271 | , "qJnxKdOelNJxuZxPFoNN2tNIxY+63H6yH9XkhDw1bTPsTv2YX0ZdNxGHprh2a5jP" 272 | , "Z5gUh2EUsPnSNhnVhAGef3Y2gfAxeT1k81Ap4IKhBq9Drmlg7uJOPkqBkUhMi675" 273 | , "pVtxb2oSOrH4wkJD9n47dGSl2ziuUejfhzc0oZcVEs/w90KFkfNvTYXzSJfjU+WJ" 274 | , "KX2h0VI3m33lBbreyGktoccImF6+gHNKC0m+L74MyfLzu3TDlg7a+YwEOhCu2Tbf" 275 | , "kdPcSvSW0xEo9yn4epcGL+bRLXsT8DYQSE0q7sJf0I6y+nespoPCpfWnWinKbs7n" 276 | , "xNDl7wfD4spYcV19lgAicv7l1W+ItB3A/8KOSD+a7bc5LY7svKwBPV5ZQ4jRkvoa" 277 | , "Efcztv7i89/CjurCm3TX2oespTqCUOKYlc61NQQ9l//2yoBPY2IvBKUOPpDHSyn+" 278 | , "ZuMKdNu0mzdTHDjsbNW/es2n8Uk1wG+bQ60ZWCkixJZ/SCECBJpt1qkkgh9iclh+" 279 | , "abTBXBSU+N8DmyO9UACV9LlsBkKxjfK4F+mlodgP5C9R6nPlpYB7W9cuLvIWQnuR" 280 | , "DSnW6fS1T0g77mXMFeB8bjnADq7dM3aQXisvkX/XGT1KfsJdTqoau3dFMYArFpx9" 281 | , "0LqEh6pmt2rkNfFNPHnSx/hzVKr0ZwIDAQABo4G3MIG0MB0GA1UdDgQWBBRPlQCM" 282 | , "ToNUODspmRtqhXHcidXpRDCBhAYDVR0jBH0we4AUT5UAjE6DVDg7KZkbaoVx3InV" 283 | , "6UShWKRWMFQxCzAJBgNVBAYTAlVTMRMwEQYDVQQIEwpTb21lLVN0YXRlMRwwGgYD" 284 | , "VQQKExNjb25maWd1cmF0aW9uLXRvb2xzMRIwEAYDVQQDEwlsb2NhbGhvc3SCCQD0" 285 | , "/DLKTizB6zAMBgNVHRMEBTADAQH/MA0GCSqGSIb3DQEBCwUAA4ICAQAJfpa2Ju9j" 286 | , "Om7M5U9cQUZaYKqKe2N6+fx4y7C6J9oHAVjXzhevPm307I7MyVWpzh8+AShEnzyY" 287 | , "R83M8hL61cMOCjU3YOl6exz1jUYHXKhj0chl18z6wDM9o8NkoG4iFDbEipAtciKm" 288 | , "UbU+vm2d9z6mC+VN6xPVa9S72/+dRvyIgkPl3hQOZ5wKYic/7/EXM0MldQ7gb6KO" 289 | , "UuYDlr5aEHvF1J8Fnju5RzVofCPbC2obiwJN3RnYYFJv5pybQdnYfBg4z8OzgiQf" 290 | , "V/OVndzqyHWLg21MxPExM/PHFyuzeAh6e3lu6F1XhwoA4H8UzN1Gei2B8HfNQ54O" 291 | , "xyzeBu+kdPPzC0xQFm/s80CG+OPhtTd2ka6N2/YwgMSL6QOTQ1J7zpIwfsIgCaNH" 292 | , "Fkjj0gJk82+URMwjMhyh6m49qwhanL/9yodmascr27o10ZmAq6570C+zqaUoVk8y" 293 | , "m/PMNTHMLsSddjkelAKSjVU9+PQDRgnZTPiNhpEswgAbF8UjNkyxBRjBUrBIEGWd" 294 | , "k+PNgjOH3HPT3nWXYyTNTjAJQ7D5RVwFiROMdHdZdFjaxjRQpRkMvR/rpEdsf89H" 295 | , "75OZcCJzjg03soMUQ+ySp8Ax2Z6PSC1Cbvu+P+aOB0lyNpMYFuL0LVq5iWb6GmcB" 296 | , "5wxh9JKKsOVBhPDpOQlEAyRqtdXGbOwHNg==" 297 | , "-----END CERTIFICATE-----" 298 | ] 299 | 300 | serverKey ∷ B8.ByteString 301 | serverKey = B8.unlines 302 | [ "-----BEGIN RSA PRIVATE KEY-----" 303 | , "MIIJKAIBAAKCAgEArVwnqGsNZviWl6iZ8SnTnpTScbmcTxaDTdrTSMWPutx+sh/V" 304 | , "5IQ8NW0z7E79mF9GXTcRh6a4dmuYz2eYFIdhFLD50jYZ1YQBnn92NoHwMXk9ZPNQ" 305 | , "KeCCoQavQ65pYO7iTj5KgZFITIuu+aVbcW9qEjqx+MJCQ/Z+O3Rkpds4rlHo34c3" 306 | , "NKGXFRLP8PdChZHzb02F80iX41PliSl9odFSN5t95QW63shpLaHHCJhevoBzSgtJ" 307 | , "vi++DMny87t0w5YO2vmMBDoQrtk235HT3Er0ltMRKPcp+HqXBi/m0S17E/A2EEhN" 308 | , "Ku7CX9COsvp3rKaDwqX1p1opym7O58TQ5e8Hw+LKWHFdfZYAInL+5dVviLQdwP/C" 309 | , "jkg/mu23OS2O7LysAT1eWUOI0ZL6GhH3M7b+4vPfwo7qwpt019qHrKU6glDimJXO" 310 | , "tTUEPZf/9sqAT2NiLwSlDj6Qx0sp/mbjCnTbtJs3Uxw47GzVv3rNp/FJNcBvm0Ot" 311 | , "GVgpIsSWf0ghAgSabdapJIIfYnJYfmm0wVwUlPjfA5sjvVAAlfS5bAZCsY3yuBfp" 312 | , "paHYD+QvUepz5aWAe1vXLi7yFkJ7kQ0p1un0tU9IO+5lzBXgfG45wA6u3TN2kF4r" 313 | , "L5F/1xk9Sn7CXU6qGrt3RTGAKxacfdC6hIeqZrdq5DXxTTx50sf4c1Sq9GcCAwEA" 314 | , "AQKCAgBnaupdlj9QhkuP/YyYSZNsrus73LZal9uMvlX8u56aop8SM9utjxU76gFn" 315 | , "n1e5ZlzbjtZuTg8M1fM7B1m6JWjMpybhOFUBAtbUbsVejvVzDhiJ+HyB/uTumsZD" 316 | , "YfCLWva2JoLb+Idg4pNnajW63fQxG8K/22McmBeF8FF6f+S4WTTK5CcSxrMSZz6V" 317 | , "SWvtsru+UkjucQfrHUl5Ib9IoU6izae00E5CSNw11KSfhAZBLu+X5FQBmQmPJ4o/" 318 | , "zDxD0WjbSLM2ck0xgXMyvBPe/vgaYZ+DCK+JA9jEYB8Z+j/KDSqzW+5tBjH+ZrQ6" 319 | , "ISDzZgKEQ+zgAPGdSa00pjzYblf6jy2WUDwB38EtecuIxswmfuwWbSX0VGU2Pujl" 320 | , "2V/JonJv/j23MsRjYxcrgfZowdbSjFJtxkHRZiHvguKMZ+2hp23PonwLRe33zqSV" 321 | , "PE3YLy/R5wjN7EMUCccVqKb4VdOrIBl6sfZGzoGymE4Fq6x0+ueWuwammiNeegi2" 322 | , "UXAj93c8kBnfIh6397bfMgM6nLY/NK/igtO4cjuOP2aZpUD0oDzHDTkf+E9Ezavs" 323 | , "HDqMMuIgxHlKRmWAaw5LIWHsVYpekt9x9zuvb3lCMYOu2gr6XlxLR0L9SPR38uMG" 324 | , "WJNgo11qt5LCeFdXLBqP5WhqCb7yW2/BLiZM3ihSV/Yn5aZegQKCAQEA5bwEbZke" 325 | , "UxSljlz7UChbHAeHXrMN7t0+RueRE1hn5pMdZLTaLiUA+qnaCAgWWeeNqUnTRGpN" 326 | , "DD1/+0D3+5XDNtQiw93vIM/eXBN2HVzqKcPBggPmoIY99/e3vi+VYT8PQt0Sd+Tw" 327 | , "tfkGNpMen2F+YNWBg9NGtwAs1xDDrzLVD1c4gAxfAv2noywBbkRbn/UQbhcd6ebl" 328 | , "2DDKJVbZiCSnGAx2nZupet/R1W6fGWqYNv5+Gd/XRhrtwOdLEU6WqE3xN0VWK06y" 329 | , "D3fR6wPkScZM2UXupgsZyJMPVdb68mah+skOx0wZMWxYzmzDWaDm1kwlmP8FZBtr" 330 | , "jY3BtKdKza5X6QKCAQEAwS4kQUAkMzyzdScp8TV9dZnvf3QsajB5pTFfsWiGmkzx" 331 | , "kQQVvIX7L70Phh+oIHxaWhxxWw7J2G1QZu/bnrv+nDviGHo+ZEqY+7mPY/AVC3f4" 332 | , "i2mLAj61c+p2HtlFo0ZPntTClXHWR+jsA2z+zk2L2LxmvJFdfngOaHkAT5pg34CT" 333 | , "bJJMucNs0efEiGNgPCTIaZNPH5HW2lHPTOreRFImh843WsS0iLkWG9gMz6F5jkNr" 334 | , "ReGpJ3432dq91xot0iJ4Qo9cAEo8rra1BgbeJC7IIeLUt8Ud7lDGdTkzPMajqItO" 335 | , "jat/veec0+9tWzrUu/F6hBWrLtH8Q94ug2pNseaHzwKCAQB79HurKv/qsew2KUNM" 336 | , "V8n5ELLgzNnKtUNh/JYRixTcmyoz6UUDuuGRXk4PIVX2AnM0EWpVssmJvjEsvzxO" 337 | , "Wdsv3Tw41Kmu2ZnPsox7gWOzTzU80qAAow4Smm1gx8ng46Z3XFMXr8aVWR0aGz1d" 338 | , "n7wRwYGVQE0adpS7IgeDo3jEQzpwFLy7H2PxLdBDz8xkPVU1IXH5f6UqhgC8LuVG" 339 | , "iQhDeI4Tsia67sMIVxyvGQ2yNpSRn25HHEaGXAXr+6xceVmaieXZjieTIwJ3vOzT" 340 | , "RZS3cv02SC0MRRT0Kv/SBMCHUS6RKCU7vosYLiUlWiTTIdjzeT5OamEYypDmyZEZ" 341 | , "82TpAoIBABX5iLg/cp69dfCKrvO4UPgytZK7BV5i+0N2VVtZ943P2N7VJx/V4dfx" 342 | , "WrW4Hijr3F9Jwv9HtGBBNxcui74HxpPBIBwGs9g2wCZKWmxU4B/42rYJIH314jA4" 343 | , "aI1jy88h7Wa07xmO5IAzl71gBbA0FAdojws+QfNj9sedlBJ6DjD+cEa2cbHj8BoE" 344 | , "kk+tdkIBMScJUcPWlCkrizhFs1j0O1vRcmyJ2bt/ymsKbZKk3K35L1e4rsRGUFYg" 345 | , "0t2IJdQ0hZeUtTN3PmXldLwlxdk51Rw9sFLjQl9couasxg5Qzkca6aml65cPpMBb" 346 | , "CQaKr65dbsFdsaZWzqptuL7MNeBZx/MCggEBALqzujabof6VsX1+BrBeV6iz7VNV" 347 | , "ECHRaxDH7BIfLXWcP++nZH8nboBjnm7vE8ZBx7m8v1I2uWPQ/pkeClcRmtVeo+PW" 348 | , "Q9ITFaAmfMiJx/2VzOt9Ze5DT35kTyx4nt5dZ7znnSTqEvP2AEB8GY8zP6yy61Pd" 349 | , "Yw0cd2Buw0NqmWOIK83WSv44g7+maAkv4Jph5YA0lM3tQPwuKNFWNK2oOT5P911j" 350 | , "2GQMvNO99jq+FAf7XEL4WAZj+KOk0RBPa82dg8xTUMXEFhYHPhVfOpEZU3H099pM" 351 | , "Oo6zONyBMHTJazFr6atuwRR6RFRzHmMaJ0K72FBuHb4F31X+yOTSKT8rea0=" 352 | , "-----END RSA PRIVATE KEY-----" 353 | ] 354 | #endif 355 | -------------------------------------------------------------------------------- /test/Tests/BoolOption.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE UnicodeSyntax #-} 7 | 8 | -- | 9 | -- Module: Tests.BoolOption 10 | -- Description: Tests for 'boolOption' and 'boolOption_' 11 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 12 | -- License: MIT 13 | -- Maintainer: Lars Kuhtz 14 | -- Stability: experimental 15 | -- 16 | -- load in ghci with: 17 | -- 18 | -- > ghci -isrc -idist/build/autogen -itest -iexamples -DREMOTE_CONFIGS test/TestExample.hs 19 | -- 20 | module Tests.BoolOption 21 | ( mainA 22 | , boolOptionTests 23 | ) where 24 | 25 | import Configuration.Utils 26 | import Configuration.Utils.Internal 27 | import TestTools 28 | 29 | import Data.Monoid.Unicode 30 | 31 | -- -------------------------------------------------------------------------- -- 32 | -- Setup 33 | 34 | data A = A 35 | { _a ∷ !Bool 36 | , _b ∷ !Bool 37 | , _c ∷ !Bool 38 | } 39 | deriving (Show, Read, Eq, Ord) 40 | 41 | a ∷ Lens' A Bool 42 | a = lens _a $ \s x → s { _a = x } 43 | 44 | b ∷ Lens' A Bool 45 | b = lens _b $ \s x → s { _b = x } 46 | 47 | c ∷ Lens' A Bool 48 | c = lens _c $ \s x → s { _c = x } 49 | 50 | defaultA ∷ A 51 | defaultA = A True True True 52 | 53 | pA ∷ MParser A 54 | pA = id 55 | <$< a .:: boolOption_ 56 | % long "a" 57 | ⊕ short 'a' 58 | ⊕ help "a flag" 59 | <*< b .:: boolOption 60 | % long "b" 61 | ⊕ short 'b' 62 | ⊕ help "b flag" 63 | <*< c .:: enableDisableFlag 64 | % long "c" 65 | ⊕ long "c_" 66 | ⊕ short 'd' -- 'c' is taken by --config-file 67 | ⊕ help "c flag" 68 | 69 | instance ToJSON A where 70 | toJSON A{..} = object 71 | [ "a" .= _a 72 | , "b" .= _b 73 | , "c" .= _c 74 | ] 75 | 76 | instance FromJSON (A → A) where 77 | parseJSON = withObject "A" $ \o → id 78 | <$< a ..: "a" % o 79 | <*< b ..: "b" % o 80 | <*< c ..: "c" % o 81 | 82 | infoA ∷ ProgramInfo A 83 | infoA = programInfo "BoolOptionTest" pA (A True True True) 84 | 85 | infoA_ ∷ ProgramInfo A 86 | infoA_ = programInfo "BoolOptionTest" pA (A False False False) 87 | 88 | mainA ∷ IO () 89 | mainA = runWithConfiguration infoA print 90 | 91 | -- -------------------------------------------------------------------------- -- 92 | -- Tests 93 | 94 | da ∷ ConfAssertion A 95 | da = ConfAssertion [] a $ _a defaultA 96 | 97 | db ∷ ConfAssertion A 98 | db = ConfAssertion [] b $ _b defaultA 99 | 100 | dc ∷ ConfAssertion A 101 | dc = ConfAssertion [] c $ _c defaultA 102 | 103 | boolOptionTests ∷ PkgInfo → [IO Bool] 104 | boolOptionTests pkgInfo = atests ⊕ btests ⊕ ctests ⊕ ctests_ 105 | where 106 | atests = 107 | [ runA 1 True [da, db, dc] 108 | , runA 2 True [ConfAssertion ["--a"] a True] 109 | , runA 3 True [ConfAssertion ["-a"] a True] 110 | , runA 4 False [ConfAssertion ["-no-a"] a True] 111 | 112 | , runA 5 False [ConfAssertion ["--a=true"] a True] 113 | , runA 6 False [ConfAssertion ["--a=false"] a False] 114 | , runA 7 False [ConfAssertion ["--a", "true"] a True] 115 | , runA 8 False [ConfAssertion ["--a", "false"] a False] 116 | 117 | , runA 9 True [ConfAssertion ["--no-a"] a False] 118 | , runA 10 False [ConfAssertion ["--no-a=true"] a True] 119 | , runA 11 False [ConfAssertion ["--no-a=false"] a False] 120 | , runA 12 False [ConfAssertion ["--no-a", "true"] a True] 121 | , runA 13 False [ConfAssertion ["--no-a", "false"] a False] 122 | 123 | , runA 14 True [ConfAssertion ["-a"] a True] 124 | , runA 15 False [ConfAssertion ["-a=true"] a True] 125 | , runA 16 False [ConfAssertion ["-a=false"] a False] 126 | , runA 17 False [ConfAssertion ["-a", "true"] a True] 127 | , runA 18 False [ConfAssertion ["-a", "false"] a False] 128 | ] 129 | 130 | btests = 131 | [ runB 1 False [ConfAssertion ["--b"] b True] 132 | , runB 2 False [ConfAssertion ["-b"] b True] 133 | , runB 3 False [ConfAssertion ["-no-b"] b True] 134 | 135 | , runB 4 True [ConfAssertion ["--b=true"] b True] 136 | , runB 5 True [ConfAssertion ["--b=false"] b False] 137 | , runB 6 True [ConfAssertion ["--b", "true"] b True] 138 | , runB 7 True [ConfAssertion ["--b", "false"] b False] 139 | 140 | , runB 8 False [ConfAssertion ["-b=true"] b True] 141 | , runB 9 False [ConfAssertion ["-b=false"] b False] 142 | , runB 10 True [ConfAssertion ["-b", "true"] b True] 143 | , runB 12 True [ConfAssertion ["-b", "false"] b False] 144 | 145 | , runB 13 True [ConfAssertion ["--b=TRUE"] b True] 146 | , runB 14 True [ConfAssertion ["--b=FALSE"] b False] 147 | , runB 15 True [ConfAssertion ["--b", "TRUE"] b True] 148 | , runB 16 True [ConfAssertion ["--b", "FALSE"] b False] 149 | 150 | , runB 17 True [ConfAssertion ["--b=True"] b True] 151 | , runB 18 True [ConfAssertion ["--b=False"] b False] 152 | , runB 19 True [ConfAssertion ["--b", "True"] b True] 153 | , runB 20 True [ConfAssertion ["--b", "False"] b False] 154 | ] 155 | 156 | ctests = 157 | [ runC 1 True [da, db, dc] 158 | , runC 2 False [ConfAssertion ["--c"] c True] 159 | , runC 3 False [ConfAssertion ["--c_"] c True] 160 | , runC 4 False [ConfAssertion ["--c"] c False] 161 | , runC 5 False [ConfAssertion ["--c_"] c False] 162 | , runC 6 True [ConfAssertion ["--enable-c"] c True] 163 | , runC 7 True [ConfAssertion ["--enable-c_"] c True] 164 | , runC 8 True [ConfAssertion ["-d"] c True] 165 | , runC 9 False [ConfAssertion ["-disable-c"] c False] 166 | , runC 10 False [ConfAssertion ["-disable-c"] c True] 167 | , runC 9 False [ConfAssertion ["-disable-d"] c False] 168 | , runC 10 False [ConfAssertion ["-disable-d"] c True] 169 | , runC 10 False [ConfAssertion ["--disable-d"] c False] 170 | , runC 11 True [ConfAssertion ["--disable-c"] c False] 171 | , runC 12 True [ConfAssertion ["--disable-c_"] c False] 172 | ] 173 | 174 | ctests_ = 175 | [ runC_ 1 False [da, db, dc] 176 | , runC_ 2 False [ConfAssertion ["--c"] c True] 177 | , runC_ 3 False [ConfAssertion ["--c_"] c True] 178 | , runC_ 4 False [ConfAssertion ["--c"] c False] 179 | , runC_ 5 False [ConfAssertion ["--c_"] c False] 180 | , runC_ 6 True [ConfAssertion ["--enable-c"] c True] 181 | , runC_ 7 True [ConfAssertion ["--enable-c_"] c True] 182 | , runC_ 8 True [ConfAssertion ["-d"] c True] 183 | , runC_ 9 False [ConfAssertion ["-disable-c"] c False] 184 | , runC_ 10 False [ConfAssertion ["-disable-c"] c True] 185 | , runC_ 11 True [ConfAssertion ["--disable-c"] c False] 186 | , runC_ 12 True [ConfAssertion ["--disable-c_"] c False] 187 | ] 188 | 189 | runA (x ∷ Int) = runTest pkgInfo infoA ("boolOption-a-" ⊕ sshow x) 190 | runB (x ∷ Int) = runTest pkgInfo infoA ("boolOption-b-" ⊕ sshow x) 191 | 192 | runC (x ∷ Int) = runTest pkgInfo infoA ("boolOption-c1-" ⊕ sshow x) 193 | runC_ (x ∷ Int) = runTest pkgInfo infoA_ ("boolOption-c2-" ⊕ sshow x) 194 | -------------------------------------------------------------------------------- /test/Tests/MonoidConfig.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE UnicodeSyntax #-} 8 | 9 | -- | 10 | -- Module: Tests.MonoidConfig 11 | -- Description: Test cases for monoidal configuration types 12 | -- Copyright: Copyright © 2015 PivotCloud, Inc. 13 | -- License: MIT 14 | -- Maintainer: Lars Kuhtz 15 | -- Stability: experimental 16 | -- 17 | module Tests.MonoidConfig 18 | ( monoidUpdateTests 19 | ) where 20 | 21 | import TestTools 22 | 23 | import Configuration.Utils 24 | import Configuration.Utils.Internal 25 | import Configuration.Utils.Internal.ConfigFileReader 26 | import Configuration.Utils.Validation 27 | 28 | import Data.Bifunctor 29 | import qualified Data.HashMap.Strict as HM 30 | import Data.Monoid.Unicode 31 | import Data.String 32 | import qualified Data.Text as T 33 | 34 | import Prelude.Unicode hiding ((×)) 35 | 36 | -- -------------------------------------------------------------------------- -- 37 | -- Test cases 38 | 39 | monoidUpdateTests ∷ PkgInfo → [IO Bool] 40 | monoidUpdateTests pkgInfo = concatMap ($ pkgInfo) 41 | [ routingTableTests 42 | , textAppendTestsR 43 | , textAppendTestsFilesR 44 | , textAppendTestsL 45 | , textAppendTestsFilesL 46 | ] 47 | 48 | -- -------------------------------------------------------------------------- -- 49 | -- HashMap 50 | 51 | newtype RoutingTable = RoutingTable { _routingTableMap ∷ HM.HashMap T.Text T.Text } 52 | 53 | routingTableMap ∷ Lens' RoutingTable (HM.HashMap T.Text T.Text) 54 | routingTableMap = lens _routingTableMap $ \a b → a { _routingTableMap = b } 55 | 56 | defaultRoutingTable ∷ RoutingTable 57 | defaultRoutingTable = RoutingTable HM.empty 58 | 59 | instance ToJSON RoutingTable where 60 | toJSON RoutingTable{..} = object 61 | [ "route_map" .= _routingTableMap 62 | ] 63 | 64 | instance FromJSON (RoutingTable → RoutingTable) where 65 | parseJSON = withObject "RoutingTable" $ \o → id 66 | <$< routingTableMap . fromLeftMonoidalUpdate %.: "route_map" % o 67 | 68 | pRoutingTable ∷ MParser RoutingTable 69 | pRoutingTable = routingTableMap %:: pLeftMonoidalUpdate pRoute 70 | where 71 | pRoute = option (eitherReader readRoute) 72 | % long "route" 73 | ⊕ help "add a route to the routing table; the APIROUTE part must not contain a colon character" 74 | ⊕ metavar "APIROUTE:APIURL" 75 | 76 | readRoute s = case break (== ':') s of 77 | (a,':':b) → first T.unpack $ do 78 | validateNonEmpty "APIROUTE" a 79 | validateHttpOrHttpsUrl "APIURL" b 80 | return $ HM.singleton (T.pack a) (T.pack b) 81 | _ → Left "missing colon between APIROUTE and APIURL" 82 | 83 | mainInfoRoutingTable ∷ ProgramInfoValidate RoutingTable [] 84 | mainInfoRoutingTable = programInfoValidate "Routing Table" pRoutingTable defaultRoutingTable (const $ return ()) 85 | 86 | -- Test Cases 87 | 88 | routingTableTests ∷ PkgInfo → [IO Bool] 89 | routingTableTests pkgInfo = 90 | [ run 0 [ConfAssertion ["--route=a:" ⊕ b0] (routingTableMap ∘ at "a") $ Just b0] 91 | , run 1 [ConfAssertion ["--route=a:" ⊕ b0, "--route=a:" ⊕ b1] (routingTableMap ∘ at "a") $ Just b1] 92 | , run 2 [ConfAssertion ["--route=a:" ⊕ b0, "--route=a:" ⊕ b1] (routingTableMap ∘ at "a") $ Just b1] 93 | , run 3 [ConfAssertion ["--route=a:" ⊕ b0, "--route=b:" ⊕ b1] (routingTableMap ∘ at "a") $ Just b0] 94 | , run 4 [ConfAssertion ["--route=a:" ⊕ b0, "--route=b:" ⊕ b1] (routingTableMap ∘ at "b") $ Just b1] 95 | , run 5 [ConfAssertion ["--route=a:" ⊕ b0, "--route=b:" ⊕ b1] (routingTableMap ∘ at "c") Nothing] 96 | ] 97 | where 98 | b0,b1 ∷ IsString a ⇒ a 99 | b0 = "http://b0" 100 | b1 = "https://b1" 101 | run (x ∷ Int) = runTest pkgInfo mainInfoRoutingTable ("routing-table-" ⊕ sshow x) True 102 | 103 | at k f m = f mv <&> \r → case r of 104 | Nothing → maybe m (const (HM.delete k m)) mv 105 | Just v' → HM.insert k v' m 106 | where 107 | mv = HM.lookup k m 108 | 109 | -- -------------------------------------------------------------------------- -- 110 | -- Text with right append 111 | 112 | newtype StringConfigR = StringConfigR { _stringConfigR ∷ T.Text } 113 | 114 | stringConfigR ∷ Lens' StringConfigR T.Text 115 | stringConfigR = lens _stringConfigR $ \a b → a { _stringConfigR = b } 116 | 117 | defaultStringConfigR ∷ StringConfigR 118 | defaultStringConfigR = StringConfigR "|" 119 | 120 | instance ToJSON StringConfigR where 121 | toJSON StringConfigR{..} = object 122 | [ "string" .= _stringConfigR 123 | ] 124 | 125 | instance FromJSON (StringConfigR → StringConfigR) where 126 | parseJSON = withObject "StringConfigR" $ \o → id 127 | <$< stringConfigR . fromRightMonoidalUpdate %.: "string" % o 128 | 129 | pStringConfigR ∷ MParser StringConfigR 130 | pStringConfigR = stringConfigR %:: pRightMonoidalUpdate pString 131 | where 132 | pString = T.pack <$> strOption % long "string" 133 | 134 | -- Test cases 135 | 136 | textAppendTestsR ∷ PkgInfo → [IO Bool] 137 | textAppendTestsR pkgInfo = 138 | [ run 0 True [ConfAssertion [] stringConfigR "|"] 139 | , run 1 True [ConfAssertion ["--string=a"] stringConfigR "|a"] 140 | 141 | , run 2 True [ConfAssertion ["--string=a", "--string=b"] stringConfigR "|ab"] 142 | , run 3 False [ConfAssertion ["--string=a", "--string=b"] stringConfigR "|ba"] 143 | , run 4 False [ConfAssertion ["--string=b", "--string=a"] stringConfigR "|ab"] 144 | , run 5 True [ConfAssertion ["--string=b", "--string=a"] stringConfigR "|ba"] 145 | 146 | , run 6 False [ConfAssertion ["--string=aaa", "--string=bbb"] stringConfigR "|bbbaaa"] 147 | , run 7 True [ConfAssertion ["--string=aaa", "--string=bbb"] stringConfigR "|aaabbb"] 148 | , run 8 True [ConfAssertion ["--string=bbb", "--string=aaa"] stringConfigR "|bbbaaa"] 149 | , run 9 False [ConfAssertion ["--string=bbb", "--string=aaa"] stringConfigR "|aaabbb"] 150 | ] 151 | where 152 | run (x ∷ Int) = runTest pkgInfo mi ("stringR-" ⊕ sshow x) 153 | mi = programInfoValidate "Text right append" pStringConfigR defaultStringConfigR (const $ return ()) 154 | 155 | textAppendTestsFilesR ∷ PkgInfo → [IO Bool] 156 | textAppendTestsFilesR pkgInfo = 157 | [ run ca 0 True [ConfAssertion [] stringConfigR "|a"] 158 | 159 | , run ca 2 True [ConfAssertion ["--string=b"] stringConfigR "|ab"] 160 | , run ca 3 False [ConfAssertion ["--string=b"] stringConfigR "|ba"] 161 | , run cb 4 False [ConfAssertion ["--string=a"] stringConfigR "|ab"] 162 | , run cb 5 True [ConfAssertion ["--string=a"] stringConfigR "|ba"] 163 | 164 | , run2 ca ca 6 True [ConfAssertion [] stringConfigR "|aa"] 165 | , run2 ca cb 6 False [ConfAssertion [] stringConfigR "|ba"] 166 | , run2 ca cb 7 True [ConfAssertion [] stringConfigR "|ab"] 167 | , run2 cb ca 8 True [ConfAssertion [] stringConfigR "|ba"] 168 | , run2 cb ca 9 False [ConfAssertion [] stringConfigR "|ab"] 169 | ] 170 | where 171 | ca = StringConfigR "a" 172 | cb = StringConfigR "b" 173 | run c (x ∷ Int) b a = withConfigFile Yaml c $ \file → 174 | runTest pkgInfo (mi [file]) ("stringR-file1-" ⊕ sshow x) b a 175 | 176 | run2 c0 c1 (x ∷ Int) b a = 177 | withConfigFile Json c0 $ \file0 → 178 | withConfigFile Yaml c1 $ \file1 → 179 | runTest pkgInfo (mi [file0,file1]) ("stringR-file2-" ⊕ sshow x) b a 180 | 181 | mi files = set piConfigurationFiles (map ConfigFileRequired files) $ 182 | programInfoValidate "Text right append with files" pStringConfigR defaultStringConfigR (const $ return ()) 183 | 184 | -- -------------------------------------------------------------------------- -- 185 | -- Text with left append 186 | 187 | newtype StringConfigL = StringConfigL { _stringConfigL ∷ T.Text } 188 | 189 | stringConfigL ∷ Lens' StringConfigL T.Text 190 | stringConfigL = lens _stringConfigL $ \a b → a { _stringConfigL = b } 191 | 192 | defaultStringConfigL ∷ StringConfigL 193 | defaultStringConfigL = StringConfigL "|" 194 | 195 | instance ToJSON StringConfigL where 196 | toJSON StringConfigL{..} = object 197 | [ "string" .= _stringConfigL 198 | ] 199 | 200 | instance FromJSON (StringConfigL → StringConfigL) where 201 | parseJSON = withObject "StringConfigL" $ \o → id 202 | <$< stringConfigL . fromLeftMonoidalUpdate %.: "string" % o 203 | 204 | pStringConfigL ∷ MParser StringConfigL 205 | pStringConfigL = stringConfigL %:: pLeftMonoidalUpdate pString 206 | where 207 | pString = T.pack <$> strOption % long "string" 208 | 209 | -- Test cases 210 | 211 | textAppendTestsL ∷ PkgInfo → [IO Bool] 212 | textAppendTestsL pkgInfo = 213 | [ run 0 True [ConfAssertion [] stringConfigL "|"] 214 | , run 1 True [ConfAssertion ["--string=a"] stringConfigL "a|"] 215 | 216 | , run 2 True [ConfAssertion ["--string=a", "--string=b"] stringConfigL "ba|"] 217 | , run 3 False [ConfAssertion ["--string=a", "--string=b"] stringConfigL "ab|"] 218 | , run 4 False [ConfAssertion ["--string=b", "--string=a"] stringConfigL "ba|"] 219 | , run 5 True [ConfAssertion ["--string=b", "--string=a"] stringConfigL "ab|"] 220 | 221 | , run 6 True [ConfAssertion ["--string=aaa", "--string=bbb"] stringConfigL "bbbaaa|"] 222 | , run 7 False [ConfAssertion ["--string=aaa", "--string=bbb"] stringConfigL "aaabbb|"] 223 | , run 8 False [ConfAssertion ["--string=bbb", "--string=aaa"] stringConfigL "bbbaaa|"] 224 | , run 9 True [ConfAssertion ["--string=bbb", "--string=aaa"] stringConfigL "aaabbb|"] 225 | ] 226 | where 227 | run (x ∷ Int) = runTest pkgInfo mi ("stringL-" ⊕ sshow x) 228 | mi = programInfoValidate "Text left append" pStringConfigL defaultStringConfigL (const $ return ()) 229 | 230 | textAppendTestsFilesL ∷ PkgInfo → [IO Bool] 231 | textAppendTestsFilesL pkgInfo = 232 | [ run ca 1 True [ConfAssertion [] stringConfigL "a|"] 233 | 234 | , run ca 2 True [ConfAssertion ["--string=b"] stringConfigL "ba|"] 235 | , run ca 3 False [ConfAssertion ["--string=b"] stringConfigL "ab|"] 236 | , run cb 4 False [ConfAssertion ["--string=a"] stringConfigL "ba|"] 237 | , run cb 5 True [ConfAssertion ["--string=a"] stringConfigL "ab|"] 238 | 239 | , run2 ca ca 1 True [ConfAssertion [] stringConfigL "aa|"] 240 | , run2 ca cb 2 True [ConfAssertion [] stringConfigL "ba|"] 241 | , run2 ca cb 3 False [ConfAssertion [] stringConfigL "ab|"] 242 | , run2 cb ca 4 False [ConfAssertion [] stringConfigL "ba|"] 243 | , run2 cb ca 5 True [ConfAssertion [] stringConfigL "ab|"] 244 | ] 245 | where 246 | ca = StringConfigL "a" 247 | cb = StringConfigL "b" 248 | run c (x ∷ Int) b a = withConfigFile Json c $ \file → 249 | runTest pkgInfo (mi [file]) ("stringL-file1-" ⊕ sshow x) b a 250 | 251 | run2 c0 c1 (x ∷ Int) b a = 252 | withConfigFile Yaml c0 $ \file0 → 253 | withConfigFile Json c1 $ \file1 → 254 | runTest pkgInfo (mi [file0,file1]) ("stringL-file2-" ⊕ sshow x) b a 255 | 256 | mi files = set piConfigurationFiles (map ConfigFileRequired files) $ 257 | programInfoValidate "Text left append with file" pStringConfigL defaultStringConfigL (const $ return ()) 258 | --------------------------------------------------------------------------------