configuration-tools 0.5.0 → 0.6.0

raw patch · 16 files changed

+446/−117 lines, 16 filesdep +networkdep +vectordep ~optparse-applicativesetup-changednew-component:exe:examplePVP ok

version bump matches the API change (PVP)

Dependencies added: network, vector

Dependency ranges changed: optparse-applicative

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−0
• README.md +18/−6
• Setup.hs +14/−11
• configuration-tools.cabal +24/−4
• src/Configuration/Utils.hs +103/−24
• src/Configuration/Utils/CommandLine.hs +20/−1
• src/Configuration/Utils/Internal.hs +2/−15
• src/Configuration/Utils/Internal/ConfigFileReader.hs +5/−4
• src/Configuration/Utils/Internal/HttpsCertPolicy.hs +3/−3
• src/Configuration/Utils/Internal/JsonTools.hs +193/−0
• src/Configuration/Utils/Monoid.hs +2/−2
• src/Configuration/Utils/Operators.hs +1/−1
• src/Configuration/Utils/Setup.hs +14/−11
• test/TestExample.hs +15/−16
• test/TestTools.hs +11/−18
• test/Tests/MonoidConfig.hs +2/−1

@@ -1,5 +1,24 @@ # configuration-tools +## 0.6.0 (2021-02-16)++#### New++* The command line option `--print-config-as` was added, that takes the values+  `full`, `minimal`, and `diff` and print either the full configuration, a+  minimal configuration that contains only changes that are different from the+  default configuration, or it print a YAML document that shows the difference+  between the actual configuration and the default configuration.++* The helper functions `jsonOption` and `jsonReader` for building command line+  parsers have been added.++#### Removed++* The function `fmapL` is removed from `Configuration.Utils.Internal`. Instead+  the function `first` from `Data.Bifunctor` from the `base` package can be+  used.+ ## 0.5.0 (2020-04-06)  #### Changed

@@ -95,7 +95,7 @@ In addition to the user defined command line options the following options are recognized by the application: -*   `--config-file, -c`+*   `--config-file`     parses the given file as a --possibly partial-- configuration in YAML or     JSON format. The file location can be provided either as a local file     system path or as a remote HTTP or HTTPS URL. In addition a list of static@@ -107,17 +107,29 @@     precedence over earlier settings. Files from static locations are     loaded before files that are specified on the command line. -*   `print-config, -p`+*   `print-config`     configures the application and prints the configuration in YAML format     to standard out and exits. The printed configuration is exactly the     configuration that otherwise would be used to run the application. -*   `--help, -h`+*   `print-config-as (full|minimal|diff)`+    Configures the application and prints the configuration in YAML format+    to standard out and exits. The printed configuration is exactly the+    configuration that otherwise would be used to run the application.++    Arguments:++    *   `full`: print the complete configuration. Same as `--print-config`.+    *   `minimal`: print a minimal configuration that contains only those+        settings that are different from the default setting.+    *   `diff`: print a YAML document that shows the difference between the+        default configuration and the actual configuration.++*   `--help, -h, -?`     prints a help message and exits. -As long as the package wasn't build with `-f-remote-configs` the following-two options are available. They affect how configuration files-are loaded from remote URLs.+If the package is build with `-f+remote-configs` the following two options are+available. They affect how configuration files are loaded from remote URLs.  *   `--config-https-insecure=true|false`     Bypass certificate validation for all HTTPS

@@ -235,19 +235,22 @@ trim = f . f   where f = reverse . dropWhile isSpace +#if defined (MIN_VERSION_Cabal) && MIN_VERSION_Cabal(3,4,0)+getVCS :: IO (Maybe KnownRepoType)+#else getVCS :: IO (Maybe RepoType)+#endif getVCS = getCurrentDirectory >>= getVcsOfDir--getVcsOfDir :: FilePath -> IO (Maybe RepoType)-getVcsOfDir d = do-    canonicDir <- canonicalizePath d-    doesDirectoryExist (canonicDir </> ".hg") >>= \x0 -> if x0-    then return (Just Mercurial)-    else doesDirectoryExist (canonicDir </> ".git") >>= \x1 -> if x1-        then return $ Just Git-        else if isDrive canonicDir-            then return Nothing-            else getVcsOfDir (takeDirectory canonicDir)+  where+    getVcsOfDir d = do+        canonicDir <- canonicalizePath d+        doesDirectoryExist (canonicDir </> ".hg") >>= \x0 -> if x0+        then return (Just Mercurial)+        else doesDirectoryExist (canonicDir </> ".git") >>= \x1 -> if x1+            then return $ Just Git+            else if isDrive canonicDir+                then return Nothing+                else getVcsOfDir (takeDirectory canonicDir)  pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString pkgInfoModule moduleName cName pkgDesc bInfo = do

