diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ===== 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.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 diff --git a/constraints b/constraints --- a/constraints +++ b/constraints @@ -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, diff --git a/examples/Example.hs b/examples/Example.hs --- a/examples/Example.hs +++ b/examples/Example.hs @@ -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 diff --git a/src/Configuration/Utils.hs b/src/Configuration/Utils.hs --- a/src/Configuration/Utils.hs +++ b/src/Configuration/Utils.hs @@ -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 diff --git a/src/Configuration/Utils/Http.hs b/src/Configuration/Utils/Http.hs --- a/src/Configuration/Utils/Http.hs +++ b/src/Configuration/Utils/Http.hs @@ -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 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 @@ -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. -- diff --git a/src/Configuration/Utils/Validation.hs b/src/Configuration/Utils/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Utils/Validation.hs @@ -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 +-- 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 + diff --git a/test/TestExample.hs b/test/TestExample.hs new file mode 100644 --- /dev/null +++ b/test/TestExample.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnicodeSyntax #-} + +-- | +-- Module: Main +-- Copyright: Copyright © 2014 AlephCloud Systems, Inc. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 () +