configuration-tools 0.2.6 → 0.2.7

raw patch · 9 files changed

+569/−53 lines, 9 filesdep +dlistdep +mtldep +network-uriPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: dlist, mtl, network-uri

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• configuration-tools.cabal +16/−6
• constraints +3/−1
• examples/Example.hs +25/−6
• src/Configuration/Utils.hs +130/−35
• src/Configuration/Utils/Http.hs +42/−5
• src/Configuration/Utils/Internal.hs +8/−0
• src/Configuration/Utils/Validation.hs +302/−0
• test/TestExample.hs +33/−0

@@ -1,3 +1,13 @@+0.2.7+=====++*   Added `view` funtion for lenses to `Configuration.Utils.Internal`.++*   Added support for validation of configuration values.++*   Added module `Configuration.Utils.Validation` that provides primitives+    for validating different basic configuration values.+ 0.2.6 ===== 

@@ -3,7 +3,7 @@ -- ------------------------------------------------------ --  Name:                configuration-tools-Version:             0.2.6+Version:             0.2.7 Synopsis:            Tools for specifying and parsing configurations description:     Tools for specifying and parsing configurations@@ -54,7 +54,7 @@ source-repository this     type: git     location: https://github.com/alephcloud/hs-configuration-tools.git-    tag: 0.2.6+    tag: 0.2.7  Library     hs-source-dirs: src@@ -65,6 +65,7 @@         Configuration.Utils         Configuration.Utils.Http         Configuration.Utils.Setup+        Configuration.Utils.Validation      other-modules:         Configuration.Utils.Internal@@ -78,7 +79,10 @@         bytestring >= 0.10.0.2,         case-insensitive >= 1.2,         directory >= 1.2.1.0,+        dlist >= 0.7.1,         errors >= 1.4.3,+        mtl >= 2.2,+        network-uri >= 2.6.0.1,         optparse-applicative >= 0.8.1,         process >= 1.2.0.0,         text >= 1.0,@@ -89,18 +93,24 @@      ghc-options: -Wall -Test-Suite url-example+Test-Suite url-example-test     type: exitcode-stdio-1.0     default-language: Haskell2010-    main-is: Example.hs-    hs-source-dirs: examples+    main-is: TestExample.hs+    hs-source-dirs: examples, test +    other-modules:+        Example+     build-depends:         base >= 4.6 && < 5.0,         base-unicode-symbols >= 0.2.2.4,-        configuration-tools+        configuration-tools,+        errors >= 1.4.3,+        mtl >= 2.2      ghc-options: -Wall+    cpp-options: -DMain=Example  Test-Suite trivial     type: exitcode-stdio-1.0

@@ -12,7 +12,7 @@              case-insensitive ==1.2.0.0,              comonad ==4.2.2,              conduit ==1.2.0.2,-             configuration-tools ==0.2.6,+             configuration-tools ==0.2.7,              containers ==0.5.5.1,              contravariant ==1.2,              deepseq ==1.3.0.2,@@ -32,8 +32,10 @@              monad-control ==0.3.3.0,              mtl ==2.2.1,              nats ==0.2,+             network-uri ==2.6.0.1,              old-locale ==1.0.0.6,              optparse-applicative ==0.11.0.1,+             parsec ==3.1.7,              prelude-extras ==0.4,              pretty ==1.1.1.1,              primitive ==0.5.3.0,