@@ -1,7 +1,7 @@ cabal-version: 2.2  name: configuration-tools-version: 0.5.0+version: 0.6.0 synopsis: Tools for specifying and parsing configurations description:     Tools for specifying and parsing configurations@@ -33,14 +33,14 @@ maintainer: Lars Kuhtz <lakuhtz@gmail.com> copyright:     (c) 2019-2020 Colin Woodbury <colin@fosskers.ca>,-    (c) 2015-2020 Lars Kuhtz <lakuhtz@gmail.com>,+    (c) 2015-2021 Lars Kuhtz <lakuhtz@gmail.com>,     (c) 2014-2015 AlephCloud, Inc. category: Configuration, Console build-type: Custom tested-with:-      GHC==8.8.3+      GHC==8.10.4+    , GHC==8.8.4     , GHC==8.6.5-    , GHC==8.4.4  extra-doc-files:     README.md,@@ -76,6 +76,7 @@         Configuration.Utils.ConfigFile         Configuration.Utils.Http         Configuration.Utils.Internal+        Configuration.Utils.Internal.JsonTools         Configuration.Utils.Internal.ConfigFileReader         Configuration.Utils.Maybe         Configuration.Utils.Monoid@@ -116,6 +117,7 @@       , text >= 1.0       , transformers >= 0.4       , unordered-containers >= 0.2.4.0+      , vector >= 0.12       , yaml >= 0.8.8.3      if flag(remote-configs)@@ -173,6 +175,7 @@           , wai >= 3.0           , warp >= 3.0           , warp-tls >= 3.0+          , network >= 2.8          cpp-options: -DREMOTE_CONFIGS @@ -194,3 +197,20 @@       , base-unicode-symbols >= 0.2.2.4       , Cabal >= 2.2       , configuration-tools++executable example+    default-language: Haskell2010+    ghc-options: -Wall+    main-is: Example.hs+    ghc-options: -main-is Example+    hs-source-dirs: examples+    other-modules:+        PkgInfo+    autogen-modules:+        PkgInfo+    build-depends:+        base >= 4.11 && < 5+      , base-unicode-symbols >= 0.2.2.4+      , Cabal >= 2.2+      , configuration-tools+      , mtl >= 2.2

