configuration-tools 0.4.0 → 0.4.1
raw patch · 12 files changed
+178/−195 lines, 12 filesdep +semigroupoidsdep ~basedep ~http-clientsetup-changednew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: semigroupoids
Dependency ranges changed: base, http-client
API changes (from Hackage documentation)
- Configuration.Utils.CommandLine: newtype Const a (b :: k) :: forall k. () => * -> k -> *
- Configuration.Utils.Internal.HttpsCertPolicy: instance GHC.Exception.Exception Configuration.Utils.Internal.HttpsCertPolicy.VerboseTlsException
- Configuration.Utils.Maybe: instance (Data.Aeson.Types.FromJSON.FromJSON (a -> a), Data.Aeson.Types.FromJSON.FromJSON a) => Data.Aeson.Types.FromJSON.FromJSON (GHC.Base.Maybe a -> GHC.Base.Maybe a)
+ Configuration.Utils.CommandLine: infixl 3 <|>
+ Configuration.Utils.CommandLine: newtype Const a (b :: k) :: forall k. () => Type -> k -> Type
+ Configuration.Utils.Internal.HttpsCertPolicy: instance GHC.Exception.Type.Exception Configuration.Utils.Internal.HttpsCertPolicy.VerboseTlsException
+ Configuration.Utils.Maybe: instance (Data.Aeson.Types.FromJSON.FromJSON (a -> a), Data.Aeson.Types.FromJSON.FromJSON a) => Data.Aeson.Types.FromJSON.FromJSON (GHC.Maybe.Maybe a -> GHC.Maybe.Maybe a)
+ Configuration.Utils.Monoid: pLeftSemigroupalUpdate :: Semigroup a => Parser a -> MParser a
+ Configuration.Utils.Monoid: pRightSemigroupalUpdate :: Semigroup a => Parser a -> MParser a
- Configuration.Utils.CommandLine: (<$>) :: Functor f => a -> b -> f a -> f b
+ Configuration.Utils.CommandLine: (<$>) :: Functor f => (a -> b) -> f a -> f b
- Configuration.Utils.CommandLine: (<**>) :: Applicative f => f a -> f a -> b -> f b
+ Configuration.Utils.CommandLine: (<**>) :: Applicative f => f a -> f (a -> b) -> f b
- Configuration.Utils.CommandLine: (<*>) :: Applicative f => f a -> b -> f a -> f b
+ Configuration.Utils.CommandLine: (<*>) :: Applicative f => f (a -> b) -> f a -> f b
- Configuration.Utils.CommandLine: CompletionResult :: String -> IO String -> CompletionResult
+ Configuration.Utils.CommandLine: CompletionResult :: (String -> IO String) -> CompletionResult
- Configuration.Utils.CommandLine: ParserFailure :: String -> (h, ExitCode, Int) -> ParserFailure h
+ Configuration.Utils.CommandLine: ParserFailure :: (String -> (h, ExitCode, Int)) -> ParserFailure h
- Configuration.Utils.CommandLine: abortOption :: () => ParseError -> Mod OptionFields a -> a -> Parser a -> a
+ Configuration.Utils.CommandLine: abortOption :: () => ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
- Configuration.Utils.CommandLine: class Applicative f => Alternative (f :: * -> *)
+ Configuration.Utils.CommandLine: class Applicative f => Alternative (f :: Type -> Type)
- Configuration.Utils.CommandLine: class Functor f => Applicative (f :: * -> *)
+ Configuration.Utils.CommandLine: class Functor f => Applicative (f :: Type -> Type)
- Configuration.Utils.CommandLine: class HasCompleter (f :: * -> *)
+ Configuration.Utils.CommandLine: class HasCompleter (f :: Type -> Type)
- Configuration.Utils.CommandLine: class HasMetavar (f :: * -> *)
+ Configuration.Utils.CommandLine: class HasMetavar (f :: Type -> Type)
- Configuration.Utils.CommandLine: class HasName (f :: * -> *)
+ Configuration.Utils.CommandLine: class HasName (f :: Type -> Type)
- Configuration.Utils.CommandLine: class HasValue (f :: * -> *)
+ Configuration.Utils.CommandLine: class HasValue (f :: Type -> Type)
- Configuration.Utils.CommandLine: data Mod (f :: * -> *) a
+ Configuration.Utils.CommandLine: data Mod (f :: Type -> Type) a
- Configuration.Utils.CommandLine: eitherReader :: () => String -> Either String a -> ReadM a
+ Configuration.Utils.CommandLine: eitherReader :: () => (String -> Either String a) -> ReadM a
- Configuration.Utils.CommandLine: helper :: () => Parser a -> a
+ Configuration.Utils.CommandLine: helper :: () => Parser (a -> a)
- Configuration.Utils.CommandLine: infoOption :: () => String -> Mod OptionFields a -> a -> Parser a -> a
+ Configuration.Utils.CommandLine: infoOption :: () => String -> Mod OptionFields (a -> a) -> Parser (a -> a)
- Configuration.Utils.CommandLine: liftA :: Applicative f => a -> b -> f a -> f b
+ Configuration.Utils.CommandLine: liftA :: Applicative f => (a -> b) -> f a -> f b
- Configuration.Utils.CommandLine: liftA2 :: Applicative f => a -> b -> c -> f a -> f b -> f c
+ Configuration.Utils.CommandLine: liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
- Configuration.Utils.CommandLine: liftA3 :: Applicative f => a -> b -> c -> d -> f a -> f b -> f c -> f d
+ Configuration.Utils.CommandLine: liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
- Configuration.Utils.CommandLine: maybeReader :: () => String -> Maybe a -> ReadM a
+ Configuration.Utils.CommandLine: maybeReader :: () => (String -> Maybe a) -> ReadM a
- Configuration.Utils.CommandLine: mkCompleter :: String -> IO [String] -> Completer
+ Configuration.Utils.CommandLine: mkCompleter :: (String -> IO [String]) -> Completer
- Configuration.Utils.CommandLine: newtype WrappedArrow (a :: * -> * -> *) b c
+ Configuration.Utils.CommandLine: newtype WrappedArrow (a :: Type -> Type -> Type) b c
- Configuration.Utils.CommandLine: newtype WrappedMonad (m :: * -> *) a
+ Configuration.Utils.CommandLine: newtype WrappedMonad (m :: Type -> Type) a
- Configuration.Utils.CommandLine: optional :: Alternative f => f a -> f Maybe a
+ Configuration.Utils.CommandLine: optional :: Alternative f => f a -> f (Maybe a)
- Configuration.Utils.CommandLine: overFailure :: () => ParserHelp -> ParserHelp -> ParserResult a -> ParserResult a
+ Configuration.Utils.CommandLine: overFailure :: () => (ParserHelp -> ParserHelp) -> ParserResult a -> ParserResult a
- Configuration.Utils.CommandLine: showDefaultWith :: () => a -> String -> Mod f a
+ Configuration.Utils.CommandLine: showDefaultWith :: () => (a -> String) -> Mod f a
- Configuration.Utils.CommandLine: style :: () => Doc -> Doc -> Mod f a
+ Configuration.Utils.CommandLine: style :: () => (Doc -> Doc) -> Mod f a
- Configuration.Utils.Internal.HttpsCertPolicy: HttpsCertPolicy :: !Bool -> !(HashMap ServiceID Fingerprint) -> HttpsCertPolicy
+ Configuration.Utils.Internal.HttpsCertPolicy: HttpsCertPolicy :: !Bool -> !HashMap ServiceID Fingerprint -> HttpsCertPolicy
- Configuration.Utils.Internal.HttpsCertPolicy: [_certPolicyHostFingerprints] :: HttpsCertPolicy -> !(HashMap ServiceID Fingerprint)
+ Configuration.Utils.Internal.HttpsCertPolicy: [_certPolicyHostFingerprints] :: HttpsCertPolicy -> !HashMap ServiceID Fingerprint
- Configuration.Utils.Validation: validateBool :: (MonadError Text m) => Text -> Bool -> Bool -> m ()
+ Configuration.Utils.Validation: validateBool :: MonadError Text m => Text -> Bool -> Bool -> m ()
- Configuration.Utils.Validation: validateFalse :: (MonadError Text m) => Text -> Bool -> m ()
+ Configuration.Utils.Validation: validateFalse :: MonadError Text m => Text -> Bool -> m ()
- Configuration.Utils.Validation: validateTrue :: (MonadError Text m) => Text -> Bool -> m ()
+ Configuration.Utils.Validation: validateTrue :: MonadError Text m => Text -> Bool -> m ()
Files
- CHANGELOG.md +5/−1
- Setup.hs +7/−11
- configuration-tools.cabal +76/−85
- examples/Trivial.hs +5/−6
- src/Configuration/Utils.hs +3/−17
- src/Configuration/Utils/CommandLine.hs +3/−5
- src/Configuration/Utils/ConfigFile.hs +5/−6
- src/Configuration/Utils/Internal/ConfigFileReader.hs +3/−4
- src/Configuration/Utils/Internal/HttpsCertPolicy.hs +23/−23
- src/Configuration/Utils/Monoid.hs +32/−17
- src/Configuration/Utils/Operators.hs +1/−2
- src/Configuration/Utils/Setup.hs +15/−18
CHANGELOG.md view
@@ -1,3 +1,8 @@+0.4.1 (2019-05-10)+==================++* Added `pLeftSemigroupalUpdate` and `pRightSemigroupalUpdate`.+ 0.4.0 (2018-08-21) ================== @@ -210,4 +215,3 @@ === First release.-
Setup.hs view
@@ -1,4 +1,5 @@ -- ------------------------------------------------------ --+-- Copyright © 2019 Colin Woodbury <colin@fosskers.ca> -- Copyright © 2015-2018 Lars Kuhtz <lakuhtz@gmail.com> -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ --@@ -102,13 +103,13 @@ #define MIN_VERSION_Cabal(a,b,c) 0 #endif +import qualified Distribution.InstalledPackageInfo as I import Distribution.PackageDescription import Distribution.Simple-import Distribution.Simple.Setup-import qualified Distribution.InstalledPackageInfo as I-import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths+import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex+import Distribution.Simple.Setup import Distribution.Text #if MIN_VERSION_Cabal(2,0,0)@@ -135,14 +136,10 @@ import Prelude hiding (readFile, writeFile) import System.Directory- ( doesFileExist- , doesDirectoryExist- , createDirectoryIfMissing- , getCurrentDirectory- , canonicalizePath- )-import System.FilePath (isDrive, (</>), takeDirectory)+ (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist,+ doesFileExist, getCurrentDirectory) import System.Exit (ExitCode(ExitSuccess))+import System.FilePath (isDrive, takeDirectory, (</>)) -- | Include this function when your setup doesn't contain any -- extra functionality.@@ -466,4 +463,3 @@ ++ "]" where cr = (unwords . words . I.copyright) a-
configuration-tools.cabal view
@@ -1,11 +1,8 @@--- ------------------------------------------------------ ----- Copyright © 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>--- Copyright © 2014-2015 AlephCloud Systems, Inc.--- ------------------------------------------------------ --+cabal-version: 1.24 -Name: configuration-tools-Version: 0.4.0-Synopsis: Tools for specifying and parsing configurations+name: configuration-tools+version: 0.4.1+synopsis: Tools for specifying and parsing configurations description: Tools for specifying and parsing configurations .@@ -28,20 +25,21 @@ and in the API documentation of the modules "Configuration.Utils" and "Configuration.Utils.Setup". -Homepage: https://github.com/alephcloud/hs-configuration-tools-Bug-reports: https://github.com/alephcloud/hs-configuration-tools/issues-License: MIT-License-file: LICENSE-Author: Lars Kuhtz <lakuhtz@gmail.com>-Maintainer: Lars Kuhtz <lakuhtz@gmail.com>-Copyright:+homepage: https://github.com/alephcloud/hs-configuration-tools+bug-reports: https://github.com/alephcloud/hs-configuration-tools/issues+license: MIT+license-file: LICENSE+author: Lars Kuhtz <lakuhtz@gmail.com>+maintainer: Lars Kuhtz <lakuhtz@gmail.com>+copyright:+ (c) 2019 Colin Woodbury <colin@fosskers.ca>, (c) 2015-2018 Lars Kuhtz <lakuhtz@gmail.com>, (c) 2014-2015 AlephCloud, Inc.-Category: Configuration, Console-Build-type: Custom-cabal-version: 1.24+category: Configuration, Console+build-type: Custom tested-with:- GHC==8.4.3+ GHC==8.6.5+ , GHC==8.4.3 , GHC==8.2.2 , GHC==8.0.2 , GHC==7.10.3@@ -64,19 +62,15 @@ location: https://github.com/alephcloud/hs-configuration-tools.git branch: master -source-repository this- type: git- location: https://github.com/alephcloud/hs-configuration-tools.git- tag: 0.4.0- flag remote-configs Description: enable loading of configuration files from HTTP URLs Default: True Manual: True -Library+library hs-source-dirs: src default-language: Haskell2010+ ghc-options: -Wall exposed-modules: Configuration.Utils@@ -95,52 +89,52 @@ Configuration.Utils.Internal.HttpsCertPolicy build-depends:- Cabal >= 1.24,- aeson >= 0.7.0.6,- ansi-wl-pprint >= 0.6,- attoparsec >= 0.11.3.4,- base >= 4.8 && < 5.0,- 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,- filepath >= 1.3.0.1,- mtl >= 2.2,- network-uri >= 2.6.0.1,- optparse-applicative >= 0.11.0.2,- process >= 1.2.0.0,- profunctors >= 4.0.4,- semigroups >= 0.18,- text >= 1.0,- transformers >= 0.4,- unordered-containers >= 0.2.4.0,- yaml >= 0.8.8.3+ Cabal >= 1.24+ , aeson >= 0.7.0.6+ , ansi-wl-pprint >= 0.6+ , attoparsec >= 0.11.3.4+ , base >= 4.8 && < 5+ , 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+ , filepath >= 1.3.0.1+ , mtl >= 2.2+ , network-uri >= 2.6.0.1+ , optparse-applicative >= 0.11.0.2+ , process >= 1.2.0.0+ , profunctors >= 4.0.4+ , semigroups >= 0.18+ , semigroupoids >= 5.0+ , text >= 1.0+ , transformers >= 0.4+ , unordered-containers >= 0.2.4.0+ , yaml >= 0.8.8.3 if flag(remote-configs) build-depends:- base64-bytestring >= 1.0,- connection >= 0.2,- data-default >= 0.5,- 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,- x509-system >= 1.5,- x509-validation >= 1.5.1+ base64-bytestring >= 1.0+ , connection >= 0.2+ , data-default >= 0.5+ , enclosed-exceptions >= 1.0+ , http-client >= 0.4.30+ , http-client-tls >= 0.2+ , http-types >= 0.8+ , monad-control >= 1.0+ , tls >= 1.2+ , x509 >= 1.5+ , x509-system >= 1.5+ , x509-validation >= 1.5.1 if flag(remote-configs) cpp-options: -DREMOTE_CONFIGS +test-suite url-example-test+ default-language: Haskell2010 ghc-options: -Wall--Test-Suite url-example-test type: exitcode-stdio-1.0- default-language: Haskell2010 main-is: TestExample.hs hs-source-dirs: examples, test @@ -151,39 +145,36 @@ Tests.MonoidConfig build-depends:- Cabal >= 1.24,- base >= 4.8 && < 5.0,- base-unicode-symbols >= 0.2.2.4,- bytestring >= 0.10,- configuration-tools,- mtl >= 2.2,- text >= 1.0,- transformers >= 0.4,- unordered-containers >= 0.2.4.0,- yaml >= 0.8.8.3+ Cabal >= 1.24+ , base >= 4.8 && < 5+ , base-unicode-symbols >= 0.2.2.4+ , bytestring >= 0.10+ , configuration-tools+ , mtl >= 2.2+ , text >= 1.0+ , transformers >= 0.4+ , unordered-containers >= 0.2.4.0+ , yaml >= 0.8.8.3 if flag(remote-configs) build-depends:- enclosed-exceptions >= 1.0,- http-types >= 0.8,- monad-control >= 1.0,- wai >= 3.0,- warp >= 3.0,- warp-tls >= 3.0+ enclosed-exceptions >= 1.0+ , http-types >= 0.8+ , monad-control >= 1.0+ , wai >= 3.0+ , warp >= 3.0+ , warp-tls >= 3.0 cpp-options: -DREMOTE_CONFIGS +test-suite trivial+ default-language: Haskell2010 ghc-options: -Wall--Test-Suite trivial type: exitcode-stdio-1.0- default-language: Haskell2010 main-is: Trivial.hs hs-source-dirs: examples build-depends:- base >= 4.8 && < 5.0,- base-unicode-symbols >= 0.2.2.4,- configuration-tools-- ghc-options: -Wall+ base >= 4.8 && < 5+ , base-unicode-symbols >= 0.2.2.4+ , configuration-tools
examples/Trivial.hs view
@@ -2,14 +2,14 @@ -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- -{-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-} -module Main-( main-) where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main ( main ) where+ import Configuration.Utils import PkgInfo_trivial @@ -21,4 +21,3 @@ main ∷ IO () main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world"-
src/Configuration/Utils.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-}@@ -125,8 +124,8 @@ import Configuration.Utils.CommandLine import Configuration.Utils.ConfigFile-import qualified Configuration.Utils.Internal.ConfigFileReader as CF import Configuration.Utils.Internal+import qualified Configuration.Utils.Internal.ConfigFileReader as CF import Configuration.Utils.Maybe import Configuration.Utils.Monoid import Configuration.Utils.Operators@@ -148,7 +147,7 @@ import qualified Options.Applicative as O -import Prelude hiding (concatMap, mapM_, any)+import Prelude hiding (any, concatMap, mapM_) import Prelude.Unicode import System.IO@@ -317,18 +316,6 @@ , _mainConfig ∷ !a } --- | A flag that indicates that the application should output the effective--- configuration and exit.----printConfig ∷ Lens' (AppConfiguration a) Bool-printConfig = lens _printConfig $ \s a → s { _printConfig = a }---- | The 'ConfigFilesConfig' collects all parameters that determine how--- configuration files are loaded and parsed.----configFilesConfig ∷ Lens' (AppConfiguration a) ConfigFilesConfig-configFilesConfig = lens _configFilesConfig $ \s a → s { _configFilesConfig = a }- -- | A list of configuration file locations. Configuration file locations are -- set either statically in the code or are provided dynamically on the command -- line via @--config-file@ options.@@ -695,4 +682,3 @@ when (any (const True) warnings) $ do T.hPutStrLn stderr "WARNINGS:" mapM_ (\w → T.hPutStrLn stderr $ "warning: " ⊕ w) warnings-
src/Configuration/Utils/CommandLine.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -68,7 +67,7 @@ import qualified Options.Applicative as O import qualified Options.Applicative.Builder.Internal as O -import Prelude hiding (concatMap, mapM_, any)+import Prelude hiding (any, concatMap, mapM_) import qualified Text.ParserCombinators.ReadP as P hiding (string) @@ -265,6 +264,5 @@ eitherReadP label p s = case [ x | (x,"") ← P.readP_to_S p (T.unpack s) ] of [x] → Right x- [] → Left $ "eitherReadP: no parse for " ⊕ label ⊕ " of " ⊕ s- _ → Left $ "eitherReadP: ambigous parse for " ⊕ label ⊕ " of " ⊕ s-+ [] → Left $ "eitherReadP: no parse for " ⊕ label ⊕ " of " ⊕ s+ _ → Left $ "eitherReadP: ambigous parse for " ⊕ label ⊕ " of " ⊕ s
src/Configuration/Utils/ConfigFile.hs view
@@ -75,7 +75,7 @@ import qualified Data.Text as T import Data.Typeable -import Prelude hiding (concatMap, mapM_, any)+import Prelude hiding (any, concatMap, mapM_) #ifdef REMOTE_CONFIGS import Configuration.Utils.Internal.HttpsCertPolicy@@ -276,8 +276,7 @@ -- Miscellaneous Utilities dropAndUncaml ∷ Int → String → String-dropAndUncaml i l- | length l < i + 1 = l- | otherwise = let (h:t) = drop i l- in toLower h : concatMap (\x → if isUpper x then "-" ⊕ [toLower x] else [x]) t-+dropAndUncaml _ "" = ""+dropAndUncaml i l = case drop i l of+ [] -> l+ (h:t) -> toLower h : concatMap (\x → if isUpper x then "-" ⊕ [toLower x] else [x]) t
src/Configuration/Utils/Internal/ConfigFileReader.hs view
@@ -43,8 +43,8 @@ import Control.Applicative import Control.DeepSeq (NFData) import Control.Monad-import Control.Monad.IO.Class import Control.Monad.Error.Class+import Control.Monad.IO.Class import qualified Data.ByteString.Char8 as B8 import Data.Monoid.Unicode@@ -54,7 +54,7 @@ import GHC.Generics -import Prelude hiding (concatMap, mapM_, any)+import Prelude hiding (any, concatMap, mapM_) import Prelude.Unicode #ifdef REMOTE_CONFIGS@@ -208,7 +208,7 @@ url = getConfigFile path policy = _cfcHttpsPolicy conf doHttp = liftIO $ do- request ← (HTTP.parseUrl $ T.unpack url)+ request ← (HTTP.parseUrlThrow $ T.unpack url) <&> over requestHeaders ((:) acceptHeader) resp ← httpWithValidationPolicy request policy let format = maybe Other contentType ∘ L.lookup HTTP.hContentType $ HTTP.responseHeaders resp@@ -220,4 +220,3 @@ requestHeaders = lens HTTP.requestHeaders $ \s a → s { HTTP.requestHeaders = a } #endif-
src/Configuration/Utils/Internal/HttpsCertPolicy.hs view
@@ -1,7 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-} @@ -41,40 +40,41 @@ import Configuration.Utils.Operators import Configuration.Utils.Validation -import Control.Exception (catches, Handler(..))-import Control.Monad.Writer hiding (mapM_)+import Control.Arrow (second)+import Control.Exception (Exception, Handler(..), catches, throwIO)+import Control.Monad.State+import Control.Monad.Writer +import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as LB+import Data.Default (def)+import qualified Data.HashMap.Strict as HM+import Data.IORef+import qualified Data.List as L import Data.Maybe import Data.Monoid.Unicode import Data.String import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Typeable+import qualified Data.X509 as TLS+import qualified Data.X509.Validation as TLS import qualified Options.Applicative as O -import Prelude hiding (concatMap, mapM_, any)+import Prelude hiding (any, concatMap, mapM_) 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 qualified Network.TLS.Extra as TLS++import qualified System.X509 as TLS+ 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@@ -144,7 +144,7 @@ → HttpsCertPolicy → IO (HTTP.Response LB.ByteString) simpleHttpWithValidationPolicy url policy = do- request ← (HTTP.parseUrl $ T.unpack url)+ request ← HTTP.parseUrlThrow $ T.unpack url httpWithValidationPolicy request policy httpWithValidationPolicy@@ -154,7 +154,8 @@ httpWithValidationPolicy request policy = do certVar ← newIORef Nothing settings ← getSettings policy certVar- HTTP.withManager settings (HTTP.httpLbs request) `catches`+ mgr <- HTTP.newManager settings+ HTTP.httpLbs request mgr `catches` [ Handler $ \(e ∷ TLS.TLSException) → do cert ← readIORef certVar handleTlsException request cert e@@ -285,7 +286,7 @@ -- and 'TLS.connectTo' are going to overwrite this anyways. -- tlsSettings certstore = (TLS.defaultParamsClient "" "")- { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_all }+ { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default } , TLS.clientShared = def { TLS.sharedCAStore = certstore , TLS.sharedValidationCache = validationCache@@ -325,4 +326,3 @@ ⊕ " but got fingerprint: " ⊕ printFingerprint fingerprint where printFingerprint (TLS.Fingerprint f) = fromString ∘ B8.unpack ∘ B64.encode $ f-
src/Configuration/Utils/Monoid.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-} @@ -13,33 +11,37 @@ -- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com> -- Stability: experimental ----- The distinction between appending on the left and appending on--- the right is important for monoids that are sensitive to ordering--- such as 'List'. It is also of relevance for monoids with set semantics--- with non-extensional equality such as `HashMap`.+-- The distinction between appending on the left and appending on the right is+-- important for monoids that are sensitive to ordering such as 'List'. It is+-- also of relevance for monoids with set semantics with non-extensional+-- equality such as `HashMap`. -- module Configuration.Utils.Monoid-( LeftMonoidalUpdate-, leftMonoidalUpdate-, fromLeftMonoidalUpdate-, pLeftMonoidalUpdate-, RightMonoidalUpdate-, rightMonoidalUpdate-, fromRightMonoidalUpdate-, pRightMonoidalUpdate-) where+ ( LeftMonoidalUpdate+ , leftMonoidalUpdate+ , fromLeftMonoidalUpdate+ , pLeftMonoidalUpdate+ , pLeftSemigroupalUpdate+ , RightMonoidalUpdate+ , rightMonoidalUpdate+ , fromRightMonoidalUpdate+ , pRightMonoidalUpdate+ , pRightSemigroupalUpdate+ ) where import Configuration.Utils.CommandLine import Configuration.Utils.Internal -import Control.Monad.Writer hiding (mapM_)+import Control.Monad.Writer hiding (mapM_, (<>)) import Data.Aeson+import qualified Data.List.NonEmpty as NEL import Data.Semigroup+import Data.Semigroup.Foldable (fold1) import qualified Options.Applicative.Types as O -import Prelude hiding (concatMap, mapM_, any)+import Prelude hiding (any, concatMap, mapM_) import Prelude.Unicode -- | Update a value by appending on the left. Under normal@@ -99,6 +101,13 @@ pLeftMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a pLeftMonoidalUpdate pElement = mappend ∘ mconcat ∘ reverse <$> many pElement +-- | Like `pLeftMonoidalUpdate`, but works for `Semigroup`s instead. Using this+-- parser requires the input to have at least one copy (say, for flags that can+-- be passed multiple times).+--+pLeftSemigroupalUpdate ∷ Semigroup a ⇒ O.Parser a → MParser a+pLeftSemigroupalUpdate pElement = (<>) ∘ fold1 ∘ NEL.fromList ∘ reverse <$> some pElement+ -- | Update a value by appending on the right. Under normal -- circumstances you'll never use this type directly but only -- its 'FromJSON' instance. See the 'leftMonoidalUpdate' for an example.@@ -129,3 +138,9 @@ pRightMonoidalUpdate ∷ Monoid a ⇒ O.Parser a → MParser a pRightMonoidalUpdate pElement = flip mappend ∘ mconcat <$> many pElement +-- | Like `pRightMonoidalUpdate`, but works for `Semigroup`s instead. Using this+-- parser requires the input to have at least one copy (say, for flags that can+-- be passed multiple times).+--+pRightSemigroupalUpdate ∷ Semigroup a ⇒ O.Parser a → MParser a+pRightSemigroupalUpdate pElement = flip (<>) ∘ fold1 ∘ NEL.fromList <$> some pElement
src/Configuration/Utils/Operators.hs view
@@ -56,7 +56,7 @@ -- | Functional composition for applicative functors. -- (<*<) ∷ Applicative f ⇒ f (b → c) → f (a → b) → f (a → c)-(<*<) a b = pure (.) <*> a <*> b+(<*<) a b = ((.) <$> a) <*> b infixr 4 <*< {-# INLINE (<*<) #-} @@ -109,4 +109,3 @@ infixr 4 ⊙ {-# INLINE (⊙) #-} {-# DEPRECATED (⊙) "use '<*<' instead" #-}-
src/Configuration/Utils/Setup.hs view
@@ -1,9 +1,12 @@ -- ------------------------------------------------------ --+-- Copyright © 2019 Colin Woodbury <colin@fosskers.ca> -- Copyright © 2015-2018 Lars Kuhtz <lakuhtz@gmail.com> -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -102,13 +105,13 @@ #define MIN_VERSION_Cabal(a,b,c) 0 #endif +import qualified Distribution.InstalledPackageInfo as I import Distribution.PackageDescription import Distribution.Simple-import Distribution.Simple.Setup-import qualified Distribution.InstalledPackageInfo as I-import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths+import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex+import Distribution.Simple.Setup import Distribution.Text #if MIN_VERSION_Cabal(2,0,0)@@ -135,14 +138,10 @@ import Prelude hiding (readFile, writeFile) import System.Directory- ( doesFileExist- , doesDirectoryExist- , createDirectoryIfMissing- , getCurrentDirectory- , canonicalizePath- )-import System.FilePath (isDrive, (</>), takeDirectory)+ (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist,+ doesFileExist, getCurrentDirectory) import System.Exit (ExitCode(ExitSuccess))+import System.FilePath (isDrive, takeDirectory, (</>)) -- | Include this function when your setup doesn't contain any -- extra functionality.@@ -275,12 +274,11 @@ updateFile :: FilePath -> B.ByteString -> IO () updateFile fileName content = do- doesFileExist fileName >>= \x -> if x- then do- oldRevisionFile <- B.readFile fileName- when (oldRevisionFile /= content) update- else- update+ x <- doesFileExist fileName+ if | not x -> update+ | otherwise -> do+ oldRevisionFile <- B.readFile fileName+ when (oldRevisionFile /= content) update where update = B.writeFile fileName content @@ -311,7 +309,7 @@ pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString pkgInfoModule moduleName cName pkgDesc bInfo = do- (tag, revision, branch) <- getVCS >>= \x -> case x of+ (tag, revision, branch) <- getVCS >>= \case Just Mercurial -> hgInfo Just Git -> gitInfo _ -> noVcsInfo@@ -466,4 +464,3 @@ ++ "]" where cr = (unwords . words . I.copyright) a-