diff --git a/src/Data/Yaml/Config.hs b/src/Data/Yaml/Config.hs --- a/src/Data/Yaml/Config.hs +++ b/src/Data/Yaml/Config.hs @@ -1,15 +1,48 @@ {-# LANGUAGE NoImplicitPrelude #-} +-- | Library for read config files in YAML format. +-- +-- example.yaml: +-- +-- @ +-- server: +-- port: 8080 +-- logs: +-- access: \/var\/log\/server\/access.log +-- error: \/var\/log\/server\/error.log +-- @ +-- +-- Usage example: +-- +-- @ +--module Main where +--import Prelude hiding (lookup) +--import Data.Word (Word16) +--import Data.Yaml.Config (load, subconfig, lookupDefault, lookup) +-- +--main :: IO () +--main = do +-- config <- load "./example.yaml" +-- +-- serverConfig <- subconfig config "server" +-- let interface = lookupDefault serverConfig "interface" "127.0.0.1" +-- port :: Word16 = lookupDefault serverConfig "port" 80 +-- +-- logConfig <- subconfig serverConfig "logs" +-- accessLog <- lookup logConfig "access" +-- errorLog <- lookup logConfig "error" +-- +-- mapM_ putStrLn [interface, (show port), errorLog, accessLog] +-- @ +-- module Data.Yaml.Config ( Config , Key , load , keys - , lookupSubconfig , subconfig , lookup , lookupDefault - , require ) where import Data.Yaml.Config.Internal diff --git a/src/Data/Yaml/Config/Internal.hs b/src/Data/Yaml/Config/Internal.hs --- a/src/Data/Yaml/Config/Internal.hs +++ b/src/Data/Yaml/Config/Internal.hs @@ -1,23 +1,29 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Data.Yaml.Config.Internal ( Config(..) , Key + + -- * public API + -- ** work with files , load + + -- **explore config , keys - , lookupSubconfig , subconfig , lookup , lookupDefault - , require + + -- * export for tests , fullpath ) where import Prelude hiding (lookup) import Control.DeepSeq (NFData(rnf)) -import Control.Exception (Exception, throwIO) +import Control.Exception (Exception) import Control.Monad (foldM) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) @@ -27,81 +33,101 @@ import Data.Yaml (Object, FromJSON(parseJSON), parseMaybe) import qualified Data.HashMap.Strict as HashMap import qualified Data.Yaml as Yaml +import Control.Failure --- | Subconfig or field name +-- | Config or field name type Key = ST.Text --- | Throwable exception +-- | This error can be raised if config has not target path. newtype KeyError = KeyError Key deriving (Show, Typeable) instance Exception KeyError --- | (Sub)Config type +-- | Type contains config section and path from root. data Config = Config [Key] Object deriving (Eq, Show) instance NFData Config where rnf (Config p o) = rnf p `seq` rnf o `seq` () -ke :: Key -> IO a -ke = throwIO . KeyError +ke :: Failure KeyError m => Key -> m a +ke = failure . KeyError --- | Show full path from the root to target key +-- | Show full path from the root to target key. Levels are separated by dots. +-- +-- >>> fullpath sub "field1" +-- "section1.field1" +-- fullpath :: Config -> Key -> Key fullpath (Config parents _) path = ST.intercalate "." $ reverse $ path : parents --- | Find file in filesystem and try to load it as YAML config --- May fail with @KeyError@ +-- | Find file in filesystem and try to load it as YAML config. +-- May fail with @InvalidYaml@ if file not found. +-- +-- >>> config <- load "example.yaml" +-- load :: FilePath -> IO Config load f = maybe err (return . Config []) =<< Yaml.decodeFile f where err = error $ "Invalid config file " <> f <> "." --- | Show all (sub)config first level filed's name +-- | Show all first level config field's. +-- +-- >>> keys config +-- ["section1","section2"] +-- keys :: Config -> [Key] keys (Config _ o) = HashMap.keys o --- | Field value wrapped into @Maybe@ (sub)config -lookup :: FromJSON a - => Config -- ^ (Sub)Config for find - -> Key -- ^ Field name - -> Maybe a -- ^ Field value -lookup conf path = foldM lookupSubconfig conf (init pathes) >>= +-- | Get value for given key. +-- May fail with @KeyError@ if key doesn't exist. +-- +-- >>> keys sub +-- ["field1","field2"] +-- >>> putStrLn =<< lookup "field1" sub +-- value1 +-- +lookup :: (Failure KeyError m, FromJSON a) + => Key -- ^ Field name + -> Config -- ^ Config for find + -> m a -- ^ Field value +lookup path c = maybe err return $ lookupMaybe path c + where + err = ke $ "Field " <> fullpath c path <> " not found or has wrong type." + +lookupMaybe :: FromJSON a => Key -> Config -> Maybe a +lookupMaybe path conf = foldM (flip subconfig) conf (init pathes) >>= look (last pathes) where look k (Config _ o) = HashMap.lookup k o >>= parseMaybe parseJSON pathes = ST.splitOn "." path --- | Subconfig wrapped into @Maybe@ -lookupSubconfig :: Config -- ^ (Sub)Config for find - -> Key -- ^ Field name - -> Maybe Config -- ^ Maybe Subconfig -lookupSubconfig (Config parents o) k = HashMap.lookup k o >>= \s -> case s of - (Yaml.Object so) -> Just $ Config (k : parents) so - _ -> Nothing - --- | Find value in (sub)config and return it or default value +-- | Find value in config and return it or return default value. +-- +-- >>> lookupDefault "field3" "def" sub +-- "def" +-- lookupDefault :: FromJSON a - => Config -- ^ (Sub)Config for find - -> Key -- ^ Field name - -> a -- ^ Default value - -> a -- ^ Return value -lookupDefault c p d = fromMaybe d $ lookup c p + => Key -- ^ Field name + -> a -- ^ Default value + -> Config -- ^ Config for find + -> a -- ^ Founded or default value +lookupDefault p d = fromMaybe d . lookup p --- | Find subconfig --- May fail with @KeyError@ -subconfig :: Config -- ^ (Sub)Config for find - -> Key -- ^ Subconfig name - -> IO Config -- ^ Subconfig -subconfig c path = maybe err return $ lookupSubconfig c path +-- | Get subconfig by name. +-- May fail with @KeyError@ if target key doesn't exist at current level. +-- +-- >>> :set -XOverloadedStrings +-- >>> sub <- subconfig "section1" config +-- +subconfig :: Failure KeyError m + => Key -- ^ Subconfig name + -> Config -- ^ (Sub)Config for find + -> m Config -- ^ Founded Subconfig +subconfig path c@(Config parents o) = case HashMap.lookup path o of + Just (Yaml.Object so) -> return $ Config (path : parents) so + _ -> err where err = ke $ "Subconfig " <> fullpath c path <> " not found." - --- | Same as @lookup@ buf fail with @KeyError@ --- if there is no field with target name -require :: FromJSON a => Config -> Key -> IO a -require c path = maybe err return $ lookup c path - where - err = ke $ "Field " <> fullpath c path <> " not found or has wrong type." diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -10,15 +10,15 @@ import Data.Text as Text import qualified Data.Text as ST -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck (Gen, Property, Arbitrary(..), elements, sized, oneof, listOf) import Test.QuickCheck.Monadic (assert) import Data.Yaml(Object, Value(Object, Null)) import qualified Data.HashMap.Strict as HashMap -import Data.Yaml.Config.Internal (Config(Config), Key, lookupSubconfig, keys, +import Data.Yaml.Config.Internal (Config(Config), Key, subconfig, keys, fullpath) type CorrectPath = [Key] @@ -48,24 +48,24 @@ testCorrectSubconfigPath :: DeepObject -> Bool testCorrectSubconfigPath (DeepObject _ []) = True testCorrectSubconfigPath (DeepObject config (key : others)) = - maybe False (`subcheck` others) $ lookupSubconfig config key + maybe False (`subcheck` others) $ subconfig key config where subcheck sc keys = testCorrectSubconfigPath $ DeepObject sc keys testWrongSubconfigPath :: DeepObject -> Bool testWrongSubconfigPath (DeepObject config []) = List.null $ keys config testWrongSubconfigPath (DeepObject config (nextKey : others)) = - maybe nextCheck (const False) $ lookupSubconfig config wrongKey + maybe nextCheck (const False) $ subconfig wrongKey config where nextCheck = maybe False (testWrongSubconfigPath . nextDeep) $ - lookupSubconfig config nextKey + subconfig nextKey config nextDeep = flip DeepObject others wrongKey = nextKey <> "_" testCorrectPath :: DeepObject -> Bool testCorrectPath = testCorrectPath' [] testCorrectPath' path (DeepObject config (nextKey : others)) = checkPath config - && (maybe False (`subcheck` others) $ lookupSubconfig config nextKey) + && (maybe False (`subcheck` others) $ subconfig nextKey config) where subcheck sc keys = testCorrectPath' (nextKey : path) $ DeepObject sc keys checkPath c = fullpath c nextKey == @@ -73,11 +73,8 @@ testCorrectPath' _ (DeepObject config []) = List.null $ keys config main :: IO () -main = defaultMain - [ - testGroup "lookup" - [ testProperty "wrongSubconfigPath" testWrongSubconfigPath - , testProperty "correctSubconfigPath" testCorrectSubconfigPath - , testProperty "correctPath" testCorrectPath - ] +main = defaultMain $ testGroup "Tests" + [ testProperty "wrongSubconfigPath" testWrongSubconfigPath + , testProperty "correctSubconfigPath" testCorrectSubconfigPath + , testProperty "correctPath" testCorrectPath ] diff --git a/yaml-config.cabal b/yaml-config.cabal --- a/yaml-config.cabal +++ b/yaml-config.cabal @@ -1,5 +1,5 @@ Name: yaml-config -Version: 0.0.1 +Version: 0.1.0 Synopsis: Configuration management Description: Configuration management License: MIT @@ -7,6 +7,7 @@ Copyright: Selectel Author: Fedor Gogolev Mitroshin Maxim + Simon Hengel Maintainer: mitroshin@selectel.org Category: Configuration Build-type: Simple @@ -22,6 +23,7 @@ , unordered-containers == 0.2.* , text == 0.11.* , yaml == 0.8.* + , failure == 0.2.* Exposed-modules: Data.Yaml.Config Other-modules: Data.Yaml.Config.Internal @@ -37,11 +39,12 @@ , unordered-containers == 0.2.* , text == 0.11.* , yaml == 0.8.* + , failure == 0.2.* , hashable == 1.2.* - , test-framework == 0.8.* - , test-framework-quickcheck2 == 0.3.* - , QuickCheck == 2.5.* + , tasty == 0.3.* + , tasty-quickcheck == 0.3.* + , QuickCheck == 2.6.* Source-repository head Type: git