configuration-tools 0.2.9 → 0.2.10

raw patch · 12 files changed

+715/−520 lines, 12 filesdep +deepseqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−8
• README.md +16/−16
• configuration-tools.cabal +7/−4
• src/Configuration/Utils.hs +5/−5
• src/Configuration/Utils/ConfigFile.hs +1/−118
• src/Configuration/Utils/HttpsCertPolicy.hs +0/−308
• src/Configuration/Utils/Internal.hs +6/−1
• src/Configuration/Utils/Internal/ConfigFileReader.hs +221/−0
• src/Configuration/Utils/Internal/HttpsCertPolicy.hs +316/−0
• test/TestExample.hs +79/−40
• test/TestTools.hs +35/−13
• test/Tests/MonoidConfig.hs +7/−7

@@ -1,13 +1,27 @@+0.2.10+======++*   Moved all internal APIs to the `Internal` name space. Exposing them+    in 0.2.9 was considered a bug.++*   Configuration files can be formatted either as JSON or as YAML.+    For remote configuration files the HTTP `Content-Type` header is used to+    determine the format, for local files the file suffix is used.+    The default format is YAML.++*   Set the HTTP `accept` header for JSON and YAML when requesting remote+    configuration files.+ 0.2.9 =====  *   Use tight constraint for all validation functions. Previously the-    constraint where unessecarly restrictive.+    constraint where unnecessarily restrictive.  *   Added `updateProperty` function that generalized `%.:` in the same     way as `setProperty` generalizes `..:`. -*   Added validation function for config file arguments.+*   Added a validation function for configuration file arguments.  *   Allow usage of more than a single `--config-file` option on the     command line.@@ -15,9 +29,9 @@ *   Support for static configuration file locations. Configuration files     can be marked as `required` or `optional`. -*   Support loading of configuraiton files form HTTP and HTTPS URLs-    including flags for disabling validation of SSL certificates and-    whitelisting SSL certificates based on their fingerprint.+*   Support for loading of configuration files form HTTP and HTTPS URLs.+    There are new flags for disabling validation of SSL certificates and+    white listing SSL certificates based on their fingerprint.  *   Added tools for updating configurations with a monoid instance. @@ -39,7 +53,7 @@ 0.2.8 ===== -*   Added validation funcitons for Boolean values, numberic values and+*   Added validation functions for Boolean values, numeric values and     orders.  *   Added operator `!..:` for parsing of configuration values that are@@ -53,7 +67,7 @@ 0.2.7 ===== -*   Added `view` funtion for lenses to `Configuration.Utils.Internal`.+*   Added `view` function for lenses to `Configuration.Utils.Internal`.  *   Added support for validation of configuration values. @@ -90,7 +104,7 @@ =====  *   Configuration.Utils.Setup: fixed generation of `PkgInfo` module for-    package configurations with explict flags.+    package configurations with explicit flags.  *   Improved documentation for `Maybe` values. 