@@ -125,6 +125,7 @@ import Configuration.Utils.CommandLine import Configuration.Utils.ConfigFile import Configuration.Utils.Internal+import Configuration.Utils.Internal.JsonTools import qualified Configuration.Utils.Internal.ConfigFileReader as CF import Configuration.Utils.Maybe import Configuration.Utils.Monoid@@ -135,6 +136,7 @@ import Control.Monad.Writer hiding (mapM_)  import qualified Data.ByteString.Char8 as B8+import qualified Data.CaseInsensitive as CI import Data.Foldable import Data.Maybe import Data.Monoid.Unicode@@ -301,6 +303,29 @@ -- -------------------------------------------------------------------------- -- -- AppConfiguration +data PrintConfigMode = Full | Minimal | Diff++printConfigModeToText ∷ PrintConfigMode → T.Text+printConfigModeToText Full = "full"+printConfigModeToText Minimal = "minimal"+printConfigModeToText Diff = "diff"++printConfigModeFromText ∷ T.Text → Either String PrintConfigMode+printConfigModeFromText t = case CI.mk t of+    "full" → Right Full+    "minimal" → Right Minimal+    "diff" → Right Diff+    x → Left $ "unknow print configuration mode: " <> sshow x++instance ToJSON PrintConfigMode where+    toJSON = toJSON ∘ printConfigModeToText+    {-# INLINE toJSON #-}++instance FromJSON PrintConfigMode where+    parseJSON = withText "PrintConfigMode"+        $ either fail return ∘ printConfigModeFromText+    {-# INLINE parseJSON #-}+ -- | An /internal/ data type that is used during configuration parsing to -- represent the overall application configuration which includes --@@ -314,7 +339,7 @@ -- line options but not through configuration files. -- data AppConfiguration a = AppConfiguration-    { _printConfig ∷ !Bool+    { _printConfig ∷ !(Maybe PrintConfigMode)     , _configFilesConfig ∷ !ConfigFilesConfig     , _configFiles ∷ ![ConfigFile]     , _mainConfig ∷ !a@@ -341,7 +366,7 @@ -- -- 2. 'ConfigFiles' options are all @--config-file@ options. ----- 3. Other /meta/ options, such as @--print-config@.+-- 3. Other /meta/ options, such as @--print-config@ and @--printconfig-as@. -- -- 4. Options for the actual user /configuration/. The user configuration --    is represented as an update function that yields a configuration@@ -356,16 +381,26 @@     <*> many pConfigFile     <*> mainParser   where-    pPrintConfig = O.switch-        % O.long "print-config"-        ⊕ O.help "Print the parsed configuration to standard out and exit"-        ⊕ O.showDefault-     pConfigFile = ConfigFileRequired ∘ T.pack <$> O.strOption         % O.long "config-file"         ⊕ O.metavar "FILE"         ⊕ O.help "Configuration file in YAML or JSON format. If more than a single config file option is present files are loaded in the order in which they appear on the command line." +    pPrintConfig+        = Just <$> pPrintConfigOption+        <|> Just <$> pPrintConfigFlag+        <|> pure Nothing++    pPrintConfigFlag = O.flag' Full+        % O.long "print-config"+        ⊕ O.help "Print the parsed configuration to standard out and exit. This is an alias for --print-config-as=full"++    pPrintConfigOption = O.option (eitherReader $ printConfigModeFromText . T.pack)+        % O.long "print-config-as"+        ⊕ O.help "Print the parsed configuration to standard out and exit"+        ⊕ O.completeWith ["full", "minimal", "diff", "Full", "Minimal", "Diff"]+        ⊕ O.metavar "full|minimal|diff"+ -- -------------------------------------------------------------------------- -- -- Main Configuration without Package Info @@ -375,19 +410,32 @@ -- In addition to the options defined by the given options parser the following -- options are recognized: ----- [@--config-file, -c@]+-- [@--config-file@] --     Parse the given file path as a (partial) configuration in YAML or JSON --     format. ----- [@--print-config, -p@]+-- [@--print-config@] --     Print the final parsed configuration to standard out and exit. ----- [@--help, -h@]+-- [@--print-config-as (full|minimal|diff)@]+--     Configures the application and prints the configuration in YAML format to+--     standard out and exits. The printed configuration is exactly the+--     configuration that otherwise would be used to run the application.+--+--     Arguments:+--+--     *   @full@: print the complete configuration. Same as @--print-config@.+--     *   @minimal@: print a minimal configuration that contains only those+--         settings that are different from the default setting.+--     *   @diff@: print a YAML document that shows the difference between the+--         default configuration and the actual configuration.+--+-- [@--help, -h, -?@] --     Print a help message and exit. ----- As long as the package wasn't build with @-f-remote-configs@ the following--- two options are available. They affect how configuration files--- are loaded from remote URLs.+-- If the package is build with @-f+remote-configs@ the following two options+-- are available. They affect how configuration files are loaded from remote+-- URLs. -- -- [@--config-https-insecure=true|false@] --     Bypass certificate validation for all HTTPS@@ -437,9 +485,9 @@ -- -- @(info message, detailed info message, version string, license text)@ ----- See the documentation of "Configuration.Utils.Setup" for a way--- how to generate this information automatically from the package--- description during the build process.+-- See the documentation of "Configuration.Utils.Setup" for a way how to+-- generate this information automatically from the package description during+-- the build process. -- type PkgInfo =     ( String@@ -465,7 +513,20 @@ -- [@--print-config, -p@] --     Print the final parsed configuration to standard out and exit. ----- [@--help, -h@]+-- [@--print-config-as (full|minimal|diff)@]+--     Configures the application and prints the configuration in YAML format to+--     standard out and exits. The printed configuration is exactly the+--     configuration that otherwise would be used to run the application.+--+--     Arguments:+--+--     *   @full@: print the complete configuration. Same as @--print-config@.+--     *   @minimal@: print a minimal configuration that contains only those+--         settings that are different from the default setting.+--     *   @diff@: print a YAML document that shows the difference between the+--         default configuration and the actual configuration.+--+-- [@--help, -h, -?@] --     Print a help message and exit. -- -- [@--version, -v@]@@ -480,9 +541,9 @@ -- [@--license@] --     Print the text of the license of the application and exit. ----- As long as the package wasn't build with @-f-remote-configs@ the following--- two options are available. They affect how configuration files--- are loaded from remote URLs.+-- If the package is build with @-f+remote-configs@ the following two options+-- are available. They affect how configuration files are loaded from remote+-- URLs. -- -- [@--config-https-insecure=true|false@] --     Bypass certificate validation for all HTTPS@@ -538,7 +599,11 @@      -- the 'O.helper' option from optparse-applicative is hidden by default     -- which seems a bit weired. This option doesn't hide the access to help.+#if MIN_VERSION_optparse_applicative(0,16,0)+    nonHiddenHelper = abortOption (ShowHelpText Nothing)+#else     nonHiddenHelper = abortOption ShowHelpText+#endif         % long "help"         ⊕ short 'h'         ⊕ short '?'@@ -613,11 +678,25 @@     -- Validate final configuration     validateConfig appInfo $ _mainConfig appConf -    if _printConfig appConf-        then B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ appConf-        else mainFunction ∘ _mainConfig $ appConf+    case _printConfig appConf of+        Nothing → mainFunction ∘ _mainConfig $ appConf+        Just Full → B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ appConf+        Just Minimal → B8.putStrLn+            ∘ Yaml.encode+            ∘ resolve resolveOnlyRight+            ∘ diff (toJSON $ _piDefaultConfiguration appInfo)+            ∘ toJSON+            ∘ _mainConfig+            $ appConf+        Just Diff → B8.putStrLn+            ∘ Yaml.encode+            ∘ diff (toJSON $ _piDefaultConfiguration appInfo)+            ∘ toJSON+            ∘ _mainConfig+            $ appConf   where-    parserPrefs = O.prefs O.disambiguate+    parserPrefs = O.prefs mempty+  -- | Parse the command line arguments. --

@@ -47,6 +47,8 @@ , enableDisableFlag , fileOption , eitherReadP+, jsonOption+, jsonReader , module Options.Applicative ) where @@ -56,6 +58,8 @@ import Control.Applicative import Control.Monad.Writer hiding (mapM_) +import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.CaseInsensitive as CI import Data.Maybe import Data.Monoid.Unicode@@ -220,7 +224,7 @@ -- | An option parser for flags that are enabled via the flag name prefixed -- with @--enable-@ and disabled via the flag name prefix @--disable-@. The -- prefixes are applied to all long option names. Short option names are parsed--- unchanged and and cause the flag to be enabled.+-- unchanged and cause the flag to be enabled. -- -- This resembles the style of flags that is used for instances with Cabal. --@@ -254,6 +258,8 @@         }     enmods = O.Mod (mapEnFlags ∘ f) d o +-- | An option that expects a file name.+-- fileOption     ∷ O.Mod O.OptionFields String     → O.Parser FilePath@@ -262,6 +268,8 @@     ⊕ O.action "file"     ⊕ mods +-- | Create an either-reader from a 'ReadP' parser.+-- eitherReadP     ∷ T.Text     → P.ReadP a@@ -272,3 +280,14 @@         [x] → Right x         [] → Left $ "eitherReadP: no parse for " ⊕ label ⊕ " of " ⊕ s         _ → Left $ "eitherReadP: ambigous parse for " ⊕ label ⊕ " of " ⊕ s++-- | An option that expects a JSON value as argument.+--+jsonOption ∷ FromJSON a ⇒ Mod OptionFields a → O.Parser a+jsonOption = O.option jsonReader++-- | An option reader for a JSON value.+--+jsonReader ∷ FromJSON a ⇒ ReadM a+jsonReader = eitherReader $ eitherDecode' ∘ BL8.pack+