@@ -2,21 +2,30 @@ -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}  module Main ( main+, main_ ) where  import Configuration.Utils++import Control.Monad+import Control.Monad.Except+import Control.Monad.Writer+ import Data.Monoid.Unicode+ import Prelude.Unicode --- This assume usage of cabal with custom Setup.hs+-- This assumes usage of cabal with custom Setup.hs ---import PkgInfo_url_example+import PkgInfo_url_example_test  -- | Specification of the authentication section of a URL. --@@ -42,6 +51,10 @@     , _pwd = ""     } +validateAuth ∷ ConfigValidation Auth []+validateAuth conf =+    when (_user conf ≠ "" && _pwd conf ≡ "") $ tell ["password is empty"]+ instance FromJSON (Auth → Auth) where     parseJSON = withObject "Auth" $ \o → id         <$< user ..: "user" × o@@ -86,6 +99,12 @@     , _path = ""     } +validateHttpURL ∷ ConfigValidation HttpURL []+validateHttpURL conf = do+    validateAuth $ _auth conf+    when (_domain conf ≡ "" && _path conf ≡ "") $+        throwError "domain and path must not both be null"+ instance FromJSON (HttpURL → HttpURL) where     parseJSON = withObject "HttpURL" $ \o → id         <$< auth %.: "auth" × o@@ -112,13 +131,13 @@  -- | Information about the main Application ---mainInfo ∷ ProgramInfo HttpURL-mainInfo = programInfo "HTTP URL" pHttpURL defaultHttpURL+mainInfo ∷ ProgramInfoValidate HttpURL []+mainInfo = programInfoValidate "HTTP URL" pHttpURL defaultHttpURL validateHttpURL  -- This version assumes usage of cabal with custom Setup.hs -- main ∷ IO ()-main = runWithPkgInfoConfiguration mainInfo pkgInfo $ \conf → do+main = runWithPkgInfoConfiguration mainInfo pkgInfo $ \conf →     putStrLn         $ "http://"         ⊕ (_user ∘ _auth) conf@@ -132,7 +151,7 @@ -- This version does not rely on cabal -- main_ ∷ IO ()-main_ = runWithConfiguration mainInfo $ \conf → do+main_ = runWithConfiguration mainInfo $ \conf →     putStrLn         $ "http://"         ⊕ (_user ∘ _auth) conf