@@ -3,7 +3,7 @@ Overview ======== -This package provides a collection of utils on top of the packages+This package provides a collection of utilities on top of the packages [optparse-applicative](http://hackage.haskell.org/package/optparse-applicative), [aeson](http://hackage.haskell.org/package/aeson), and [yaml](http://hackage.haskell.org/package/yaml) for configuring libraries and@@ -34,7 +34,7 @@ Installation ============ -Assuming that you have a recent version verison of `GHC` and `Cabal`+Assuming that you have a recent version version of `GHC` and `Cabal` installed in your system this package can be install from [Hackage](http://hackage.haskell.org/) via @@ -81,7 +81,7 @@ Optionally, a function for validating the configuration value may be provided. -The package provides operators and functions that make the implmentation of+The package provides operators and functions that make the implementation of these requisites easy for the common case that the configuration is encoded mainly through nested records. @@ -89,9 +89,9 @@ options are recognized by the application:  *   `--config-file, -c`-    parses the given file as a --possibly partial-- configuration in YAML-    format. The file location can be provided either as a local filesystem path-    or as a remote HTTP or HTTPS URL. In addition a list of static+    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     configuration file locations can be defined in the code.      If this option is provided more than a single time the configuration@@ -109,7 +109,7 @@     prints a help message and exits.  As long as the package wasn't build with `-f-remote-configs` the following-two options are availabe. They affect how configuration files+two options are available. They affect how configuration files are loaded from remote URLs.  *   `--config-https-insecure=true|false`@@ -158,7 +158,7 @@     } ~~~ -We have to define lenses for the configuration types. Here we do it explicitely.+We have to define lenses for the configuration types. Here we do it explicitly. Alternatively one could have used TemplateHaskell along with `makeLenses` from the module `Control.Lens` from the [lens](http://hackage.haskell.org/package/lens) package.@@ -191,7 +191,7 @@ instance that yields a function that updates a given `Auth` value with the values from the parsed JSON value. The `<*<` operator is functional composition lifted for applicative functors and `%` is a version of `$` with a different-precedence that helps to reduce the use of paranthesis in applicative style+precedence that helps to reduce the use of parenthesis in applicative style code.  ~~~{.haskell}@@ -233,7 +233,7 @@ [optparse-applicative](http://hackage.haskell.org/package/optparse-applicative) package for further information on how to define command line options. -The following definitons for the `HttpURL` are similar to definitions for+The following definitions for the `HttpURL` are similar to definitions for the `Auth` type above. In addition it is demonstrated how to deal with nested configuration types. Mainly the usage of `..:` is replaced by `%.:` and `.::` is replaced by `%::`.@@ -313,10 +313,10 @@  Sum types can not be used as configuration types in the same way as product types. The reason is that the nondeterminism in the choice of a term for the type is-not restricted to the choosen constructor arguments but in addition there+not restricted to the chosen constructor arguments but in addition there is non-determinism in the choice of the constructor, too. -An update function for a product type can be defined pointwise as a mapping from+An update function for a product type can be defined point-wise as a mapping from constructor parameters to values. An update for a sum type must take the constructor context into account. Moreover, when applied to a given default value the function may not be applicable at all if the default value uses a@@ -338,7 +338,7 @@  The module `Configuration.Utils.Setup` an example `Setup.hs` script that hooks into the cabal build process at the end of the configuration phase and generates-a module with package information for each component of the cabal pacakge.+a module with package information for each component of the cabal package.  The modules are created in the *autogen* build directory where also the *Path_* module is created by cabal's simple build setup. This is usually the directory@@ -421,7 +421,7 @@     indirect dependencies along with their licenses and copyrights.  *   `--license`-    prints the text of the lincense of the application and exits.+    prints the text of the license of the application and exits.  Here is the example output of `--long-info` for the example `examples/Trivial.hs` from this package:@@ -518,7 +518,7 @@ *   Simplify specification of Configuration data types by     integrating the aeson instances and the option parser. -*   Come up with a storry for sum types. We may use the following approach: The+*   Come up with a story for sum types. We may use the following approach: The     definition of the default should include alternate values for each     constructor. Effectively, this means to map the sum type onto a product type     by interpreting the summands as factors. For mapping back from the product@@ -537,7 +537,7 @@  *   Nicer error messages if parsing fails. -*   Suport JSON encoded configuration files.+*   Support JSON encoded configuration files.  *   Support mode where JSON/YAML parsing fails when unexpected     properties are encountered.

@@ -3,7 +3,7 @@ -- ------------------------------------------------------ --  Name:                configuration-tools-Version:             0.2.9+Version:             0.2.10 Synopsis:            Tools for specifying and parsing configurations description:     Tools for specifying and parsing configurations@@ -33,7 +33,7 @@ License-file:        LICENSE Author:              Lars Kuhtz <lars@alephcloud.com> Maintainer:          Lars Kuhtz <lars@alephcloud.com>-Copyright:           Copyright (c) 2014 AlephCloud, Inc.+Copyright:           Copyright (c) 2014-2015 AlephCloud, Inc. Category:            Configuration, Console Build-type:          Custom @@ -54,7 +54,7 @@ source-repository this     type: git     location: https://github.com/alephcloud/hs-configuration-tools.git-    tag: 0.2.9+    tag: 0.2.10  flag remote-configs     Description: enable loading of configuration files from HTTP URLs@@ -71,6 +71,7 @@         Configuration.Utils.ConfigFile         Configuration.Utils.Http         Configuration.Utils.Internal+        Configuration.Utils.Internal.ConfigFileReader         Configuration.Utils.Maybe         Configuration.Utils.Monoid         Configuration.Utils.Operators@@ -78,7 +79,7 @@         Configuration.Utils.Validation     if flag(remote-configs)         exposed-modules:-            Configuration.Utils.HttpsCertPolicy+            Configuration.Utils.Internal.HttpsCertPolicy      build-depends:         Cabal >= 1.20,@@ -89,6 +90,7 @@         base-unicode-symbols >= 0.2.2.4,         bytestring >= 0.10.0.2,         case-insensitive >= 1.2,+        deepseq >= 1.3,         directory >= 1.2.1.0,         dlist >= 0.7.1,         errors >= 1.4.3,@@ -110,6 +112,7 @@             enclosed-exceptions >= 1.0,             http-client >= 0.4,             http-client-tls >= 0.2,+            http-types >= 0.8,             monad-control >= 1.0,             tls >= 1.2,             x509 >= 1.5,

@@ -124,8 +124,8 @@ ) where  import Configuration.Utils.CommandLine-import Configuration.Utils.ConfigFile hiding (parseConfigFiles)-import qualified Configuration.Utils.ConfigFile as CF (parseConfigFiles)+import Configuration.Utils.ConfigFile+import qualified Configuration.Utils.Internal.ConfigFileReader as CF import Configuration.Utils.Internal import Configuration.Utils.Maybe import Configuration.Utils.Monoid@@ -375,7 +375,7 @@         × O.long "config-file"         ⊕ O.short 'c'         ⊕ O.metavar "FILE"-        ⊕ O.help "Configuration file in YAML format. If more than a single config file option is present files are loaded in the order in which they appear on the command line."+        ⊕ 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."  -- -------------------------------------------------------------------------- -- -- Main Configuration without Package Info@@ -387,7 +387,7 @@ -- options are recognized: -- -- [@--config-file, -c@]---     Parse the given file path as a (partial) configuration in YAML+--     Parse the given file path as a (partial) configuration in YAML or JSON --     format. -- -- [@--print-config, -p@]@@ -471,7 +471,7 @@ -- options are recognized: -- -- [@--config-file, -c@]---     Parse the given file path as a (partial) configuration in YAML+--     Parse the given file path as a (partial) configuration in YAML or JSON --     format. -- -- [@--print-config, -p@]

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}@@ -61,17 +60,11 @@ -- * Miscellaneous Utilities , dropAndUncaml , module Data.Aeson---- * Internal Tools for Parsing Configuration Files-, parseConfigFiles ) where  import Configuration.Utils.CommandLine import Configuration.Utils.Internal-import Configuration.Utils.Validation -import Control.Monad.Except hiding (mapM_)- import Data.Aeson import Data.Aeson.Types (Parser) import Data.Char@@ -82,26 +75,12 @@ import Data.String import qualified Data.Text as T import Data.Typeable-import qualified Data.Yaml as Yaml  import Prelude hiding (concatMap, mapM_, any)  #ifdef REMOTE_CONFIGS-import Configuration.Utils.HttpsCertPolicy+import Configuration.Utils.Internal.HttpsCertPolicy import Configuration.Utils.Operators--import Control.Exception.Enclosed-import Control.Monad.Trans.Control--import qualified Data.ByteString.Lazy as LB-import qualified Data.List as L-import qualified Data.Text.IO as T--import qualified Network.HTTP.Client as HTTP--import Prelude.Unicode--import System.IO #endif  -- | A JSON 'Value' parser for a property of a given@@ -288,102 +267,6 @@  pConfigFilesConfig ∷ MParser ConfigFilesConfig pConfigFilesConfig = pure id-#endif---- -------------------------------------------------------------------------- ----- Tools for parsing configuration files--#ifdef REMOTE_CONFIGS-type ConfigFileParser μ =-    ( Functor μ-    , Applicative μ-    , MonadIO μ-    , MonadBaseControl IO μ-    , MonadError T.Text μ-    )-#else-type ConfigFileParser μ =-    ( Functor μ-    , Applicative μ-    , MonadIO μ-    , MonadError T.Text μ-    )-#endif--parseConfigFiles-    ∷ (ConfigFileParser μ, FromJSON (α → α))-    ⇒ ConfigFilesConfig-    → α-        -- ^ default configuration value-    → [ConfigFile]-        -- ^ list of configuration file paths-    → μ α-parseConfigFiles conf = foldM $ \val file →-    readConfigFile conf file <*> pure val--readConfigFile-    ∷ (ConfigFileParser μ, FromJSON (α → α))-    ⇒ ConfigFilesConfig-    → ConfigFile-        -- ^ file path-    → μ (α → α)-readConfigFile _conf file =-#ifdef REMOTE_CONFIGS-    if isRemote file then loadRemote _conf file else loadLocal file-#else-    loadLocal file-#endif--loadLocal-    ∷ (Functor μ, MonadIO μ, MonadError T.Text μ, FromJSON (α → α))-    ⇒ ConfigFile-        -- ^ file path-    → μ (α → α)-loadLocal path = do-    validateFilePath "config-file" (T.unpack file)-    exists ← (True <$ validateFile "config-file" (T.unpack file)) `catchError` \e → case path of-        ConfigFileOptional _ → return False-        ConfigFileRequired _ → throwError $ "failed to read config file: " ⊕ e-    if exists-      then-        liftIO (Yaml.decodeFileEither (T.unpack file)) >>= \case-            Left e → throwError $ "failed to parse configuration file " ⊕ file ⊕ ": " ⊕ sshow e-            Right r → return r-      else-        return id-  where-    file = getConfigFile path--#ifdef REMOTE_CONFIGS-isRemote-    ∷ ConfigFile-    → Bool-isRemote path = L.any (`T.isPrefixOf` getConfigFile path) ["http://", "https://"]--loadRemote-    ∷ (ConfigFileParser μ, FromJSON (α → α))-    ⇒ ConfigFilesConfig-    → ConfigFile-        -- ^ URL-    → μ (α → α)-loadRemote conf path = do-    validateHttpOrHttpsUrl "config-file" (T.unpack url)-    dat ← (Just <$> doHttp) `catchAnyDeep` \e →-        case path of-            ConfigFileOptional _ → do-                liftIO ∘ T.hPutStrLn stderr $ "WARNING: failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e-                return Nothing-            ConfigFileRequired _ → throwError $ "failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e--    case dat of-        Nothing → return id-        Just d → case Yaml.decodeEither' d of-            Left e → throwError $ "failed to parse remote configuration " ⊕ url ⊕ ": " ⊕ sshow e-            Right r → return r-  where-    url = getConfigFile path-    policy = _cfcHttpsPolicy conf-    doHttp = LB.toStrict ∘ HTTP.responseBody <$> liftIO × httpWithValidationPolicy url policy #endif  -- -------------------------------------------------------------------------- --

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

