packages feed

yaml-config (empty) → 0.0.1

raw patch · 6 files changed

+275/−0 lines, 6 filesdep +QuickCheckdep +basedep +deepseqsetup-changed

Dependencies added: QuickCheck, base, deepseq, hashable, test-framework, test-framework-quickcheck2, text, unordered-containers, yaml

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2013 Selectel++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Yaml/Config.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE NoImplicitPrelude #-}++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
@@ -0,0 +1,107 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Yaml.Config.Internal+    ( Config(..)+    , Key+    , load+    , keys+    , lookupSubconfig+    , subconfig+    , lookup+    , lookupDefault+    , require+    , fullpath+    ) where++import Prelude hiding (lookup)+import Control.DeepSeq (NFData(rnf))+import Control.Exception (Exception, throwIO)+import Control.Monad (foldM)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Typeable (Typeable)+import qualified Data.Text as ST++import Data.Yaml (Object, FromJSON(parseJSON), parseMaybe)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Yaml as Yaml++-- | Subconfig or field name+type Key = ST.Text++-- | Throwable exception+newtype KeyError = KeyError Key+    deriving (Show, Typeable)++instance Exception KeyError++-- | (Sub)Config type+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++-- | Show full path from the root to target key+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@+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+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) >>=+    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+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++-- | 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+  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
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad (liftM)+import Data.Monoid ((<>))+import Data.Hashable (Hashable)+import Data.Text (Text)+import Data.List as List+import Data.Text as Text+import qualified Data.Text as ST++import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (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,+                                  fullpath)++type CorrectPath = [Key]++data DeepObject = DeepObject Config CorrectPath deriving (Eq, Show)++instance Arbitrary Text where+    arbitrary = liftM Text.pack arbitrary++instance Arbitrary DeepObject where+    arbitrary = deepConfig++newObject :: [(Key, Value)] -> Object+newObject = HashMap.fromList++deepConfig :: Gen DeepObject+deepConfig = sized deepConfig' >>= \(keys, obj) ->+    return $ DeepObject (Config [] obj) $ List.tail keys++deepConfig' :: Int -> Gen ([Key], Object)+deepConfig' 0 = arbitrary >>= \newKey -> return $ ([newKey], newObject [])+deepConfig' n | n > 0 = do+    newKey <- arbitrary+    (keys, newNode) <- deepConfig' (pred n)+    return $ (newKey : keys, newObject [(List.head keys , Object newNode)])++testCorrectSubconfigPath :: DeepObject -> Bool+testCorrectSubconfigPath (DeepObject _ []) = True+testCorrectSubconfigPath (DeepObject config (key : others)) =+    maybe False (`subcheck` others) $ lookupSubconfig config key+  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+  where+    nextCheck = maybe False (testWrongSubconfigPath . nextDeep) $+        lookupSubconfig config nextKey+    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)+  where+    subcheck sc keys = testCorrectPath' (nextKey : path) $ DeepObject sc keys+    checkPath c = fullpath c nextKey ==+                  (ST.intercalate "." $ List.reverse $ nextKey : path)+testCorrectPath' _ (DeepObject config []) = List.null $ keys config++main :: IO ()+main = defaultMain+    [+        testGroup "lookup"+            [ testProperty "wrongSubconfigPath" testWrongSubconfigPath+            , testProperty "correctSubconfigPath" testCorrectSubconfigPath+            , testProperty "correctPath" testCorrectPath+            ]+    ]
+ yaml-config.cabal view
@@ -0,0 +1,48 @@+Name:               yaml-config+Version:            0.0.1+Synopsis:           Configuration management+Description:        Configuration management+License:            MIT+License-file:       LICENSE+Copyright:          Selectel+Author:             Fedor Gogolev <knsd@knsd.net>+                    Mitroshin Maxim <mitroshin@selectel.org>+Maintainer:         mitroshin@selectel.org+Category:           Configuration+Build-type:         Simple+Cabal-version:      >= 1.14+Tested-with:        GHC == 7.6.*++Library+  Hs-source-dirs:   src+  Default-language: Haskell2010+  Ghc-options:      -Wall -fno-warn-orphans+  Build-depends:    base                       == 4.6.* || == 4.5.*+                  , deepseq                    == 1.3.*+                  , unordered-containers       == 0.2.*+                  , text                       == 0.11.*+                  , yaml                       == 0.8.*++  Exposed-modules:  Data.Yaml.Config+  Other-modules:    Data.Yaml.Config.Internal++Test-suite howl-tests+  Main-is:          Tests.hs+  Hs-source-dirs:   src, tests+  Default-language: Haskell2010+  Type:             exitcode-stdio-1.0++  Build-depends:    base                       == 4.6.* || == 4.5.*+                  , deepseq                    == 1.3.*+                  , unordered-containers       == 0.2.*+                  , text                       == 0.11.*+                  , yaml                       == 0.8.*+                  , hashable                   == 1.2.*++                  , test-framework             == 0.8.*+                  , test-framework-quickcheck2 == 0.3.*+                  , QuickCheck                 == 2.5.*++Source-repository head+    Type:     git+    Location: https://github.com/selectel/yaml-config