@@ -36,6 +36,10 @@ -- 4. an options parser that yields a function that takes a value and updates --    that value with the values provided as command line options. --+-- In addition to the above optionally a validation function may be provided+-- that (recursively) validates a configuration value and returns either+-- an error or a --possibly empty-- list-like structure of warnings.+-- -- The module provides operators and functions that make the implmentation of -- these entities easy for the common case that the configurations are encoded -- mainly as nested records.@@ -56,6 +60,15 @@ , piHelpFooter , piOptionParser , piDefaultConfiguration++-- * Program Configurations with Validation of Configuration Values+, ConfigValidation+, programInfoValidate++-- ** Low-level Config Validation+, ProgramInfoValidate+, piValidateConfiguration+, ConfigValidationFunction , piOptionParserAndDefaultConfiguration  -- * Running an Configured Application@@ -106,18 +119,21 @@ import Configuration.Utils.Internal  import Control.Error (fmapL)+import Control.Monad.Except hiding (mapM_)+import Control.Monad.Writer hiding (mapM_)  import Data.Aeson import Data.Aeson.Types (Parser) import qualified Data.ByteString.Char8 as B8 import Data.Char import qualified Data.CaseInsensitive as CI+import Data.Foldable import qualified Data.HashMap.Strict as H import Data.Maybe-import Data.Monoid import Data.Monoid.Unicode import Data.String import qualified Data.Text as T+import qualified Data.Text.IO as T import qualified Data.Yaml as Yaml  #if MIN_VERSION_optparse_applicative(0,10,0)@@ -128,8 +144,10 @@  import qualified Options.Applicative as O +import Prelude hiding (concatMap, mapM_, any) import Prelude.Unicode +import System.IO import System.IO.Unsafe (unsafePerformIO)  import qualified Text.ParserCombinators.ReadP as P@@ -453,7 +471,22 @@ -- -------------------------------------------------------------------------- -- -- Main Configuration -data ProgramInfo α = ProgramInfo+-- | A validation function. The type in the 'MonadWriter' is excpected to+-- be a 'Foldable' structure for collecting warnings.+--+type ConfigValidation α λ = (MonadIO μ, Functor μ, Applicative μ, MonadError T.Text μ, MonadWriter (λ T.Text) μ) ⇒ α → μ ()++-- | A newtype wrapper around a validation function. The only purpose of+-- this type is to avoid ImpredicativeTypes when storing the function+-- in the 'ProgramInfoValidate' record.+--+newtype ConfigValidationFunction α λ = ConfigValidationFunction+    { runConfigValidation ∷ ConfigValidation α λ+    }++type ProgramInfo α = ProgramInfoValidate α []++data ProgramInfoValidate α λ = ProgramInfo     { _piDescription ∷ !String       -- ^ Program Description     , _piHelpHeader ∷ !(Maybe String)@@ -464,65 +497,101 @@       -- ^ options parser for configuration (TODO consider using a typeclass for this)     , _piDefaultConfiguration ∷ !α       -- ^ default configuration+    , _piValidateConfiguration ∷ !(ConfigValidationFunction α λ)+      -- ^ a validation function. The 'Right' result is interpreted as a 'Foldable'+      -- structure of warnings.     }  -- | Program Description ---piDescription ∷ Lens' (ProgramInfo α) String+piDescription ∷ Lens' (ProgramInfoValidate α λ) String piDescription = lens _piDescription $ \s a → s { _piDescription = a } {-# INLINE piDescription #-}  -- | Help header ---piHelpHeader ∷ Lens' (ProgramInfo α) (Maybe String)+piHelpHeader ∷ Lens' (ProgramInfoValidate α λ) (Maybe String) piHelpHeader = lens _piHelpHeader $ \s a → s { _piHelpHeader = a } {-# INLINE piHelpHeader #-}  -- | Help footer ---piHelpFooter ∷ Lens' (ProgramInfo α) (Maybe String)+piHelpFooter ∷ Lens' (ProgramInfoValidate α λ) (Maybe String) piHelpFooter = lens _piHelpFooter $ \s a → s { _piHelpFooter = a } {-# INLINE piHelpFooter #-}  -- | options parser for configuration (TODO consider using a typeclass for this) ---piOptionParser ∷ Lens' (ProgramInfo α) (MParser α)+piOptionParser ∷ Lens' (ProgramInfoValidate α λ) (MParser α) piOptionParser = lens _piOptionParser $ \s a → s { _piOptionParser = a } {-# INLINE piOptionParser #-}  -- | default configuration ---piDefaultConfiguration ∷ Lens' (ProgramInfo α) α+piDefaultConfiguration ∷ Lens' (ProgramInfoValidate α λ) α piDefaultConfiguration = lens _piDefaultConfiguration $ \s a → s { _piDefaultConfiguration = a } {-# INLINE piDefaultConfiguration #-} +-- | Validation Function+--+-- The 'Right' result is interpreted as a 'Foldable' structure of warnings.+--+piValidateConfiguration ∷ Lens' (ProgramInfoValidate α λ) (ConfigValidationFunction α λ)+piValidateConfiguration = lens _piValidateConfiguration $ \s a → s { _piValidateConfiguration = a }+{-# INLINE piValidateConfiguration #-}+ -- | 'Lens' for simultaneous query and update of 'piOptionParser' and -- 'piDefaultConfiguration'. This supports to change the type of 'ProgramInfo' -- with 'over' and 'set'. ---piOptionParserAndDefaultConfiguration ∷ Lens (ProgramInfo α) (ProgramInfo β) (MParser α, α) (MParser β, β)-piOptionParserAndDefaultConfiguration = lens g $ \s (a,b) → ProgramInfo+piOptionParserAndDefaultConfiguration+    ∷ Lens+        (ProgramInfoValidate α λ)+        (ProgramInfoValidate β γ)+        (MParser α, α, ConfigValidationFunction α λ)+        (MParser β, β, ConfigValidationFunction β γ)+piOptionParserAndDefaultConfiguration = lens g $ \s (a,b,c) → ProgramInfo     { _piDescription = _piDescription s     , _piHelpHeader = _piHelpHeader s     , _piHelpFooter = _piHelpFooter s     , _piOptionParser = a     , _piDefaultConfiguration = b+    , _piValidateConfiguration = c     }   where-    g s = (_piOptionParser s, _piDefaultConfiguration s)+    g s = (_piOptionParser s, _piDefaultConfiguration s, _piValidateConfiguration s) {-# INLINE piOptionParserAndDefaultConfiguration #-}  -- | Smart constructor for 'ProgramInfo'. -- -- 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'.+-- The function 'piValidateConfiguration' is set to @const (return [])@ ---programInfo ∷ String → MParser α → α → ProgramInfo α-programInfo desc parser defaultConfig = ProgramInfo+programInfo+    ∷ String+    → MParser α+    → α+    → ProgramInfo α+programInfo desc parser defaultConfig =+    programInfoValidate desc parser defaultConfig $ const (return ())++-- | Smart constructor for 'ProgramInfo'.+--+-- 'piHelpHeader' and 'piHelpFooter' are set to 'Nothing'.+--+programInfoValidate+    ∷ String+    → MParser α+    → α+    → ConfigValidation α λ+    → ProgramInfoValidate α λ+programInfoValidate desc parser defaultConfig valFunc = ProgramInfo     { _piDescription = desc     , _piHelpHeader = Nothing     , _piHelpFooter = Nothing     , _piOptionParser = parser     , _piDefaultConfiguration = defaultConfig+    , _piValidateConfiguration = ConfigValidationFunction valFunc     }  data AppConfiguration α = AppConfiguration@@ -570,8 +639,8 @@         $ unsafePerformIO (Yaml.decodeFileEither file)  mainOptions-    ∷ ∀ α . FromJSON (α → α)-    ⇒ ProgramInfo α+    ∷ ∀ α λ . FromJSON (α → α)+    ⇒ ProgramInfoValidate α λ     → (∀ β . Maybe (MParser β))     → O.ParserInfo (AppConfiguration α) mainOptions ProgramInfo{..} pkgInfoParser = O.info optionParser@@ -610,12 +679,13 @@ --     Print a help message and exit. -- runWithConfiguration-    ∷ (FromJSON (α → α), ToJSON α)-    ⇒ ProgramInfo α+    ∷ (FromJSON (α → α), ToJSON α, Foldable λ, Monoid (λ T.Text))+    ⇒ ProgramInfoValidate α λ     → (α → IO ())     → IO () runWithConfiguration appInfo mainFunction = do     conf ← O.customExecParser parserPrefs mainOpts+    validateConfig appInfo $ _mainConfig conf     if _printConfig conf         then B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ conf         else mainFunction ∘ _mainConfig $ conf@@ -623,6 +693,30 @@     mainOpts = mainOptions appInfo Nothing     parserPrefs = O.prefs O.disambiguate +-- | Validates a configuration value. Throws an user error+-- if there is an error. If there are warnings they are+-- printed to 'stderr'.+--+validateConfig+    ∷ (Foldable λ, Monoid (λ T.Text))+    ⇒ ProgramInfoValidate α λ+    → α+    → IO ()+validateConfig appInfo conf = do+    warnings ← execWriterT . exceptT (error . T.unpack) return $ do+        runConfigValidation (view piValidateConfiguration appInfo) conf+    when (any (const True) warnings) $ do+        T.hPutStrLn stderr "WARNINGS:"+        mapM_ (\w → T.hPutStrLn stderr $ "warning: " ⊕ w) warnings++exceptT+    ∷ Monad μ+    ⇒ (ε → μ β)+    → (α → μ β)+    → ExceptT ε μ α+    → μ β+exceptT a b = runExceptT >=> either a b+ -- -------------------------------------------------------------------------- -- -- Main Configuration with Package Info @@ -690,20 +784,21 @@ -- [@--info, -i@] --     Print a short info message for the application and exit. ----- [@--long-inf@]+-- [@--long-info@] --     Print a detailed info message for the application and exit. -- -- [@--license@] --     Print the text of the lincense of the application and exit. -- runWithPkgInfoConfiguration-    ∷ (FromJSON (α → α), ToJSON α)-    ⇒ ProgramInfo α+    ∷ (FromJSON (α → α), ToJSON α, Foldable λ, Monoid (λ T.Text))+    ⇒ ProgramInfoValidate α λ     → PkgInfo     → (α → IO ())     → IO () runWithPkgInfoConfiguration appInfo pkgInfo mainFunction = do     conf ← O.customExecParser parserPrefs mainOpts+    validateConfig appInfo $ _mainConfig conf     if _printConfig conf         then B8.putStrLn ∘ Yaml.encode ∘ _mainConfig $ conf         else mainFunction ∘ _mainConfig $ conf@@ -832,14 +927,14 @@ -- == Example: -- -- > data Setting = Setting--- >     { _setA :: !Int--- >     , _setB :: !String+-- >     { _setA ∷ !Int+-- >     , _setB ∷ !String -- >     } -- >     deriving (Show, Read, Eq, Ord, Typeable) -- > -- > $(makeLenses ''Setting) -- >--- > defaultSetting :: Setting+-- > defaultSetting ∷ Setting -- > defaultSetting = Setting -- >     { _setA = 0 -- >     , _setB = 1@@ -851,15 +946,15 @@ -- >        , "b" .= _setB setting -- >        ] -- >--- > instance FromJSON (Setting -> Setting) where--- >     parseJSON = withObject "Setting" $ \o -> id+-- > instance FromJSON (Setting → Setting) where+-- >     parseJSON = withObject "Setting" $ \o → id -- >         <$< setA ..: "a" % o -- >         <*< setB ..: "b" % o -- > -- > instance FromJSON Setting where -- >    parseJSON v = parseJSON v <*> pure defaultSetting -- >--- > pSetting :: MParser Setting+-- > pSetting ∷ MParser Setting -- > pSetting = id -- >     <$< setA .:: option auto -- >         % short 'a'@@ -873,13 +968,13 @@ -- > -- | Use 'Setting' as 'Maybe' in a configuration: -- > -- -- > data Config = Config--- >     { _maybeSetting :: !(Maybe Setting)+-- >     { _maybeSetting ∷ !(Maybe Setting) -- >     } -- >     deriving (Show, Read, Eq, Ord, Typeable) -- > -- > $(makeLenses ''Config) -- >--- > defaultConfig :: Config+-- > defaultConfig ∷ Config -- > defaultConfig = Config -- >     { _maybeSetting = defaultSetting -- >     }@@ -889,11 +984,11 @@ -- >         [ "setting" .= maybeSetting -- >         ] -- >--- > instance FromJSON (Config -> Config) where--- >     parseJSON = withObject "Config" $ \o -> id+-- > instance FromJSON (Config → Config) where+-- >     parseJSON = withObject "Config" $ \o → id -- >         <$< maybeSetting %.: "setting" % o -- >--- > pConfig :: MParser Config+-- > pConfig ∷ MParser Config -- > pConfig = id -- >     <$< maybeSetting %:: (maybeOption defaultSetting -- >         <$> pEnableSetting@@ -905,15 +1000,15 @@ -- >         <> help "Enable configuration flags for setting" -- maybeOption-    :: a+    ∷ a         -- ^ default value that is used if base configuration is 'Nothing'-    -> Bool+    → Bool         -- ^ whether to enable this parser or not (usually is a boolean option parser)-    -> (a -> a)+    → (a → a)         -- ^ update function (usually given as applicative 'MParser a')-    -> Maybe a+    → Maybe a         -- ^ the base value that is updated (usually the result of parsing the configuraton file)-    -> Maybe a+    → Maybe a maybeOption _ False _ Nothing = Nothing -- not enabled maybeOption defA True update Nothing = Just $ update defA -- disabled in config file but enabled by command line maybeOption _ _ update (Just val) = Just $ update val -- enabled by config file and possibly by command line