@@ -27,6 +27,7 @@  -- * Misc Utils , (&)+, (<&>) , sshow , exceptT , errorT@@ -47,7 +48,7 @@  import Prelude.Unicode -infixl 1 &+infixl 1 &, <&>  -- -------------------------------------------------------------------------- -- -- Lenses@@ -104,6 +105,10 @@ (&) ∷ α → (α → β) → β (&) = flip ($) {-# INLINE (&) #-}++(<&>) ∷ Functor φ ⇒ φ α → (α → β) → φ β+(<&>) = flip fmap+{-# INLINE (<&>) #-}  sshow     ∷ (Show α, IsString τ)

@@ -0,0 +1,221 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Configuration.Utils.Internal.ConfigFileReader+-- Description: Internal Tools for Parsing Configuration Files+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+module Configuration.Utils.Internal.ConfigFileReader+(+  parseConfigFiles+, readConfigFile+, ConfigFileFormat(..)++-- * Local Config Files+, loadLocal++#ifdef REMOTE_CONFIGS+-- * Remote Config Files+, isRemote+, loadRemote+, yamlMimeType+, jsonMimeType+, contentType+, requestHeaders+#endif+) where++import Configuration.Utils.ConfigFile+import Configuration.Utils.Internal+import Configuration.Utils.Validation++import Control.Applicative+import Control.DeepSeq (NFData)+import Control.Monad.Except hiding (mapM_)++import qualified Data.ByteString.Char8 as B8+import qualified Data.CaseInsensitive as CI+import Data.Monoid.Unicode+import qualified Data.Text as T+import Data.Typeable+import qualified Data.Yaml as Yaml++import GHC.Generics++import Prelude hiding (concatMap, mapM_, any)+import Prelude.Unicode++#ifdef REMOTE_CONFIGS+import Configuration.Utils.Internal.HttpsCertPolicy++import Control.Exception.Enclosed+import Control.Monad.Trans.Control++import qualified Data.ByteString.Lazy as LB+import qualified Data.List as L+import Data.String+import qualified Data.Text.IO as T++import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types.Header as HTTP++import System.IO+#endif++-- -------------------------------------------------------------------------- --+-- Tools for parsing configuration files++#ifdef REMOTE_CONFIGS+type ConfigFileParser μ =+    ( Functor μ+    , Applicative μ+    , MonadIO μ+    , MonadBaseControl IO μ+    , MonadError T.Text μ+    )+#else+type ConfigFileParser μ =+    ( Functor μ+    , Applicative μ+    , MonadIO μ+    , MonadError T.Text μ+    )+#endif++parseConfigFiles+    ∷ (ConfigFileParser μ, FromJSON (α → α))+    ⇒ ConfigFilesConfig+    → α+        -- ^ default configuration value+    → [ConfigFile]+        -- ^ list of configuration file paths+    → μ α+parseConfigFiles conf = foldM $ \val file →+    readConfigFile conf file <*> pure val++readConfigFile+    ∷ (ConfigFileParser μ, FromJSON (α → α))+    ⇒ ConfigFilesConfig+    → ConfigFile+        -- ^ file path+    → μ (α → α)+readConfigFile _conf file =+#ifdef REMOTE_CONFIGS+    if isRemote file then loadRemote _conf file else loadLocal file+#else+    loadLocal file+#endif++fileType ∷ T.Text → ConfigFileFormat+fileType f+    | CI.foldCase ".yaml" `T.isSuffixOf` CI.foldCase f = Yaml+    | CI.foldCase ".yml" `T.isSuffixOf` CI.foldCase f = Yaml+    | CI.foldCase ".json" `T.isSuffixOf` CI.foldCase f = Json+    | CI.foldCase ".js" `T.isSuffixOf` CI.foldCase f = Json+    | otherwise = Other++loadLocal+    ∷ (Functor μ, MonadIO μ, MonadError T.Text μ, FromJSON (α → α))+    ⇒ ConfigFile+        -- ^ file path+    → μ (α → α)+loadLocal path = do+    validateFilePath "config-file" (T.unpack file)+    exists ← (True <$ validateFile "config-file" (T.unpack file)) `catchError` \e → case path of+        ConfigFileOptional _ → return False+        ConfigFileRequired _ → throwError $ "failed to read config file: " ⊕ e+    if exists+      then+        liftIO (parser (fileType file) file) >>= \case+            Left e → throwError $ "failed to parse configuration file " ⊕ file ⊕ ": " ⊕ sshow e+            Right r → return r+      else+        return id+  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)++data ConfigFileFormat+    = Yaml+    | Json+    | Other+    deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)++instance NFData ConfigFileFormat++#ifdef REMOTE_CONFIGS+isRemote+    ∷ ConfigFile+    → Bool+isRemote path = L.any (`T.isPrefixOf` getConfigFile path) ["http://", "https://"]++yamlMimeType ∷ IsString s ⇒ [s]+yamlMimeType = map fromString ["application/x-yaml", "text/yaml"]++-- | Defined in  RFC 4627+--+jsonMimeType ∷ IsString s ⇒ [s]+jsonMimeType = map fromString ["application/json"]++contentType+    ∷ B8.ByteString+        -- ^ value of an HTTP @Content-Type@ header+    → ConfigFileFormat+contentType headerValue+    | CI.foldCase "yaml" `B8.isInfixOf` CI.foldCase headerValue = Yaml+    | CI.foldCase "json" `B8.isInfixOf` CI.foldCase headerValue = Json+    | otherwise = Other++loadRemote+    ∷ (ConfigFileParser μ, FromJSON (α → α))+    ⇒ ConfigFilesConfig+    → ConfigFile+        -- ^ URL+    → μ (α → α)+loadRemote conf path = do+    validateHttpOrHttpsUrl "config-file" (T.unpack url)+    result ← (Just <$> doHttp) `catchAnyDeep` \e →+        case path of+            ConfigFileOptional _ → do+                liftIO ∘ T.hPutStrLn stderr $ "WARNING: failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e+                return Nothing+            ConfigFileRequired _ → throwError $ "failed to download remote configuration file " ⊕ url ⊕ ": " ⊕ sshow e++    case result of+        Nothing → return id+        Just (format, d) → case (parser format) d of+            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'++    url = getConfigFile path+    policy = _cfcHttpsPolicy conf+    doHttp = liftIO $ do+        request ← (HTTP.parseUrl $ T.unpack url)+            <&> over requestHeaders ((:) acceptHeader)+        resp ← httpWithValidationPolicy request policy+        let format = maybe Other contentType ∘ L.lookup HTTP.hContentType $ HTTP.responseHeaders resp+        return (format, LB.toStrict (HTTP.responseBody resp))++    acceptHeader = (HTTP.hAccept, B8.intercalate "," (yamlMimeType ⊕ jsonMimeType))++requestHeaders ∷ Lens' HTTP.Request HTTP.RequestHeaders+requestHeaders = lens HTTP.requestHeaders $ \s a → s { HTTP.requestHeaders = a }++#endif+

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

@@ -25,6 +25,7 @@  import Configuration.Utils import Configuration.Utils.Internal+import Configuration.Utils.Internal.ConfigFileReader  import Control.Monad @@ -43,37 +44,74 @@ -- main  main ∷ IO ()-main =-    withConfigFile config0 $ \tmpPath0 →-    withConfigFileText config1Part$ \tmpPath1 → do+main = do -#ifdef REMOTE_CONFIGS-    withConfigFileServer [("config0", ConfigType config0)] [("config1", config1Part), ("invalid", "invalid: invalid")] $ do-#endif-        (successes, failures) ← L.partition id <$> sequence-            × tests0-            ⊕ testsConfigFile [tmpPath0, tmpPath1]-            ⊕ tests2Files1 [tmpPath0, tmpPath1]-            ⊕ tests2Files2 "local-" (tmpPath0) (tmpPath1)-            ⊕ tests2Files3 "local-" (tmpPath0) (tmpPath1)+    -- run tests+    localResults ← sequence+        × tests0+        ⊕ monoidUpdateTests pkgInfo+        ⊕ boolOptionTests pkgInfo+    localFileResults ← localFileTests+    remoteResults ← remoteTests+    helpResults ← helpTests++    -- report results+    let (successes, failures) = L.partition id+            × localResults+            ⊕ remoteResults+            ⊕ localFileResults+            ⊕ helpResults++    T.putStrLn $ "success: " ⊕ sshow (length successes)+    T.putStrLn $ "failures: " ⊕ sshow (length failures)+    unless (length failures ≡ 0) $ do+        error "test suite failed"++-- -------------------------------------------------------------------------- --+-- Test categories++helpTests ∷ IO [Bool]+helpTests =+    withConfigFile Yaml config0 $ \tmpPath0 →+    withConfigFile Json config1Part $ \tmpPath1 → sequence+        × testPrintHelp [tmpPath0, tmpPath1]++localFileTests ∷ IO [Bool]+localFileTests = concat <$> mapM run+    [ (Yaml, Yaml, "yaml-yaml-")+    , (Json, Json, "json-json-")+    , (Yaml, Json, "yaml-json-")+    , (Json, Yaml, "json-yaml-")+    ]+  where+    run (format1, format2, label) =+        withConfigFile format1 config0 $ \tmpPath0 →+        withConfigFile format2 config1Part $ \tmpPath1 → sequence+            × testsConfigFile ("configFile-" ⊕ label) [tmpPath0, tmpPath1]+            ⊕ tests2Files1 ("local-" ⊕ label) [tmpPath0, tmpPath1]+            ⊕ tests2Files2 ("local-" ⊕ label) (tmpPath0) (tmpPath1)+            ⊕ tests2Files3 ("local-" ⊕ label) (tmpPath0) (tmpPath1)++remoteTests ∷ IO [Bool] #ifdef REMOTE_CONFIGS-            ⊕ tests2Files2 "remote-" (serverUrl ⊕ "/config0") (serverUrl ⊕ "/config1")-            ⊕ tests2Files3 "remote-" (serverUrl ⊕ "/config0") (serverUrl ⊕ "/config1")+remoteTests = concat <$> mapM run+    [ (Just Yaml, "yaml")+    , (Just Json, "json")+    ]+  where+    typedConfigs = [("config0", ConfigType config0), ("config1", ConfigType config1Part)]+    textConfigs = [("invalid", "invalid: invalid")]++    run (format, label) = withConfigFileServer typedConfigs textConfigs format $+        sequence+            × tests2Files2 ("remote-" ⊕ label) (serverUrl ⊕ "/config0") (serverUrl ⊕ "/config1")+            ⊕ tests2Files3 ("remote-" ⊕ label) (serverUrl ⊕ "/config0") (serverUrl ⊕ "/config1")             ⊕ testsInvalidUrl             ⊕ testsTlsUrl+#else+remoteTests = return [] #endif-            ⊕ monoidUpdateTests pkgInfo-            ⊕ boolOptionTests pkgInfo-            ⊕ testPrintHelp [tmpPath0, tmpPath1] -        T.putStrLn $ "success: " ⊕ sshow (length successes)-        T.putStrLn $ "failures: " ⊕ sshow (length failures)-        unless (length failures ≡ 0) $ do-            debug $ do-                T.readFile (T.unpack tmpPath0) >>= T.putStrLn-                T.readFile (T.unpack tmpPath1) >>= T.putStrLn-            error "test suite failed"- -- -------------------------------------------------------------------------- -- -- Test Cases @@ -87,10 +125,10 @@   where     configFiles = zipWith ($) (ConfigFileRequired : repeat ConfigFileOptional) files -testsConfigFile ∷ [T.Text] → [IO Bool]-testsConfigFile files =-    [ runTest pkgInfo (mainInfoConfigFile configFiles0) "config-file-1" True [trueAssertion []]-    , runTest pkgInfo (mainInfoConfigFile configFiles1) "config-file-2" False [trueAssertion []]+testsConfigFile ∷ T.Text → [T.Text] → [IO Bool]+testsConfigFile prefix files =+    [ runTest pkgInfo (mainInfoConfigFile configFiles0) (prefix ⊕ "-1") True [trueAssertion []]+    , runTest pkgInfo (mainInfoConfigFile configFiles1) (prefix ⊕ "-2") False [trueAssertion []]     ]   where     configFiles0 = zipWith ($) (ConfigFileRequired : repeat ConfigFileOptional) (files ⊕ ["./invalid"])@@ -133,10 +171,10 @@  -- | Tests with two configuration files ---tests2Files1 ∷ [T.Text] → [IO Bool]-tests2Files1 files =-    twoFileCasesC0C1 "2files-1-" files (trueAssertion [])-    ⊕ twoFileCasesC1C0 "2files-1-" selif (trueAssertion [])+tests2Files1 ∷ T.Text → [T.Text] → [IO Bool]+tests2Files1 prefix files =+    twoFileCasesC0C1 (prefix ⊕ "2files-1-") files (trueAssertion [])+    ⊕ twoFileCasesC1C0 (prefix ⊕ "2files-1-") selif (trueAssertion [])   where     selif = reverse files @@ -144,7 +182,7 @@ -- tests2Files2     ∷ T.Text-        -- ^ test label prefix+        -- ^ test label suffix     → T.Text         -- ^ file for config0     → T.Text@@ -161,7 +199,7 @@ -- tests2Files3     ∷ T.Text-        -- ^ test label prefix+        -- ^ test label suffix     → T.Text         -- ^ file for config0     → T.Text@@ -281,11 +319,12 @@  -- | A partial version of configuration 1 ---config1Part ∷ T.Text-config1Part = T.unlines-    [ "domain: " ⊕ T.pack (view domain config1)-    , "auth:"-    , "    user: " ⊕ T.pack (view (auth ∘ user) config1)+config1Part ∷ Value+config1Part = object+    [ "domain" .= view domain config1+    , "auth" .= object+        [ "user" .= view (auth ∘ user) config1+        ]     ]  mainInfo ∷ ProgramInfoValidate HttpURL []

@@ -46,11 +46,13 @@  import Configuration.Utils import Configuration.Utils.Internal+import Configuration.Utils.Internal.ConfigFileReader  import Control.Exception import Control.Monad  import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as LB import Data.IORef import Data.Monoid.Unicode import qualified Data.Text as T@@ -66,7 +68,7 @@  #ifdef REMOTE_CONFIGS import Control.Concurrent-import qualified Data.ByteString.Lazy as LB+import qualified Data.List as L import Data.Maybe import qualified Data.Text.Encoding as T import qualified Network.Wai as WAI@@ -178,21 +180,27 @@  withConfigFile     ∷ ToJSON γ-    ⇒ γ+    ⇒ ConfigFileFormat+    → γ     → (T.Text → IO α)     → IO α-withConfigFile config inner =-    withTempFile "." "tmp_TestExample.yml" $ \tmpPath tmpHandle → do-        B8.hPutStrLn tmpHandle ∘ Yaml.encode $ config+withConfigFile format config inner =+    withTempFile "." ("tmp_TestExample." ⊕ suffix format) $ \tmpPath tmpHandle → do+        B8.hPutStrLn tmpHandle ∘ formatter format $ config         hClose tmpHandle         inner $ T.pack tmpPath+  where+    suffix Json = "json"+    suffix _ = "yaml"+    formatter Json = LB.toStrict ∘ encode+    formatter _ = Yaml.encode  withConfigFileText     ∷ T.Text     → (T.Text → IO α)     → IO α withConfigFileText configText inner =-    withTempFile "." "tmp_TestExample.yml" $ \tmpPath tmpHandle → do+    withTempFile "." "tmp_TestExample.txt" $ \tmpPath tmpHandle → do         T.hPutStrLn tmpHandle configText         hClose tmpHandle         inner $ T.pack tmpPath@@ -207,24 +215,38 @@ withConfigFileServer     ∷ [(T.Text, ConfigType)]     → [(T.Text, T.Text)]+    → Maybe ConfigFileFormat     → IO α     → IO α-withConfigFileServer configs configTexts inner = do-    void ∘ forkIO $ WARP.run serverPort app-    void ∘ forkIO $ WARP.runTLS tlsSettings (warpSettings serverTlsPort) app-    inner+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+   where     app req respond = do-        let maybeBody = LB.fromStrict <$> do++        let format = fromMaybe Other $ maybeFormat+                <|> (contentType <$> L.lookup HTTP.hAccept × WAI.requestHeaders req)++            maybeBody = LB.fromStrict <$> do                 p ← listToMaybe $ WAI.pathInfo req                 do-                    Yaml.encode <$> lookup p configs+                    formatter format <$> lookup p configs                     <|>                     (T.encodeUtf8 <$> lookup p configTexts)          respond $ case maybeBody of             Just body → WAI.responseLBS HTTP.status200 [] body-            Nothing → WAI.responseLBS HTTP.status404 [] "resource not found"+            Nothing → WAI.responseLBS HTTP.status404 [contentTypeHeader format] "resource not found"++    formatter Json = LB.toStrict ∘ encode+    formatter _ = Yaml.encode++    contentTypeHeader Json = (HTTP.hContentType, head jsonMimeType)+    contentTypeHeader _ = (HTTP.hContentType, head yamlMimeType)  serverPort ∷ Int serverPort = 8283

@@ -21,6 +21,7 @@  import Configuration.Utils import Configuration.Utils.Internal+import Configuration.Utils.Internal.ConfigFileReader import Configuration.Utils.Validation  import qualified Data.HashMap.Strict as HM@@ -102,7 +103,6 @@         Just v' → HM.insert k v' m       where         mv = HM.lookup k m-        (<&>) = flip fmap  -- -------------------------------------------------------------------------- -- -- Text with right append@@ -168,12 +168,12 @@   where     ca = StringConfigR "a"     cb = StringConfigR "b"-    run c (x ∷ Int) b a = withConfigFile c $ \file →+    run c (x ∷ Int) b a = withConfigFile Yaml c $ \file →         runTest pkgInfo (mi [file]) ("stringR-file1-" ⊕ sshow x) b a      run2 c0 c1 (x ∷ Int) b a =-        withConfigFile c0 $ \file0 →-        withConfigFile c1 $ \file1 →+        withConfigFile Json c0 $ \file0 →+        withConfigFile Yaml c1 $ \file1 →         runTest pkgInfo (mi [file0,file1]) ("stringR-file2-" ⊕ sshow x) b a      mi files = set piConfigurationFiles (map ConfigFileRequired files) $@@ -243,12 +243,12 @@   where     ca = StringConfigL "a"     cb = StringConfigL "b"-    run c (x ∷ Int) b a = withConfigFile c $ \file →+    run c (x ∷ Int) b a = withConfigFile Json c $ \file →         runTest pkgInfo (mi [file]) ("stringL-file1-" ⊕ sshow x) b a      run2 c0 c1 (x ∷ Int) b a =-        withConfigFile c0 $ \file0 →-        withConfigFile c1 $ \file1 →+        withConfigFile Yaml c0 $ \file0 →+        withConfigFile Json c1 $ \file1 →         runTest pkgInfo (mi [file0,file1]) ("stringL-file2-" ⊕ sshow x) b a      mi files = set piConfigurationFiles (map ConfigFileRequired files) $