@@ -31,7 +31,6 @@ , sshow , exceptT , errorT-, fmapL ) where  import Control.Applicative (Const(..))@@ -39,6 +38,8 @@ import Control.Monad.Reader.Class import Control.Monad.Except +import Data.Function ((&))+import Data.Functor ((<&>)) import Data.Functor.Identity import Data.Monoid.Unicode import Data.Profunctor@@ -48,8 +49,6 @@  import Prelude.Unicode -infixl 1 &, <&>- -- -------------------------------------------------------------------------- -- -- Lenses @@ -102,14 +101,6 @@ -- -------------------------------------------------------------------------- -- -- Misc Utils -(&) ∷ a → (a → b) → b-(&) = flip ($)-{-# INLINE (&) #-}--(<&>) ∷ Functor f ⇒ f a → (a → b) → f b-(<&>) = flip fmap-{-# INLINE (<&>) #-}- sshow     ∷ (Show a, IsString s)     ⇒ a@@ -132,8 +123,4 @@     → m a errorT = exceptT (\e → error ∘ T.unpack $ "Error: " ⊕ e) return {-# INLINE errorT #-}--fmapL ∷ (a → b) → Either a c → Either b c-fmapL f = either (Left ∘ f) Right-{-# INLINE fmapL #-} 

@@ -46,6 +46,7 @@ import Control.Monad.Error.Class import Control.Monad.IO.Class +import Data.Bifunctor import qualified Data.ByteString.Char8 as B8 import Data.Monoid.Unicode import qualified Data.Text as T@@ -147,8 +148,8 @@   where     file = getConfigFile path -    parser Json f = fmapL T.pack ∘ eitherDecodeStrict' <$> B8.readFile (T.unpack f)-    parser _ f = fmapL sshow <$> Yaml.decodeFileEither (T.unpack f)+    parser Json f = first T.pack ∘ eitherDecodeStrict' <$> B8.readFile (T.unpack f)+    parser _ f = first sshow <$> Yaml.decodeFileEither (T.unpack f)  data ConfigFileFormat     = Yaml@@ -202,8 +203,8 @@             Left e → throwError $ "failed to parse remote configuration " ⊕ url ⊕ ": " ⊕ e             Right r → return r   where-    parser Json = fmapL T.pack ∘ eitherDecodeStrict'-    parser _ = fmapL sshow ∘ Yaml.decodeEither'+    parser Json = first T.pack ∘ eitherDecodeStrict'+    parser _ = first sshow ∘ Yaml.decodeEither'      url = getConfigFile path     policy = _cfcHttpsPolicy conf

@@ -40,11 +40,11 @@ import Configuration.Utils.Operators import Configuration.Utils.Validation -import Control.Arrow (second) import Control.Exception (Exception, Handler(..), catches, throwIO) import Control.Monad.State import Control.Monad.Writer +import Data.Bifunctor import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB@@ -128,7 +128,7 @@      next = state $ second (drop 1) ∘ break (≡ ':') -    x = lift ∘ fmapL T.unpack+    x = lift ∘ first T.unpack  -- -------------------------------------------------------------------------- -- -- HTTP Requests With Certificate Validation Policy@@ -158,7 +158,7 @@ httpWithValidationPolicy request policy = do     certVar ← newIORef Nothing     settings ← getSettings policy certVar-    mgr <- HTTP.newManager settings+    mgr ← HTTP.newManager settings     HTTP.httpLbs request mgr `catches`         [ Handler $ \(e ∷ TLS.TLSException) → do             cert ← readIORef certVar

@@ -0,0 +1,193 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Configuration.Utils.Internal.JsonTools+-- Copyright: Copyright © 2020 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- The difference algorithms uses the following identies on JSON Values:+--+-- * An array equals the same array with all Null entries removed.+-- * An object equals the same object with all Null valued properties removed.+--+module Configuration.Utils.Internal.JsonTools+( Diff(..)+, diff+, resolve++-- * Conflict Resoluation Strategies+, merge+, mergeLeft+, mergeRight+, resolveLeft+, resolveOnlyLeft+, resolveRight+, resolveOnlyRight+) where++import Control.Applicative++import Data.Aeson+import Data.Aeson.Types+import Data.Foldable+import qualified Data.HashMap.Strict as HM+import qualified Data.Vector as V++import GHC.Generics++-- -------------------------------------------------------------------------- --+-- Representation of Difference between to Values++-- | Represent differences between two values+--+data Diff a+    = OnlyLeft a+    | OnlyRight a+    | Conflict a a+    | Both a+    deriving (Eq, Ord, Generic)++instance ToJSON a ⇒ ToJSON (Diff a) where+    toJSON (OnlyLeft a) = object ["$left" .= a]+    toJSON (OnlyRight a) = object ["$right" .= a]+    toJSON (Both a) = object ["$both" .= a]+    toJSON (Conflict a b) = object ["$left" .= a, "$right" .= b]+    {-# INLINE toJSON #-}++instance FromJSON a ⇒ FromJSON (Diff a) where+    parseJSON a = conflict a <|> right a <|> left a <|> both a+      where+        conflict = withObject "Diff.Conflict" $ \o → Conflict+            <$> o .: "$left"+            <*> o .: "$right"+        right = withObject "Diff.OnlyRight" $ \o → OnlyRight+            <$> o .: "$right"+        left = withObject "Diff.OnlyLeft" $ \o → OnlyLeft+            <$> o .: "$left"+        both = withObject "Diff.Both" $ \o → Both+            <$> o .: "$both"+    {-# INLINE parseJSON #-}++-- -------------------------------------------------------------------------- --+-- Resolve Diff Value++-- | Resolve differences between two JSON values using the provided conflict+-- resolution function.+--+resolve ∷ (Diff Value → Value) → Value → Value+resolve f = go+  where+    go v = case f <$> parseMaybe parseJSON v of+        Just x → x+        Nothing → case v of+            (Object a) → Object $ HM.filter (/= Null) $ go <$> a+            (Array a) → Array $ V.filter (/= Null) $ go <$> a+            a → a++-- | Merge all non-conflicting differences. Leave the conflict annotations in+-- the result.+--+merge ∷ Diff Value → Value+merge (OnlyLeft a) = a+merge (OnlyRight a) = a+merge (Conflict a b) = toJSON $ Conflict a b+merge (Both a) = a++-- | Merge all differences. Pick the left value in case of a conflict.+--+mergeLeft ∷ Diff Value → Value+mergeLeft (OnlyLeft a) = a+mergeLeft (OnlyRight a) = a+mergeLeft (Conflict a _) = a+mergeLeft (Both a) = a++-- | Merge all differences. Pick the right value in case of a conflict.+--+mergeRight ∷ Diff Value → Value+mergeRight (OnlyLeft a) = a+mergeRight (OnlyRight a) = a+mergeRight (Conflict _ a) = a+mergeRight (Both a) = a++-- | Resolve all differences by choosing the left value.+--+resolveLeft ∷ Diff Value → Value+resolveLeft (OnlyLeft a) = a+resolveLeft (OnlyRight _) = Null+resolveLeft (Conflict a _) = a+resolveLeft (Both a) = a++-- | Keep values that /only/ occure in the left value. Remove all values that+-- occur in the right value or in both.+--+-- The result is the left value minus the right value.+--+resolveOnlyLeft ∷ Diff Value → Value+resolveOnlyLeft (OnlyLeft a) = a+resolveOnlyLeft (OnlyRight _) = Null+resolveOnlyLeft (Conflict a _) = a+resolveOnlyLeft (Both _) = Null++-- | Resolve all differences by choosing the right value.+--+resolveRight ∷ Diff Value → Value+resolveRight (OnlyLeft _) = Null+resolveRight (OnlyRight a) = a+resolveRight (Conflict _ a) = a+resolveRight (Both a) = a++-- | Keep values that /only/ occure in the right value. Remove all values that+-- occur in the left value or in both.+--+-- The result is the right value minus the left value.+--+resolveOnlyRight ∷ Diff Value → Value+resolveOnlyRight (OnlyLeft _) = Null+resolveOnlyRight (OnlyRight a) = a+resolveOnlyRight (Conflict _ a) = a+resolveOnlyRight (Both _) = Null++-- -------------------------------------------------------------------------- --+-- Compute Difference between two JSON Values++-- | Merge two JSON values and annotate the result with the differences.+--+diff ∷ Value → Value → Value+diff a b | a == b = toJSON $ Both a+diff (Object a) (Object b) = Object $ mergeObjects a b+diff (Array a) (Array b) = Array $ mergeVectors a b+diff a b+    | a == Null = toJSON $ OnlyRight b+    | b == Null = toJSON $ OnlyLeft a+    | otherwise = toJSON $ Conflict a b++mergeObjects ∷ Object → Object → Object+mergeObjects l r+    = (toJSON . OnlyLeft <$> HM.difference l r)+    <> (toJSON . OnlyRight <$> HM.difference r l)+    <> HM.intersectionWith diff l r++-- | A naive list merge with a lookAhead of 1+--+mergeVectors ∷ Array → Array → Array+mergeVectors a b = V.fromList $ toJSON <$> go (toList a) (toList b)+  where+    go a' [] = OnlyLeft <$> a'+    go [] b' = OnlyRight <$> b'+    go al@(ha0 : ha1 : ta) bl@(hb0 : hb1 : tb)+        | ha0 == hb0 = Both ha0 : go (ha1 : ta) (hb1 : tb)+        | ha0 == hb1 = OnlyRight hb0 : go al (hb1 : tb)+        | ha1 == hb0 = OnlyLeft ha0 : go (ha1 : ta) bl+        | otherwise = Conflict ha0 hb0 : go (ha1 : ta) (hb1 : tb)+    go (ha0 : ta) (hb0 : tb)+        | ha0 == hb0 = Both ha0 : go ta tb+        | otherwise = Conflict ha0 hb0 : go ta tb+

@@ -90,13 +90,13 @@ -- >         <> metavar "APIROUTE:APIURL" -- > -- >     readRoute s = case break (== ':') s of--- >         (a,':':b) → fmapL T.unpack $ do+-- >         (a,':':b) → first T.unpack $ do -- >             validateNonEmpty "APIROUTE" a -- >             validateHttpOrHttpsUrl "APIURL" b -- >             return $ HM.singleton (T.pack a) (T.pack b) -- >         _ → Left "missing colon between APIROUTE and APIURL" -- >--- >     fmapL f = either (Left . f) Right+-- >     first f = either (Left . f) Right -- pLeftMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a pLeftMonoidalUpdate pElement = mappend ∘ mconcat ∘ reverse <$> many pElement

@@ -50,7 +50,7 @@ (×) = ($) infixr 5 × {-# INLINE (×) #-}-{-# DEPRECATED (×) "use '$' instead" #-}+{-# DEPRECATED (×) "use '%' instead" #-}  -- | Functional composition for applicative functors. --

@@ -234,19 +234,22 @@ trim = f . f   where f = reverse . dropWhile isSpace +#if defined (MIN_VERSION_Cabal) && MIN_VERSION_Cabal(3,4,0)+getVCS :: IO (Maybe KnownRepoType)+#else getVCS :: IO (Maybe RepoType)+#endif getVCS = getCurrentDirectory >>= getVcsOfDir--getVcsOfDir :: FilePath -> IO (Maybe RepoType)-getVcsOfDir d = do-    canonicDir <- canonicalizePath d-    doesDirectoryExist (canonicDir </> ".hg") >>= \x0 -> if x0-    then return (Just Mercurial)-    else doesDirectoryExist (canonicDir </> ".git") >>= \x1 -> if x1-        then return $ Just Git-        else if isDrive canonicDir-            then return Nothing-            else getVcsOfDir (takeDirectory canonicDir)+  where+    getVcsOfDir d = do+        canonicDir <- canonicalizePath d+        doesDirectoryExist (canonicDir </> ".hg") >>= \x0 -> if x0+        then return (Just Mercurial)+        else doesDirectoryExist (canonicDir </> ".git") >>= \x1 -> if x1+            then return $ Just Git+            else if isDrive canonicDir+                then return Nothing+                else getVcsOfDir (takeDirectory canonicDir)  pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString pkgInfoModule moduleName cName pkgDesc bInfo = do

@@ -67,8 +67,7 @@      T.putStrLn $ "success: " ⊕ sshow (length successes)     T.putStrLn $ "failures: " ⊕ sshow (length failures)-    unless (length failures ≡ 0) $ do-        error "test suite failed"+    unless (length failures ≡ 0) $ error "test suite failed"  -- -------------------------------------------------------------------------- -- -- Test categories@@ -105,12 +104,12 @@     typedConfigs = [("config0", ConfigType config0), ("config1", ConfigType config1Part)]     textConfigs = [("invalid", "invalid: invalid")] -    run (format, label) = withConfigFileServer typedConfigs textConfigs format $+    run (format, label) = withConfigFileServer typedConfigs textConfigs format $ \httpPort httpsPort →         sequence-            % tests2Files2 ("remote-" ⊕ label) (serverUrl ⊕ "/config0") (serverUrl ⊕ "/config1")-            ⊕ tests2Files3 ("remote-" ⊕ label) (serverUrl ⊕ "/config0") (serverUrl ⊕ "/config1")-            ⊕ testsInvalidUrl-            ⊕ testsTlsUrl+            % tests2Files2 ("remote-" ⊕ label) (serverUrl httpPort ⊕ "/config0") (serverUrl httpPort ⊕ "/config1")+            ⊕ tests2Files3 ("remote-" ⊕ label) (serverUrl httpPort ⊕ "/config0") (serverUrl httpPort ⊕ "/config1")+            ⊕ testsInvalidUrl httpPort+            ⊕ testsTlsUrl httpPort httpsPort #else remoteTests = return [] #endif@@ -140,17 +139,17 @@ #ifdef REMOTE_CONFIGS -- | Test with invalid remote URLs ---testsInvalidUrl ∷ [IO Bool]-testsInvalidUrl =+testsInvalidUrl ∷ Int → [IO Bool]+testsInvalidUrl httpPort =     [ runTest pkgInfo mainInfo "invalidUrl-0" False [x0, d1]     , runTest pkgInfo mainInfo "invalidUrl-1" False [x1, d1]     ]   where     x0 = trueAssertion ["--config-file=http://invalid"]-    x1 = trueAssertion ["--config-file=" ⊕ T.unpack serverUrl ⊕ "/invalid"]+    x1 = trueAssertion ["--config-file=" ⊕ T.unpack (serverUrl httpPort) ⊕ "/invalid"] -testsTlsUrl ∷ [IO Bool]-testsTlsUrl =+testsTlsUrl ∷ Int → Int → [IO Bool]+testsTlsUrl httpPort httpsPort =     [ runTest pkgInfo mainInfo "tlsUrl-0" True [cf0, f1 c0]     , runTest pkgInfo mainInfo "tlsUrl-1" False [cf0t, f1 c0]     , runTest pkgInfo mainInfo "tlsUrl-2" False [cf0tl, f1 c0]@@ -160,12 +159,12 @@     , runTest pkgInfo mainInfo "tlsUrl-6" True [insec, cf0t, f1 c0]     ]   where-    cf0 = trueAssertion ["--config-file=" ⊕ T.unpack serverUrl ⊕ "/config0"]-    cf0t = trueAssertion ["--config-file=" ⊕ T.unpack serverTlsUrl ⊕ "/config0"]+    cf0 = trueAssertion ["--config-file=" ⊕ T.unpack (serverUrl httpPort) ⊕ "/config0"]+    cf0t = trueAssertion ["--config-file=" ⊕ T.unpack (serverTlsUrl httpsPort) ⊕ "/config0"]     cf0tl = trueAssertion ["--config-file=" ⊕ "https://localhost:8284" ⊕ "/config0"] -- FIXME don't hardcode this     insec = trueAssertion ["--config-https-insecure"]-    fingerF = trueAssertion ["--config-https-allow-cert=" ⊕ drop 8 (T.unpack serverTlsUrl) ⊕ ":0x+SV6/D6JSIKK8pPCpaMZvMXelXb2CnJ8xWo8qi4Fo="]-    fingerT = trueAssertion ["--config-https-allow-cert=" ⊕ drop 8 (T.unpack serverTlsUrl) ⊕ ":HK4/ZeG/3c+H5R/3eTlysmJxmrBil6w8oLdvOdHFlsg="]+    fingerF = trueAssertion ["--config-https-allow-cert=" ⊕ drop 8 (T.unpack $ serverTlsUrl httpsPort) ⊕ ":0x+SV6/D6JSIKK8pPCpaMZvMXelXb2CnJ8xWo8qi4Fo="]+    fingerT = trueAssertion ["--config-https-allow-cert=" ⊕ drop 8 (T.unpack $ serverTlsUrl httpsPort) ⊕ ":HK4/ZeG/3c+H5R/3eTlysmJxmrBil6w8oLdvOdHFlsg="]     c0 = config0 #endif 

@@ -79,6 +79,7 @@ import qualified Network.Wai.Handler.Warp as WARP import qualified Network.Wai.Handler.WarpTLS as WARP import qualified Network.HTTP.Types as HTTP+import Network.Socket (close) #endif  -- -------------------------------------------------------------------------- --@@ -220,15 +221,13 @@     ∷ [(T.Text, ConfigType)]     → [(T.Text, T.Text)]     → Maybe ConfigFileFormat-    → IO a+    → (Int → Int → IO a)     → IO a-withConfigFileServer configs configTexts maybeFormat inner = do-    w0 ← forkIO $ WARP.run serverPort app-    w1 ←  forkIO $ WARP.runTLS tlsSettings (warpSettings serverTlsPort) app-    inner `finally` do-        killThread w0-        killThread w1-+withConfigFileServer configs configTexts maybeFormat inner =+    WARP.testWithApplication (return app) $ \httpPort →+        bracket WARP.openFreePort (close ∘ snd) $ \(httpsPort, sock) → do+            s ← forkIO $ WARP.runTLSSocket tlsSettings (warpSettings httpsPort) sock app+            inner httpPort httpsPort `finally` killThread s   where     app req respond = do @@ -252,17 +251,11 @@     contentTypeHeader Json = (HTTP.hContentType, head jsonMimeType)     contentTypeHeader _ = (HTTP.hContentType, head yamlMimeType) -serverPort ∷ Int-serverPort = 8283--serverTlsPort ∷ Int-serverTlsPort = 8284--serverUrl ∷ T.Text-serverUrl = "http://127.0.0.1:" ⊕ sshow serverPort+serverUrl ∷ Int → T.Text+serverUrl serverPort = "http://127.0.0.1:" ⊕ sshow serverPort -serverTlsUrl ∷ T.Text-serverTlsUrl = "https://127.0.0.1:" ⊕ sshow serverTlsPort+serverTlsUrl ∷ Int → T.Text+serverTlsUrl serverTlsPort = "https://127.0.0.1:" ⊕ sshow serverTlsPort  tlsSettings ∷ WARP.TLSSettings tlsSettings = WARP.tlsSettingsMemory serverCert serverKey

@@ -25,6 +25,7 @@ import Configuration.Utils.Internal.ConfigFileReader import Configuration.Utils.Validation +import Data.Bifunctor import qualified Data.HashMap.Strict as HM import Data.Monoid.Unicode import Data.String@@ -77,7 +78,7 @@         ⊕ metavar "APIROUTE:APIURL"      readRoute s = case break (== ':') s of-        (a,':':b) → fmapL T.unpack $ do+        (a,':':b) → first T.unpack $ do             validateNonEmpty "APIROUTE" a             validateHttpOrHttpsUrl "APIURL" b             return $ HM.singleton (T.pack a) (T.pack b)