@@ -2,12 +2,16 @@ -- Copyright © 2014 AlephCloud Systems, Inc. -- ------------------------------------------------------ -- -{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+#if __GLASGOW_HASKELL__>=708+{-# LANGUAGE OverloadedLists #-}+#endif {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}  {-# OPTIONS_HADDOCK show-extensions #-} @@ -17,6 +21,9 @@   HttpServiceTLSConfiguration , hstcCertFile , hstcKeyFile+, defaultHttpServiceTLSConfiguration+, pHttpServiceTLSConfiguration+, validateHttpServiceTLSConfiguration  -- * HTTP Service Configuration , HttpServiceConfiguration@@ -25,6 +32,7 @@ , hscUseTLS , defaultHttpServiceConfiguration , pHttpServiceConfiguration+, validateHttpServiceConfiguration  -- * Http Client Configuration , HttpClientConfiguration@@ -33,13 +41,21 @@ , hccUseTLS , defaultHttpClientConfiguration , pHttpClientConfiguration+, validateHttpClientConfiguration , httpService2clientConfiguration ) where  import Configuration.Utils import Configuration.Utils.Internal+import Configuration.Utils.Validation +import Control.Monad (when)+#if __GLASGOW_HASKELL__>=708+import Control.Monad.Writer.Class (tell)+#endif+ import qualified Data.ByteString.Char8 as B8+import qualified Data.DList as DL import Data.Maybe (isJust) import Data.Monoid.Unicode @@ -69,6 +85,12 @@     , _hstcKeyFile = "key.pem"     } +validateHttpServiceTLSConfiguration+    ∷ ConfigValidation HttpServiceTLSConfiguration λ+validateHttpServiceTLSConfiguration conf = do+    validateFileReadable "cert-file" $ _hstcCertFile conf+    validateFileReadable "key-file" $ _hstcKeyFile conf+ instance FromJSON (HttpServiceTLSConfiguration → HttpServiceTLSConfiguration) where     parseJSON = withObject "HttpServiceTLSConfiguration" $ \o → id         <$< hstcCertFile ..: "cert-file" × o@@ -136,7 +158,6 @@ hscUseTLS ∷ Lens' HttpServiceConfiguration (Maybe HttpServiceTLSConfiguration) hscUseTLS = lens _hscUseTLS $ \s a → s { _hscUseTLS = a} - defaultHttpServiceConfiguration ∷ HttpServiceConfiguration defaultHttpServiceConfiguration = HttpServiceConfiguration     { _hscHost = "localhost"@@ -145,6 +166,17 @@     , _hscUseTLS = Nothing     } +validateHttpServiceConfiguration ∷ ConfigValidation HttpServiceConfiguration DL.DList+validateHttpServiceConfiguration conf = do+    maybe (return ()) validateHttpServiceTLSConfiguration $ _hscUseTLS conf+    validatePort "port" $ _hscPort conf+#if __GLASGOW_HASKELL__>=708+    when (_hscPort conf < 1024) $+        tell ["listening on a priviledged port requires super user rights"]+#endif+    validateNonEmpty "host" $ _hscHost conf+    validateIPv4 "interface" . B8.unpack $ _hscInterface conf+ instance FromJSON (HttpServiceConfiguration → HttpServiceConfiguration) where     parseJSON = withObject "HttpServiceConfiguration" $ \o → id         <$< hscHost ∘ bs ..: "host" × o@@ -212,6 +244,11 @@     , _hccPort = 80     , _hccUseTLS = False     }++validateHttpClientConfiguration ∷ ConfigValidation HttpClientConfiguration λ+validateHttpClientConfiguration conf = do+    validatePort "port" $ _hccPort conf+    validateNonEmpty "host" $ _hccHost conf  instance FromJSON (HttpClientConfiguration → HttpClientConfiguration) where     parseJSON = withObject "HttpClientConfiguration" $ \o → id

@@ -10,14 +10,19 @@ ( lens , over , set+, view , Lens' , Lens , Iso' , iso ) where +import Control.Applicative (Const(..))+import Control.Monad.Reader.Class+ import Data.Functor.Identity import Data.Profunctor+import Data.Profunctor.Unsafe  -- -------------------------------------------------------------------------- -- -- Lenses@@ -51,6 +56,9 @@ set ∷ ((α → Identity α) → β → Identity β) → α → β → β set s a = runIdentity . s (const $ Identity a) {-# INLINE set #-}++view ∷ MonadReader σ μ ⇒ ((α → Const α α) → σ → Const α σ) → μ α+view l = asks (getConst #. l Const)  -- | This is the same type as the type from the lens library with the same name. --

@@ -0,0 +1,302 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Configuration.Utils.Validation+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Utilities for validating configuration values+--+module Configuration.Utils.Validation+(+-- * Networking+  validateHttpOrHttpsUrl+, validateHttpUrl+, validateHttpsUrl+, validateUri+, validateAbsoluteUri+, validateAbsoluteUriFragment+, validateIPv4+, validateIPv6+, validatePort++-- * Monoids, Foldables and Co+, validateNonEmpty+, validateLength+, validateMinLength+, validateMaxLength+, validateMinMaxLength++-- * Files+, validateFilePath+, validateFile+, validateFileReadable+, validateFileWritable+, validateExecutable+, validateDirectory+) where++import Configuration.Utils++import Control.Monad.Error.Class+import Control.Monad+import Control.Monad.IO.Class++import qualified Data.Foldable as F+import Data.Monoid+import Data.Monoid.Unicode+import Data.String+import qualified Data.Text as T++import Network.URI++import Prelude.Unicode++import System.Directory++-- -------------------------------------------------------------------------- --+-- Utils++sshow+    ∷ (Show α, IsString τ)+    ⇒ α+    → τ+sshow = fromString ∘ show++-- -------------------------------------------------------------------------- --+-- Networking++-- | Validates that a value is an HTTP or HTTPS URL+--+validateHttpOrHttpsUrl+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation String λ+validateHttpOrHttpsUrl configName uri =+    case parseURI uri of+        Nothing → throwError $+            "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI"+        Just u → unless (uriScheme u ≡ "http:" || uriScheme u ≡ "https:") ∘ throwError $+            "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not an HTTP or HTTPS URL"++-- | Validates that a value is an HTTP URL+--+validateHttpUrl+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation String λ+validateHttpUrl configName uri =+    case parseURI uri of+        Nothing → throwError $+            "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI"+        Just u → unless (uriScheme u ≡ "http:") ∘ throwError $+            "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not an HTTP URL"++-- | Validates that a value is an HTTPS URL+--+validateHttpsUrl+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation String λ+validateHttpsUrl configName uri =+    case parseURI uri of+        Nothing → throwError $+            "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI"+        Just u → unless (uriScheme u ≡ "https:") ∘ throwError $+            "the value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not an HTTPS URL"++-- | Validates that a value is an URI without a fragment identifier+--+validateUri+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation String λ+validateUri configName uri =+    unless (isURIReference uri) ∘ throwError $+        "The value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI"++-- | Validates that a value is an absolute URI without a fragment identifier+--+validateAbsoluteUri+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation String λ+validateAbsoluteUri configName uri =+    unless (isAbsoluteURI uri) ∘ throwError $+        "The value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI"++-- | Validates that a value is an absolute URI with an optional fragment+-- identifier+--+validateAbsoluteUriFragment+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation String λ+validateAbsoluteUriFragment configName uri =+    unless (isURI uri) ∘ throwError $+        "The value " ⊕ T.pack uri ⊕ " for " ⊕ configName ⊕ " is not a valid URI"++validateIPv4+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation String λ+validateIPv4 configName ipv4 =+    unless (isIPv4address ipv4) ∘ throwError $+        "The value " ⊕ T.pack ipv4 ⊕ " for " ⊕ configName ⊕ " is not a valid IPv4 address"++validateIPv6+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation String λ+validateIPv6 configName ipv6 =+    unless (isIPv6address ipv6) ∘ throwError $+        "The value " ⊕ T.pack ipv6 ⊕ " for " ⊕ configName ⊕ " is not a valid IPv6 address"++validatePort+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation Int λ+validatePort configName p =+    unless (p > 1 && p < 65535) ∘ throwError $+        "port value " ⊕ T.pack (show p) ⊕ " for " ⊕ configName ⊕ " is not valid port number"++-- -------------------------------------------------------------------------- --+-- Monoids, Foldables, and Co++validateNonEmpty+    ∷ (Eq α, Monoid α)+    ⇒ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation α λ+validateNonEmpty configName x =+    when (x ≡ mempty) ∘ throwError $+        "value for " ⊕ configName ⊕ " must not be empty"++validateLength+    ∷ (F.Foldable φ)+    ⇒ T.Text+        -- ^ configuration property name that is used in the error message+    → Int+        -- ^ exact length of the validated value+    → ConfigValidation (φ α) λ+validateLength configName len x =+    unless (length (F.toList x) ≡ len) ∘ throwError $+        "value for " ⊕ configName ⊕ " must be of length exactly " ⊕ sshow len++validateMaxLength+    ∷ (F.Foldable φ)+    ⇒ T.Text+        -- ^ configuration property name that is used in the error message+    → Int+        -- ^ maximum length of the validated value+    → ConfigValidation (φ α) λ+validateMaxLength configName u x =+    unless (length (F.toList x) ≤ u) ∘ throwError $+        "value for " ⊕ configName ⊕ " must be of length at most " ⊕ sshow u++validateMinLength+    ∷ (F.Foldable φ)+    ⇒ T.Text+        -- ^ configuration property name that is used in the error message+    → Int+        -- ^ minimum length of the validated value+    → ConfigValidation (φ α) λ+validateMinLength configName l x =+    unless (length (F.toList x) ≥ l) ∘ throwError $+        "value for " ⊕ configName ⊕ " must be of length at least " ⊕ sshow l++validateMinMaxLength+    ∷ (F.Foldable φ)+    ⇒ T.Text+        -- ^ configuration property name that is used in the error message+    → Int+        -- ^ minimum length of the validated value+    → Int+        -- ^ maximum length of the validated value+    → ConfigValidation (φ α) λ+validateMinMaxLength configName l u x =+    unless (len ≥ l && len ≤ u) ∘ throwError $+        "the length of the value for " ⊕ configName ⊕+        " must be at least " ⊕ sshow l ⊕ " and at most " ⊕ sshow u+  where+    len = length $ F.toList x++-- -------------------------------------------------------------------------- --+-- Files++validateFilePath+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation FilePath λ+validateFilePath configName file =+    when (null file) ∘ throwError $+        "file path for " ⊕ configName ⊕ " must not be empty"++validateFile+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation FilePath λ+validateFile configName file = do+    exists ← liftIO $ doesFileExist file+    unless exists ∘ throwError $+        "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " does not exist"++validateFileReadable+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation FilePath λ+validateFileReadable configName file = do+    validateFile configName file+    liftIO (getPermissions file) >>= \x → unless (readable x) ∘ throwError $+        "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " is not readable"++validateFileWritable+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation FilePath λ+validateFileWritable configName file = do+    validateFile configName file+    liftIO (getPermissions file) >>= \x → unless (writable x) ∘ throwError $+        "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " is not writable"++validateFileExecutable+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation FilePath λ+validateFileExecutable configName file = do+    validateFile configName file+    liftIO (getPermissions file) >>= \x → unless (executable x) ∘ throwError $+        "the file " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " is not excutable"++validateDirectory+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation FilePath λ+validateDirectory configName dir = do+    exists ← liftIO $ doesDirectoryExist dir+    unless exists ∘ throwError $+        "the directory " ⊕ T.pack dir ⊕ " for " ⊕ configName ⊕ " does not exist"++-- | Validates if the given executable name can be found in the system+-- and can be executed.+--+validateExecutable+    ∷ T.Text+        -- ^ configuration property name that is used in the error message+    → ConfigValidation FilePath λ+validateExecutable configName file = do+    execFile ← (file <$ validateFile configName file) `catchError` \_ ->+        liftIO (findExecutable file) >>= \case+            Nothing → throwError $+                "the executable " ⊕ T.pack file ⊕ " for " ⊕ configName ⊕ " could not be found in the system;"+                ⊕ " you may check your SearchPath and PATH variable settings"+            Just f → return f+    validateFileExecutable configName execFile+

@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Tests for Example+--+module Main+( main+) where++import Control.Exception++import qualified Example++import System.Environment++main ∷ IO ()+main = do+    withArgs ["--domain=localhost"] Example.main+    withArgs ["--path=abc"] Example.main+    withArgs ["--path=abc", "--user=u"] Example.main+    handle (\(_ ∷ SomeException) → return ()) $ do+        withArgs [] Example.main+        error "expected failure but got success"+    return ()+