packages feed

yaml-config 0.0.1 → 0.1.0

raw patch · 4 files changed

+124/−65 lines, 4 filesdep +failuredep +tastydep +tasty-quickcheckdep −test-frameworkdep −test-framework-quickcheck2dep ~QuickChecknew-uploader

Dependencies added: failure, tasty, tasty-quickcheck

Dependencies removed: test-framework, test-framework-quickcheck2

Dependency ranges changed: QuickCheck

Files

src/Data/Yaml/Config.hs view
@@ -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
src/Data/Yaml/Config/Internal.hs view
@@ -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."
tests/Tests.hs view
@@ -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     ]
yaml-config.cabal view
@@ -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 <knsd@knsd.net>                     Mitroshin Maxim <mitroshin@selectel.org>+                    Simon Hengel <sol@typeful.net> 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