diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/configuration-tools.cabal b/configuration-tools.cabal --- a/configuration-tools.cabal +++ b/configuration-tools.cabal @@ -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 Maintainer: Lars Kuhtz -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, diff --git a/src/Configuration/Utils.hs b/src/Configuration/Utils.hs --- a/src/Configuration/Utils.hs +++ b/src/Configuration/Utils.hs @@ -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@] diff --git a/src/Configuration/Utils/ConfigFile.hs b/src/Configuration/Utils/ConfigFile.hs --- a/src/Configuration/Utils/ConfigFile.hs +++ b/src/Configuration/Utils/ConfigFile.hs @@ -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 -- -------------------------------------------------------------------------- -- diff --git a/src/Configuration/Utils/HttpsCertPolicy.hs b/src/Configuration/Utils/HttpsCertPolicy.hs deleted file mode 100644 --- a/src/Configuration/Utils/HttpsCertPolicy.hs +++ /dev/null @@ -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 --- 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 - diff --git a/src/Configuration/Utils/Internal.hs b/src/Configuration/Utils/Internal.hs --- a/src/Configuration/Utils/Internal.hs +++ b/src/Configuration/Utils/Internal.hs @@ -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 τ) diff --git a/src/Configuration/Utils/Internal/ConfigFileReader.hs b/src/Configuration/Utils/Internal/ConfigFileReader.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Utils/Internal/ConfigFileReader.hs @@ -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 +-- 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 + diff --git a/src/Configuration/Utils/Internal/HttpsCertPolicy.hs b/src/Configuration/Utils/Internal/HttpsCertPolicy.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Utils/Internal/HttpsCertPolicy.hs @@ -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 +-- 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 + diff --git a/test/TestExample.hs b/test/TestExample.hs --- a/test/TestExample.hs +++ b/test/TestExample.hs @@ -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 [] diff --git a/test/TestTools.hs b/test/TestTools.hs --- a/test/TestTools.hs +++ b/test/TestTools.hs @@ -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 diff --git a/test/Tests/MonoidConfig.hs b/test/Tests/MonoidConfig.hs --- a/test/Tests/MonoidConfig.hs +++ b/test/Tests/MonoidConfig.hs @@ -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) $