configurator-ng (empty) → 0.0.0.0
raw patch · 21 files changed
+3303/−0 lines, 21 filesdep +HUnitdep +attoparsecdep +basesetup-changed
Dependencies added: HUnit, attoparsec, base, bytestring, configurator-ng, critbit, data-ordlist, directory, dlist, fail, filepath, hashable, scientific, test-framework, test-framework-hunit, text, unix-compat, unordered-containers
Files
- Data/Configurator.hs +527/−0
- Data/Configurator/Config.hs +61/−0
- Data/Configurator/Config/Implementation.hs +230/−0
- Data/Configurator/Config/Internal.hs +31/−0
- Data/Configurator/FromValue.hs +42/−0
- Data/Configurator/FromValue/Implementation.hs +684/−0
- Data/Configurator/FromValue/Internal.hs +15/−0
- Data/Configurator/Parser.hs +241/−0
- Data/Configurator/Parser/Implementation.hs +193/−0
- Data/Configurator/Parser/Internal.hs +17/−0
- Data/Configurator/Syntax.hs +180/−0
- Data/Configurator/Types.hs +32/−0
- Data/Configurator/Types/Internal.hs +261/−0
- LICENSE +30/−0
- README.markdown +359/−0
- Setup.lhs +3/−0
- configurator-ng.cabal +110/−0
- tests/Test.hs +218/−0
- tests/resources/import.cfg +4/−0
- tests/resources/interp.cfg +18/−0
- tests/resources/pathological.cfg +47/−0
+ Data/Configurator.hs view
@@ -0,0 +1,527 @@+{-# LANGUAGE CPP, BangPatterns, OverloadedStrings, RecordWildCards,+ ScopedTypeVariables, TupleSections #-}++-- |+-- Module: Data.Configurator+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2015-2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- A simple (yet powerful) library for working with configuration+-- files.+--+-- Note that while the "Data.Configurator.Parser" and+-- "Data.Configurator.FromValue" should be quite stable at this point,+-- this module is likely to be subjected to significant breaking changes in+-- subsequent versions of configurator-ng. So please do file an issue+-- if you have any opinions or especially needs with regards to+-- configuration (re)loading, change notifications, etc.++module Data.Configurator+ (+ -- * Configuration file format+ -- $format++ -- ** Binding a name to a value+ -- $binding++ -- *** Value types+ -- $types++ -- *** String interpolation+ -- $interp++ -- ** Grouping directives+ -- $group++ -- ** Importing files+ -- $import++ -- * Types+ Worth(..)+ -- * Loading configuration data+ , autoReload+ , autoReloadGroups+ , autoConfig+{--+ -- * Lookup functions++ , lookup+ , lookupDefault+ , require+--}+ -- * Notification of configuration changes+ -- $notify+ , prefix+ , exact+ , subscribe+ -- * Low-level loading functions+ , load+ , loadGroups+ , reload+ , addToConfig+ , addGroupsToConfig+ -- * Helper functions+ , display+ , readConfig+ ) where++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ((<$>))+#endif+import Control.Concurrent (ThreadId, forkIO, threadDelay)+import Control.Exception (SomeException, evaluate, handle, throwIO, try)+import Control.Monad (foldM, forM, forM_, when, msum)+import Data.Configurator.Syntax (interp, topLevel)+import Data.Configurator.Types.Internal+import Data.Configurator.Config.Internal(ConfigPlan(ConfigPlan), Config(Config))+import Data.Int (Int64)+import Data.IORef (atomicModifyIORef, newIORef, readIORef)+import Data.List (tails)+import Data.Maybe (isJust)+#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (mconcat)+#endif+import Data.Scientific ( toBoundedInteger, toRealFloat )+import Data.Text.Lazy.Builder (fromString, fromText, toLazyText)+import Data.Text.Lazy.Builder.Int (decimal)+import Data.Text.Lazy.Builder.RealFloat (realFloat)+import Prelude hiding (lookup)+import System.Environment (getEnv)+import System.IO (hPutStrLn, stderr)+import System.Posix.Types (EpochTime, FileOffset)+import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)+import qualified Control.Exception as E+import qualified Data.Attoparsec.Text as T+import qualified Data.Attoparsec.Text.Lazy as L+import qualified Data.HashMap.Lazy as H+import qualified Data.CritBit.Map.Lazy as CB+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L++loadFiles :: [Worth Path] -> IO (H.HashMap (Worth Path) [Directive])+loadFiles = foldM go H.empty+ where+ go seen path = do+ let rewrap n = const n <$> path+ wpath = worth path+ path' <- rewrap <$> interpolate "" wpath CB.empty+ ds <- loadOne (T.unpack <$> path')+ let !seen' = H.insert path ds seen+ notSeen n = not . isJust . H.lookup n $ seen+ foldM go seen' . filter notSeen . importsOf wpath $ ds++-- | Create a 'ConfigCache' from the contents of the named files. Throws an+-- exception on error, such as if files do not exist or contain errors.+--+-- File names have any environment variables expanded prior to the+-- first time they are opened, so you can specify a file name such as+-- @\"$(HOME)/myapp.cfg\"@.+load :: [Worth FilePath] -> IO ConfigCache+load files = load' Nothing (map (\f -> ("", f)) files)++-- | Create a 'ConfigCache' from the contents of the named files, placing them+-- into named prefixes. If a prefix is non-empty, it should end in a+-- dot.+loadGroups :: [(Name, Worth FilePath)] -> IO ConfigCache+loadGroups files = load' Nothing files++load' :: Maybe AutoConfig -> [(Name, Worth FilePath)] -> IO ConfigCache+load' auto paths0 = do+ let second f (x,y) = (x, f y)+ paths = map (second (fmap T.pack)) paths0+ ds <- loadFiles (map snd paths)+ p <- newIORef paths+ m <- newIORef =<< flatten paths ds+ s <- newIORef H.empty+ return ConfigCache {+ cfgAuto = auto+ , cfgPaths = p+ , cfgMap = m+ , cfgSubs = s+ }++-- | Forcibly reload a 'ConfigCache'. Throws an exception on error, such as+-- if files no longer exist or contain errors.+reload :: ConfigCache -> IO ()+reload cfg@ConfigCache{..} = do+ paths <- readIORef cfgPaths+ m' <- flatten paths =<< loadFiles (map snd paths)+ m <- atomicModifyIORef cfgMap $ \m -> (m', m)+ notifySubscribers cfg m m' =<< readIORef cfgSubs++-- | Add additional files to a 'ConfigCache', causing it to be reloaded to add+-- their contents.+addToConfig :: [Worth FilePath] -> ConfigCache -> IO ()+addToConfig paths0 cfg = addGroupsToConfig (map (\x -> ("",x)) paths0) cfg++-- | Add additional files to named groups in a 'ConfigCache', causing it to be+-- reloaded to add their contents. If the prefixes are non-empty, they should+-- end in dots.+addGroupsToConfig :: [(Name, Worth FilePath)] -> ConfigCache -> IO ()+addGroupsToConfig paths0 cfg@ConfigCache{..} = do+ let fix (x,y) = (x, fmap T.pack y)+ paths = map fix paths0+ atomicModifyIORef cfgPaths $ \prev -> (prev ++ paths, ())+ reload cfg++-- | Defaults for automatic 'Config' reloading when using+-- 'autoReload'. The 'interval' is one second, while the 'onError'+-- action ignores its argument and does nothing.+autoConfig :: AutoConfig+autoConfig = AutoConfig {+ interval = 1+ , onError = const $ return ()+ }++-- | Load a 'ConfigCache' from the given 'FilePath's, and start a reload+-- thread.+--+-- At intervals, a thread checks for modifications to both the+-- original files and any files they refer to in @import@ directives,+-- and reloads the 'ConfigCache' if any files have been modified.+--+-- If the initial attempt to load the configuration files fails, an+-- exception is thrown. If the initial load succeeds, but a+-- subsequent attempt fails, the 'onError' handler is invoked.+--+-- File names have any environment variables expanded prior to the+-- first time they are opened, so you can specify a file name such as+-- @\"$(HOME)/myapp.cfg\"@.+autoReload :: AutoConfig+ -- ^ Directions for when to reload and how to handle+ -- errors.+ -> [Worth FilePath]+ -- ^ Configuration files to load.+ -> IO (ConfigCache, ThreadId)+autoReload auto paths = autoReloadGroups auto (map (\x -> ("", x)) paths)++autoReloadGroups :: AutoConfig+ -> [(Name, Worth FilePath)]+ -> IO (ConfigCache, ThreadId)+autoReloadGroups AutoConfig{..} _+ | interval < 1 = error "autoReload: negative interval"+autoReloadGroups _ [] = error "autoReload: no paths to load"+autoReloadGroups auto@AutoConfig{..} paths = do+ cfg <- load' (Just auto) paths+ let files = map snd paths+ loop meta = do+ threadDelay (max interval 1 * 1000000)+ meta' <- getMeta files+ if meta' == meta+ then loop meta+ else (reload cfg `E.catch` onError) >> loop meta'+ tid <- forkIO $ loop =<< getMeta files+ return (cfg, tid)++-- | Save both a file's size and its last modification date, so we+-- have a better chance of detecting a modification on a crappy+-- filesystem with timestamp resolution of 1 second or worse.+type Meta = (FileOffset, EpochTime)++getMeta :: [Worth FilePath] -> IO [Maybe Meta]+getMeta paths = forM paths $ \path ->+ handle (\(_::SomeException) -> return Nothing) . fmap Just $ do+ st <- getFileStatus (worth path)+ return (fileSize st, modificationTime st)++{--+-- | Look up a name in the given 'ConfigCache'. If a binding exists, and+-- the value can be 'convert'ed to the desired type, return the+-- converted value, otherwise 'Nothing'.+lookup :: Configured a => ConfigCache -> Name -> IO (Maybe a)+lookup ConfigCache{..} name =+ (convert . CB.lookup name) <$> readIORef cfgMap+--}++{--+-- | Look up a name in the given 'ConfigCache'. If a binding exists, and+-- the value can be 'convert'ed to the desired type, return the+-- converted value, otherwise throw a 'KeyError'.+require :: Configured a => ConfigCache -> Name -> IO a+require cfg name = do+ val <- lookup cfg name+ case val of+ Just v -> return v+ _ -> throwIO . KeyError $ name+--}++{--+-- | Look up a name in the given 'ConfigCache'. If a binding exists, and+-- the value can be converted to the desired type, return it,+-- otherwise return the default value.+lookupDefault :: Configured a =>+ a+ -- ^ Default value to return if 'lookup' or 'convert'+ -- fails.+ -> ConfigCache -> Name -> IO a+lookupDefault def cfg name = fromMaybe def <$> lookup cfg name+--}++-- | Perform a simple dump of a 'ConfigCache' to @stdout@.+display :: ConfigCache -> IO ()+display ConfigCache{..} = print =<< readIORef cfgMap++-- | Read the current configuration stored in the cache.+readConfig :: ConfigCache -> IO Config+readConfig = (Config . ConfigPlan <$>) . readIORef . cfgMap++flatten :: [(Name, Worth Path)]+ -> H.HashMap (Worth Path) [Directive]+ -> IO (CB.CritBit Name Value)+flatten roots files = foldM doPath CB.empty roots+ where+ doPath m (pfx, f) = case H.lookup f files of+ Nothing -> return m+ Just ds -> foldM (directive pfx (worth f)) m ds++ directive pfx _ m (Bind name (String value)) = do+ v <- interpolate pfx value m+ return $! CB.insert (T.append pfx name) (String v) m+ directive pfx _ m (Bind name value) =+ return $! CB.insert (T.append pfx name) value m+ directive pfx f m (Group name xs) = foldM (directive pfx' f) m xs+ where pfx' = T.concat [pfx, name, "."]+ directive pfx f m (Import path) =+ let f' = relativize f path+ in case H.lookup (Required (relativize f path)) files of+ Just ds -> foldM (directive pfx f') m ds+ _ -> return m+ directive _ _ m (DirectiveComment _) = return m++interpolate :: T.Text -> T.Text -> CB.CritBit Name Value -> IO T.Text+interpolate pfx s env+ | "$" `T.isInfixOf` s =+ case T.parseOnly interp s of+ Left err -> throwIO $ ParseError "" err+ Right xs -> (L.toStrict . toLazyText . mconcat) <$> mapM interpret xs+ | otherwise = return s+ where+ lookupEnv name = msum $ map (flip CB.lookup env) fullnames+ where fullnames = map (T.intercalate ".") -- ["a.b.c.x","a.b.x","a.x","x"]+ . map (reverse . (name:)) -- [["a","b","c","x"],["a","b","x"],["a","x"],["x"]]+ . tails -- [["c","b","a"],["b","a"],["a"],[]]+ . reverse -- ["c","b","a"]+ . filter (not . T.null) -- ["a","b","c"]+ . T.split (=='.') -- ["a","b","c",""]+ $ pfx -- "a.b.c."++ interpret (Literal x) = return (fromText x)+ interpret (Interpolate name) =+ case lookupEnv name of+ Just (String x) -> return (fromText x)+ Just (Number r) ->+ case toBoundedInteger r :: Maybe Int64 of+ Just n -> return (decimal n)+ Nothing -> return (realFloat (toRealFloat r :: Double))+ Just _ -> error "type error"+ _ -> do+ e <- try . getEnv . T.unpack $ name+ case e of+ Left (_::SomeException) ->+ throwIO . ParseError "" $ "no such variable " ++ show name+ Right x -> return (fromString x)++importsOf :: Path -> [Directive] -> [Worth Path]+importsOf path (Import ref : xs) = Required (relativize path ref)+ : importsOf path xs+importsOf path (Group _ ys : xs) = importsOf path ys ++ importsOf path xs+importsOf path (_ : xs) = importsOf path xs+importsOf _ _ = []++relativize :: Path -> Path -> Path+relativize parent child+ | T.head child == '/' = child+ | otherwise = fst (T.breakOnEnd "/" parent) `T.append` child++loadOne :: Worth FilePath -> IO [Directive]+loadOne path = do+ es <- try . L.readFile . worth $ path+ case es of+ Left (err::SomeException) -> case path of+ Required _ -> throwIO err+ _ -> return []+ Right s -> do+ p <- evaluate (L.eitherResult $ L.parse topLevel s)+ `E.catch` \(e::ParseError) ->+ throwIO $ case e of+ ParseError _ err -> ParseError (worth path) err+ case p of+ Left err -> throwIO (ParseError (worth path) err)+ Right ds -> return ds++-- | Subscribe for notifications. The given action will be invoked+-- when any change occurs to a configuration property matching the+-- supplied pattern.+subscribe :: ConfigCache -> Pattern -> ChangeHandler -> IO ()+subscribe ConfigCache{..} pat act = do+ m' <- atomicModifyIORef cfgSubs $ \m ->+ let m' = H.insertWith (++) pat [act] m in (m', m')+ evaluate m' >> return ()++notifySubscribers :: ConfigCache -> CB.CritBit Name Value -> CB.CritBit Name Value+ -> H.HashMap Pattern [ChangeHandler] -> IO ()+notifySubscribers ConfigCache{..} m m' subs = H.foldrWithKey go (return ()) subs+ where+ changedOrGone = CB.foldrWithKey check [] m+ where check n v nvs = case CB.lookup n m' of+ Just v' | v /= v' -> (n,Just v'):nvs+ | otherwise -> nvs+ _ -> (n,Nothing):nvs+ new = CB.foldrWithKey check [] m'+ where check n v nvs = case CB.lookup n m of+ Nothing -> (n,v):nvs+ _ -> nvs+ notify p n v a = a n v `E.catch` maybe report onError cfgAuto+ where report e = hPutStrLn stderr $+ "*** a ChangeHandler threw an exception for " +++ show (p,n) ++ ": " ++ show e+ go p@(Exact n) acts next = (const next =<<) $ do+ let v' = CB.lookup n m'+ when (CB.lookup n m /= v') . mapM_ (notify p n v') $ acts+ go p@(Prefix n) acts next = (const next =<<) $ do+ let matching = filter (T.isPrefixOf n . fst)+ forM_ (matching new) $ \(n',v) -> mapM_ (notify p n' (Just v)) acts+ forM_ (matching changedOrGone) $ \(n',v) -> mapM_ (notify p n' v) acts++-- $format+--+-- A configuration file consists of a series of directives and+-- comments, encoded in UTF-8. A comment begins with a \"@#@\"+-- character, and continues to the end of a line.+--+-- Files and directives are processed from first to last, top to+-- bottom.++-- $binding+--+-- A binding associates a name with a value.+--+-- > my_string = "hi mom! \u2603"+-- > your-int-33 = 33+-- > his_bool = on+-- > HerList = [1, "foo", off]+--+-- A name must begin with a Unicode letter, which is followed by zero+-- or more of a Unicode alphanumeric code point, hyphen \"@-@\", or+-- underscore \"@_@\".+--+-- Bindings are created or overwritten in the order in which they are+-- encountered. It is legitimate for a name to be bound multiple+-- times, in which case the last value wins.+--+-- > a = 1+-- > a = true+-- > # value of a is now true, not 1++-- $types+--+-- The configuration file format supports the following data types:+--+-- * Booleans, represented as @on@ or @off@, @true@ or @false@. These+-- are case sensitive, so do not try to use @True@ instead of+-- @true@!+--+-- * Decimal fractions, expressed in scientific notation.+--+-- * Unicode strings, represented as text (possibly containing escape+-- sequences) surrounded by double quotes.+--+-- * Heterogeneous lists of values, represented as an opening square+-- bracket \"@[@\", followed by a series of comma-separated values,+-- ending with a closing square bracket \"@]@\".+--+-- The following escape sequences are recognised in a text string:+--+-- * @\\n@ - newline+--+-- * @\\r@ - carriage return+--+-- * @\\t@ - horizontal tab+--+-- * @\\\\@ - backslash+--+-- * @\\\"@ - double quote+--+-- * @\\u@/xxxx/ - Unicode character from the basic multilingual+-- plane, encoded as four hexadecimal digits+--+-- * @\\u@/xxxx/@\\u@/xxxx/ - Unicode character from an astral plane,+-- as two hexadecimal-encoded UTF-16 surrogates++-- $interp+--+-- Strings support interpolation, so that you can dynamically+-- construct a string based on data in your configuration or the OS+-- environment.+--+-- If a string value contains the special sequence \"@$(foo)@\" (for+-- any name @foo@), then the name @foo@ will be looked up in the+-- configuration data and its value substituted. If that name cannot+-- be found, it will be looked up in the OS environment.+--+-- For security reasons, it is an error for a string interpolation+-- fragment to contain a name that cannot be found in either the+-- current configuration or the environment.+--+-- To represent a single literal \"@$@\" character in a string, double+-- it: \"@$$@\".++-- $group+--+-- It is possible to group a number of directives together under a+-- single prefix:+--+-- > my-group+-- > {+-- > a = 1+-- >+-- > # groups support nesting+-- > nested {+-- > b = "yay!"+-- > }+-- > }+--+-- The name of a group is used as a prefix for the items in the+-- group. For instance, the value of \"@a@\" above can be retrieved+-- using 'lookup' by supplying the name \"@my-group.a@\", and \"@b@\"+-- will be named \"@my-group.nested.b@\".++-- $import+--+-- To import the contents of another configuration file, use the+-- @import@ directive.+--+-- > import "$(HOME)/etc/myapp.cfg"+--+-- Absolute paths are imported as is. Relative paths are resolved with+-- respect to the file they are imported from. It is an error for an+-- @import@ directive to name a file that does not exist, cannot be read,+-- or contains errors.+--+-- If an @import@ appears inside a group, the group's naming prefix+-- will be applied to all of the names imported from the given+-- configuration file.+--+-- Supposing we have a file named \"@foo.cfg@\":+--+-- > bar = 1+--+-- And another file that imports it into a group:+--+-- > hi {+-- > import "foo.cfg"+-- > }+--+-- This will result in a value named \"@hi.bar@\".++-- $notify+--+-- To more efficiently support an application's need to dynamically+-- reconfigure, a subsystem may ask to be notified when a+-- configuration property is changed as a result of a reload, using+-- the 'subscribe' action.
+ Data/Configurator/Config.hs view
@@ -0,0 +1,61 @@+-- |+-- Module: Data.Configurator.Config+-- Copyright: (c) 2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+--+-- This module provides the abstract data structure that backs @ConfigCache@+-- and that @ConfigParser@s operate on.+--+-- It shouldn't be necessary to use this module much, if at all, in client+-- code. It might be considered semi-internal. Please file a issue if you+-- find a need to use it.++module Data.Configurator.Config+ ( Config+ , empty+ , null+ , lookup+ , lookupWithName+ , subgroups+ , subassocs+ , subassocs'+ , union+ , subconfig+ , superconfig+ ) where++import Prelude hiding (lookup,null)+import Data.Configurator.Types(Name,Value)+import Data.Configurator.Config.Implementation(Config(..),ConfigPlan(Empty))+import qualified Data.Configurator.Config.Implementation as C++lookup :: Name -> Config -> Maybe Value+lookup k (Config c) = C.lookup k c++lookupWithName :: Name -> Config -> Maybe (Name, Value)+lookupWithName k (Config c) = C.lookupWithName k c++subgroups :: Name -> Config -> [Name]+subgroups k (Config c) = C.subgroups k c++subassocs :: Name -> Config -> [(Name,Value)]+subassocs k (Config c) = C.subassocs k c++subassocs' :: Name -> Config -> [(Name,Value)]+subassocs' k (Config c) = C.subassocs' k c++empty :: Config+empty = Config Empty++null :: Config -> Bool+null (Config c) = C.null c++union :: Config -> Config -> Config+union (Config a) (Config b) = Config (C.union a b)++subconfig :: Name -> Config -> Config+subconfig key (Config c) = Config (C.subconfig key c)++superconfig :: Name -> Config -> Config+superconfig key (Config c) = Config (C.superconfig key c)
+ Data/Configurator/Config/Implementation.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-}++-- |+-- Module: Data.Configurator.Config.Implementation+-- Copyright: (c) 2015-2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>++module Data.Configurator.Config.Implementation where++import Prelude hiding ((++),null)+import Control.Applicative+-- import Control.Arrow(first)+import Data.Maybe(mapMaybe)+--import Data.Ratio+--import Data.ByteString (ByteString)+import Data.Configurator.Types.Internal hiding (Group)+import Data.Typeable+import Data.CritBit.Map.Lazy (CritBit)+import qualified Data.CritBit.Map.Lazy as CB+import qualified Data.List.Ordered as OL+import Data.Monoid+import Data.Function (on)+import Data.Text(Text)+import qualified Data.Text as T+--import qualified Data.Text.Encoding as T+--import qualified Data.Text.Lazy as TL+--import qualified Data.Text.Lazy.Builder as TB+--import qualified Data.Text.Lazy.Builder.Int as TB+--import qualified Data.Text.Lazy.Builder.RealFloat as TB++data ConfigPlan a+ = Subconfig Text (ConfigPlan a)+ | Superconfig Text (ConfigPlan a)+ | Union (ConfigPlan a) (ConfigPlan a)+ | ConfigPlan a+ | Empty+ deriving (Show, Typeable, Functor)++addPrefix :: Name -> Name -> Name+addPrefix pre key+ | T.null pre = key+ | T.null key = pre+ | otherwise = T.concat [pre, ".", key]++stripPrefix :: Name -> Name -> Maybe Name+stripPrefix pre key =+ if T.null pre+ then Just key+ else case T.stripPrefix pre key of+ Nothing -> Nothing+ Just key' -> if T.null key'+ then Just T.empty+ else T.stripPrefix "." key'++foldPlan :: b -> (b -> b -> b) -> (Text -> a -> b) -> Text -> ConfigPlan a -> b+foldPlan empty union lookup = loop+ where+ loop key (Subconfig pre pl ) = loop (addPrefix pre key) pl+ loop key (Superconfig pre pl ) = case stripPrefix pre key of+ Nothing -> empty+ Just key' -> loop key' pl+ loop key (Union pl1 pl2) = loop key pl1 `union` loop key pl2+ loop key (ConfigPlan a ) = lookup key a+ loop _key Empty = empty+{-# INLINE foldPlan #-}+++type ConfigMap a = ConfigPlan (CB.CritBit Text a)++-- | A 'Config' is a finite map from 'Text' to 'Value'.+newtype Config = Config (ConfigMap Value)++-- | FIXME: improve this implementation.+subassocs :: Text -> ConfigMap a -> [(Text,a)]+subassocs key c = filter pred (subassocs' key c)+ where+ pred (name,_) = case stripPrefix key name of+ Nothing -> False -- shouldn't happen+ Just name' -> T.find ('.'==) name' == Nothing++subassocs' :: Text -> ConfigMap a -> [(Text,a)]+subassocs' key c = subassocs_ subassocsMap key c++lookup :: Text -> ConfigMap a -> Maybe a+lookup = foldPlan Nothing (<|>) CB.lookup++lookupWithName :: Name -> ConfigMap a -> Maybe (Name,a)+lookupWithName = foldPlan Nothing (<|>) (\k m -> (k,) <$> CB.lookup k m)++subassocs_ :: (Text -> a -> [(Text,b)])+ -> Text -> ConfigPlan a -> [(Text,b)]+subassocs_ subassocs = loop+ where+ addPrefixes pre+ | T.null pre = id+ | otherwise = map (\(k,v) -> (addPrefix pre k,v))++ stripPrefixes pre+ | T.null pre = id+ | otherwise = mapMaybe $ \(k,v) -> case stripPrefix pre k of+ Nothing -> Nothing+ Just k' -> Just (k',v)++ loop !_key Empty = []+ loop !key (Subconfig pre pl) =+ stripPrefixes pre (loop (addPrefix pre key) pl)+ loop !key (Superconfig pre pl) =+ if T.length key <= T.length pre+ then case stripPrefix key pre of+ Nothing -> []+ Just _pre' -> addPrefixes pre (loop T.empty pl)+ else case stripPrefix pre key of+ Nothing -> []+ Just key' -> addPrefixes pre (loop key' pl)+ loop !key (Union pl1 pl2) =+ OL.unionBy (compare `on` fst) (loop key pl1) (loop key pl2)+ loop !key (ConfigPlan map) = subassocs key map++submap :: Text -> CritBit Text a -> CritBit Text a+submap key map+ | T.null key = map+ | otherwise = let (_ , gt) = CB.split (key <> ".") map+ (lt, _ ) = CB.split (key <> ".~") gt+ in lt++subassocsMap :: Text -> CritBit Text a -> [(Text, a)]+subassocsMap key map = CB.assocs (submap key map)++null :: ConfigPlan (CritBit Text a) -> Bool+null = foldPlan True (&&) nullSubmap T.empty++nullSubmap :: Text -> CritBit Text a -> Bool+-- nullSubmap key map = CB.null (submap key map)+nullSubmap key map =+ if T.null key+ then CB.null map+ else case CB.lookupGT key map of+ Nothing -> True+ Just (key', _) ->+ case stripPrefix key key' of+ Nothing -> False+ Just _ -> True++subgroups :: Text -> ConfigMap a -> [Text]+subgroups = loop+ where+ stripPrefixes pre+ | T.null pre = id+ | otherwise = mapMaybe (stripPrefix pre)++ addPrefixes pre+ | T.null pre = id+ | otherwise = map (addPrefix pre)++ loop !_key Empty = []+ loop !key (Subconfig pre pl) =+ stripPrefixes pre (loop (addPrefix pre key) pl)+ loop !key (Superconfig pre pl) =+ if T.length pre <= T.length key+ then case stripPrefix pre key of+ Nothing -> []+ Just key' -> addPrefixes pre (loop key' pl)+ else case stripPrefix key pre of+ Nothing -> []+ Just pre' -> if null pl+ then []+ else [addPrefix key (T.takeWhile ('.' /=) pre')]+ loop !key (Union pl1 pl2) =+ OL.unionBy compare (loop key pl1) (loop key pl2)+ loop !key (ConfigPlan map) = subgroupsMap key map++subgroupsMap :: Text -> CritBit Text a -> [Text]+subgroupsMap pre_ map = loop (CB.lookupGT pre map)+ where+ pre | T.null pre_ = T.empty+ | otherwise = pre_ <> "."+ loop Nothing = []+ loop (Just (key,_)) =+ case T.stripPrefix pre key of+ Nothing -> []+ Just sfx -> let (sfxa, sfxz) = T.break ('.' ==) sfx+ in if T.null sfxz+ then loop (CB.lookupGT key map)+ else let key' = pre <> sfxa+ in key' : loop (CB.lookupGT (key' <> "/") map)++union :: ConfigMap a -> ConfigMap a -> ConfigMap a+union x y+ | null x = y+ | null y = x+ | otherwise = Union x y++subconfig :: Text -> ConfigMap a -> ConfigMap a+subconfig = \k c -> if T.null k then c else loop k c+ where+ loop k c =+ case c of+ Empty -> Empty+ Union a b -> union (loop k a) (loop k b)+ Superconfig kk cc ->+ if T.length k <= T.length kk+ then case stripPrefix k kk of+ Nothing -> Empty+ Just kk' -> if T.null kk'+ then cc+ else Superconfig kk' cc+ else case stripPrefix kk k of+ Nothing -> Empty+ Just k' -> loop k' cc+ ConfigPlan map ->+ let map' = submap k map+ in if CB.null map'+ then Empty+ else Subconfig k (ConfigPlan map')+ (Subconfig _ _) ->+ let c' = Subconfig k c+ in if null c'+ then Empty+ else c'++superconfig :: Text -> ConfigMap a -> ConfigMap a+superconfig k c =+ if T.null k+ then c+ else if null c+ then Empty+ else Superconfig k c
+ Data/Configurator/Config/Internal.hs view
@@ -0,0 +1,31 @@+-- |+-- Module: Data.Configurator.Config.Internal+-- Copyright: (c) 2015-2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>++module Data.Configurator.Config.Internal+ ( Config(..)+ , ConfigMap+ , ConfigPlan(..)++ , lookup+ , lookupWithName+ , subgroups+ , subassocs++ , null+ , subconfig+ , superconfig+ , union++ , subassocs_+ , foldPlan+ , submap+ , subgroupsMap+ , addPrefix+ , stripPrefix+ ) where++import Prelude hiding (lookup, null)+import Data.Configurator.Config.Implementation
+ Data/Configurator/FromValue.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: Data.Configurator.FromValue+-- Copyright: (c) 2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>++module Data.Configurator.FromValue+ ( MaybeParser+ , runMaybeParser+ , FromMaybeValue(..)+ , optionalValue+ , requiredValue+ , ValueParser+ , runValueParser+ , FromValue(..)+ , ListParser+ , FromListValue(..)+ , listValue+ , listValue'+ , listElem+ , ConversionError(..)+ , ConversionErrorWhy(..)+ , defaultConversionError+ -- * Assorted primitive value parsers+ , boundedIntegerValue+ , integralValue+ , fractionalValue+ , realFloatValue+ , fixedValue+ , scientificValue+ , textValue+ , charValue+ , typeError+ , valueError+ , extraValuesError+ , missingValueError+ ) where++import Data.Configurator.FromValue.Implementation+import Data.Configurator.Types
+ Data/Configurator/FromValue/Implementation.hs view
@@ -0,0 +1,684 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances, DefaultSignatures #-}+{-# LANGUAGE ScopedTypeVariables, BangPatterns, ViewPatterns #-}+{-# LANGUAGE OverloadedStrings, OverlappingInstances #-}++-- |+-- Module: Data.Configurator.FromValue.Implementation+-- Copyright: (c) 2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>++module Data.Configurator.FromValue.Implementation where++import Control.Applicative+import Control.Arrow (first, second)+import Control.Monad (ap)+import qualified Control.Monad.Fail as Fail+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Complex (Complex((:+)))+import Data.Configurator.Types+ ( Value(..)+ , ConversionError(..)+ , ConversionErrorWhy(..)+ , defaultConversionError+ )+import Data.Configurator.Types.Internal+ ( MultiErrors+ , singleError+ , toErrors+ )+import Data.Fixed (Fixed, HasResolution)+import Data.Int(Int8, Int16, Int32, Int64)+import Data.Monoid+import Data.Ratio ( Ratio, (%) )+import Data.Scientific+ ( Scientific, coefficient, base10Exponent, normalize+ , floatingOrInteger, toRealFloat, toBoundedInteger )+import Data.Text(Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import Data.Text.Encoding(encodeUtf8)+import Data.Typeable(Typeable, TypeRep, typeOf)+#if !(MIN_VERSION_base(4,8,0))+import Data.Word(Word)+#endif+import Data.Word(Word8, Word16, Word32, Word64)+import Foreign.C.Types(CFloat, CDouble)++type ConversionErrors = MultiErrors ConversionError++-- | An action to turn a 'Maybe' 'Value' into zero or one values of type @a@,+-- and possibly report errors/warnings.+newtype MaybeParser a = MaybeParser {+ unMaybeParser :: Maybe Value -> (Maybe a, ConversionErrors)+ } deriving (Functor, Typeable)++-- | An action to turn a 'Value' into zero or one values of type @a@,+-- and possibly report errors/warnings.+newtype ValueParser a = ValueParser {+ unValueParser :: Value -> (Maybe a, ConversionErrors)+ } deriving (Functor, Typeable)++data ListParserResult a =+ NonListError+ | ListError+ | ListOk a [Value]+ deriving (Functor, Typeable)++-- | An action to turn a @['Value']@ into zero or one values of type @a@,+-- and possibly report errors/warnings.+newtype ListParser a = ListParser {+ unListParser :: [Value] -> (ListParserResult a, ConversionErrors)+ } deriving (Functor, Typeable)++instance Applicative MaybeParser where+ pure a = MaybeParser $ \_v -> (Just a, mempty)+ (<*>) ff fa =+ MaybeParser $ \v ->+ case unMaybeParser ff v of+ (Nothing, w) -> (Nothing, w)+ (Just f , w) ->+ case unMaybeParser fa v of+ (Nothing, w') -> (Nothing , w <> w')+ (Just a , w') -> (Just (f a), w <> w')++instance Applicative ValueParser where+ pure a = ValueParser $ \_v -> (Just a, mempty)+ (<*>) ff fa =+ ValueParser $ \v ->+ case unValueParser ff v of+ (Nothing, w) -> (Nothing, w)+ (Just f , w) ->+ case unValueParser fa v of+ (Nothing, w') -> (Nothing , w <> w')+ (Just a , w') -> (Just (f a), w <> w')++instance Alternative ValueParser where+ empty = ValueParser $ \_v -> (Nothing, mempty)+ f <|> g = ValueParser $ \v ->+ case unValueParser f v of+ (Nothing, Nothing) -> unValueParser g v+ (Nothing, w) ->+ case unValueParser g v of+ (Nothing, w') -> (Nothing, w <> w')+ res -> res+ res -> res++ some v = repeat <$> v+ many v = some v <|> pure []++instance Alternative MaybeParser where+ empty = MaybeParser $ \_v -> (Nothing, mempty)+ f <|> g = MaybeParser $ \v ->+ case unMaybeParser f v of+ (Nothing, Nothing) -> unMaybeParser g v+ (Nothing, w) ->+ case unMaybeParser g v of+ (Nothing, w') -> (Nothing, w <> w')+ res -> res+ res -> res++ some v = repeat <$> v+ many v = some v <|> pure []++instance Monad MaybeParser where+#if !(MIN_VERSION_base(4,8,0))+ return = pure+#endif+ m >>= k = MaybeParser $ \v ->+ case unMaybeParser m v of+ (Just a, w) ->+ case w of+ Nothing -> unMaybeParser (k a) v+ Just _ -> let (mb, w') = unMaybeParser (k a) v+ in (mb, w <> w')+ (Nothing, w) -> (Nothing, w)++ fail = Fail.fail++instance Monad ValueParser where+#if !(MIN_VERSION_base(4,8,0))+ return = pure+#endif+ m >>= k = ValueParser $ \v ->+ case unValueParser m v of+ (Just a, w) ->+ case w of+ Nothing -> unValueParser (k a) v+ Just _ -> let (mb, w') = unValueParser (k a) v+ in (mb, w <> w')+ (Nothing, w) -> (Nothing, w)++ fail = Fail.fail++instance Fail.MonadFail MaybeParser where+ fail msg = MaybeParser $ \_v -> (Nothing, singleError (failError msg))++instance Fail.MonadFail ValueParser where+ fail msg = ValueParser $ \_v -> (Nothing, singleError (failError msg))++failError :: String -> ConversionError+failError msg = defaultConversionError {+ conversionErrorLoc = "fail",+ conversionErrorWhy = MonadFail,+ conversionErrorMsg = Just (T.pack msg)+ }++runMaybeParser :: MaybeParser a -> Maybe Value -> (Maybe a, [ConversionError])+runMaybeParser p = second toErrors . unMaybeParser p++runValueParser :: ValueParser a -> Value -> (Maybe a, [ConversionError])+runValueParser p = second toErrors . unValueParser p++instance Applicative ListParser where+ pure a = ListParser $ \vs -> (ListOk a vs, mempty)+ (<*>) = ap++instance Alternative ListParser where+ empty = ListParser $ \_v -> (ListError, mempty)+ f <|> g = ListParser $ \v ->+ case unListParser f v of+ (ListError, Nothing) -> unListParser g v+ (ListError, w) ->+ case unListParser g v of+ (ListError, w') -> (ListError, w <> w')+ res -> res+ res -> res++instance Monad ListParser where+#if !(MIN_VERSION_base(4,8,0))+ return = pure+#endif+ m >>= k = ListParser $ \v ->+ case unListParser m v of+ (ListOk a v', w) ->+ case w of+ Nothing -> unListParser (k a) v'+ Just _ -> let (mb, w') = unListParser (k a) v'+ in (mb, w <> w')+ (ListError, w) ->+ (ListError, w)+ (NonListError, w) ->+ (NonListError, w)++ fail = Fail.fail++instance Fail.MonadFail ListParser where+ fail msg = ListParser $ \_v -> (NonListError, singleError (failError msg))++-- | Turns a 'ValueParser' into a 'MaybeParser'. If the 'Maybe' 'Value' the+-- parser is passed is 'Nothing' (which normally means a key was not found),+-- then this returns the @Nothing@ value with no errors or warnings.+-- Otherwise, it passes the 'Value' to the subparser. If the+-- subparser returns a result value, then this returns 'Just' the value.+-- Otherwise, if the subparser does not return a value, then this does+-- not return a value.+--+-- Any errors/warnings returned by the subparser are returned exactly as-is.++optionalValue :: ValueParser a -> MaybeParser (Maybe a)+optionalValue p =+ MaybeParser $ \mv ->+ case mv of+ Nothing -> (Just Nothing, mempty)+ Just v -> first (Just <$>) (unValueParser p v)++-- | Turns a 'ValueParser' into a 'MaybeParser'. If the 'Maybe' 'Value' the+-- parser is passed is 'Nothing' (which normally means a key was not found),+-- then this does not return a value and also returns a 'missingValueError'.+-- Otherwise, the 'Value' is passed to the subparser, and the result+-- and any errors/warnings are returned as-is.++requiredValue :: forall a. Typeable a => ValueParser a -> MaybeParser a+requiredValue p =+ MaybeParser $ \mv ->+ case mv of+ Nothing -> (Nothing, err)+ Just v -> unValueParser p v+ where+ funcName = "requiredValue"+ err = singleError $ missingValueError funcName (typeOf (undefined :: a))++missingValueError :: Text -> TypeRep -> ConversionError+missingValueError funcName typ = defaultConversionError {+ conversionErrorLoc = funcName,+ conversionErrorWhy = MissingValue,+ conversionErrorType = Just typ+ }++-- | Turns a 'ListParser' into a 'ValueParser'. It first checks that the+-- 'Value' the 'ValueParser' is passed is a 'List' Value. If it's not,+-- this returns no result as well as a 'typeError'. Otherwise, it passes+-- the list of results to the 'ListParser' subparser.+--+-- If the subparser consumes all of the list elements, this returns the+-- value and errors as-is. If there are leftover list elements, this+-- returns the value, and adds a message warning of the extra elements+-- to the list of errors.+--+-- The difference from 'listValue\'' is that this returns values with+-- unconsumed list elements (discarding the list elements).++listValue :: forall a. Typeable a => ListParser a -> ValueParser a+listValue p =+ ValueParser $ \v ->+ case v of+ List vs ->+ case unListParser p vs of+ (ListOk a vs', errs) ->+ case vs' of+ [] -> (Just a, errs)+ (_:_) -> (,) (Just a) $! errs <> extraErr vs+ (_, errs) -> (Nothing, errs)+ _ -> (Nothing, typeErr v)+ where+ fn = "listValue"+ extraErr vs = singleError $ extraValuesError fn vs (typeOf (undefined :: a))+ typeErr v = singleError $ typeError fn v (typeOf (undefined :: a))++-- | Turns a 'ListParser' into a 'ValueParser'. It first checks that the+-- 'Value' the 'ValueParser' is passed is a 'List' Value. If it's not,+-- this returns no result as well as a 'typeError'. Otherwise, it passes+-- the list of results to the 'ListParser' subparser.+--+-- If the subparser consumes all of the list elements, this returns the+-- value and errors as-is. If there are leftover list elements, this+-- returns no value, and adds a message warning of the extra elements+-- to the list of errors.+--+-- The difference from 'listValue' is that this never returns a value if+-- there are unconsumed list elements. (discarding both the value returned+-- and the list element.)++listValue' :: forall a. Typeable a => ListParser a -> ValueParser a+listValue' p =+ ValueParser $ \v ->+ case v of+ List vs ->+ case unListParser p vs of+ (ListOk a vs', errs) ->+ case vs' of+ [] -> (Just a, errs)+ (_:_) -> (,) Nothing $! errs <> extraErr vs+ (_, errs) -> (Nothing, errs)+ _ -> (Nothing, typeErr v)+ where+ fn = "listValue'"+ extraErr vs = singleError $ extraValuesError fn vs (typeOf (undefined :: a))+ typeErr v = singleError $ typeError fn v (typeOf (undefined :: a))++-- | Turns a 'ValueParser' into a 'ListParser' that consumes a single element.+--+-- If there are no list elements left, this returns list error value and an+-- 'ExhaustedValues' error.+--+-- If there is an element left, it is passed to the value parser. If the+-- value parser returns a value, it is returned along with the errors as-is.+-- If the value parser returns no value, then this returns a non-list error+-- value and the list of errors returned by the value parser.+--+-- The difference between a "list error value" and a "non-list error value",+-- is that the 'Alternative' instance for 'ListParser' recovers from "list+-- error" values but does not recover from "non-list error" values. This+-- behavior was chosen so that the 'optional', 'some', and 'many' combinators+-- work on 'ListParser's in a way that is hopefully least surprising.++listElem :: forall a. (Typeable a) => ValueParser a -> ListParser a+listElem p =+ ListParser $ \vs ->+ case vs of+ [] -> (ListError, exhaustedError)+ (v:vs') -> case unValueParser p v of+ (Nothing, errs) -> (NonListError, errs)+ (Just a, errs) -> (ListOk a vs', errs)+ where+ exhaustedError = singleError defaultConversionError {+ conversionErrorLoc = "listElem",+ conversionErrorWhy = ExhaustedValues,+ conversionErrorType = Just (typeOf (undefined :: a))+ }++extraValuesError :: Text -> [Value] -> TypeRep -> ConversionError+extraValuesError funcName vals typ+ = defaultConversionError {+ conversionErrorLoc = funcName,+ conversionErrorWhy = ExtraValues,+ conversionErrorVal = Just (List vals),+ conversionErrorType = Just typ+ }++typeError :: Text -> Value -> TypeRep -> ConversionError+typeError funcName val typ+ = defaultConversionError {+ conversionErrorLoc = funcName,+ conversionErrorWhy = TypeError,+ conversionErrorVal = Just val,+ conversionErrorType = Just typ+ }++boundedIntegerValue :: forall a. (Typeable a, Integral a, Bounded a)+ => ValueParser a+boundedIntegerValue =+ ValueParser $ \v ->+ case v of+ (Number r) ->+ case toBoundedInteger r of+ ja@(Just _) -> (ja , mempty)+ Nothing -> (Nothing, overflowErr r)+ _ -> (Nothing, typeErr v)+ where+ fn = "boundedIntegerValue"+ overflowErr v = singleError (overflowError fn v (typeOf (undefined :: a)))+ typeErr v = singleError (typeError fn v (typeOf (undefined :: a)))++overflowError :: Text -> Scientific -> TypeRep -> ConversionError+overflowError fn val typ = valueError fn (Number val) typ "overflow"++valueError :: Text -> Value -> TypeRep -> Text -> ConversionError+valueError funcName val typ msg+ = defaultConversionError {+ conversionErrorLoc = funcName,+ conversionErrorWhy = ValueError,+ conversionErrorVal = Just val,+ conversionErrorType = Just typ,+ conversionErrorMsg = Just msg+ }++integralValue :: forall a. (Typeable a, Integral a) => ValueParser a+integralValue =+ ValueParser $ \v ->+ case v of+ Number r ->+ if base10Exponent r >= 0+ then toIntegral r+ else let r' = normalize r+ in if base10Exponent r' >= 0+ then toIntegral r'+ else (Nothing, intErr r)+ _ -> (Nothing, typeErr v)+ where+ fn = "integralValue"+ intErr r = singleError (notAnIntegerError fn r (typeOf (undefined :: a)))+ typeErr v = singleError (typeError fn v (typeOf (undefined :: a)))++ toIntegral r =+ case floatingOrInteger r of+ Right a -> (Just a, mempty)+ -- This case should be impossible:+ Left (_::Float) -> (Nothing, intErr r)++notAnIntegerError :: Text -> Scientific -> TypeRep -> ConversionError+notAnIntegerError fn val typ = valueError fn (Number val) typ "not an integer"++fractionalValue :: forall a. (Typeable a, Fractional a) => ValueParser a+fractionalValue =+ ValueParser $ \v ->+ case v of+ Number r ->+ let !c = coefficient r+ !e = base10Exponent r+ !r' = fromRational $! if e >= 0+ then (c * 10^e) % 1+ else c % (10^(- e))+ in (Just r', mempty)+ _ -> (Nothing, typeErr v)+ where+ fn = "fractionalValue"+ typeErr v = singleError (typeError fn v (typeOf (undefined :: a)))++realFloatValue :: forall a. (Typeable a, RealFloat a) => ValueParser a+realFloatValue = realFloatValue_ (typeOf (undefined :: a))++realFloatValue_ :: (RealFloat a) => TypeRep -> ValueParser a+realFloatValue_ typ =+ ValueParser $ \v ->+ case v of+ Number (toRealFloat -> !r) -> (Just r, mempty)+ _ -> (Nothing, typeErr v)+ where+ fn = "realFloatValue"+ typeErr v = singleError (typeError fn v typ)++fixedValue :: forall a. (Typeable a, HasResolution a) => ValueParser (Fixed a)+fixedValue = fractionalValue+ -- FIXME: optimize fixedValue and/or Data.Fixed++class FromMaybeValue a where+ fromMaybeValue :: MaybeParser a+ default fromMaybeValue :: (Typeable a, FromValue a) => MaybeParser a+ fromMaybeValue = requiredValue fromValue++class FromValue a where+ fromValue :: ValueParser a++class FromListValue a where+ fromListValue :: ListParser a++instance FromValue a => FromMaybeValue (Maybe a) where+ fromMaybeValue = optionalValue fromValue++instance FromMaybeValue Bool+instance FromValue Bool where+ fromValue = boolValue++boolValue :: ValueParser Bool+boolValue =+ ValueParser $ \v ->+ case v of+ Bool b -> (Just b, mempty)+ _ -> (Nothing, typeErr v (typeOf True))+ where+ fn = "boolValue"+ typeErr v t = singleError (typeError fn v t)++instance FromMaybeValue Value where+ fromMaybeValue = MaybeParser $ \mv -> (mv, mempty)+instance FromValue Value where+ fromValue = ValueParser $ \v -> (Just v, mempty)++instance FromMaybeValue Int+instance FromValue Int where+ fromValue = boundedIntegerValue++instance FromMaybeValue Integer+instance FromValue Integer where+ fromValue = integralValue++instance FromMaybeValue Int8+instance FromValue Int8 where+ fromValue = boundedIntegerValue++instance FromMaybeValue Int16+instance FromValue Int16 where+ fromValue = boundedIntegerValue++instance FromMaybeValue Int32+instance FromValue Int32 where+ fromValue = boundedIntegerValue++instance FromMaybeValue Int64+instance FromValue Int64 where+ fromValue = boundedIntegerValue++instance FromMaybeValue Word+instance FromValue Word where+ fromValue = boundedIntegerValue++instance FromMaybeValue Word8+instance FromValue Word8 where+ fromValue = boundedIntegerValue++instance FromMaybeValue Word16+instance FromValue Word16 where+ fromValue = boundedIntegerValue++instance FromMaybeValue Word32+instance FromValue Word32 where+ fromValue = boundedIntegerValue++instance FromMaybeValue Word64+instance FromValue Word64 where+ fromValue = boundedIntegerValue++instance FromMaybeValue Double+instance FromValue Double where+ fromValue = realFloatValue++instance FromMaybeValue Float+instance FromValue Float where+ fromValue = realFloatValue++instance FromMaybeValue CDouble+instance FromValue CDouble where+ fromValue = realFloatValue++instance FromMaybeValue CFloat+instance FromValue CFloat where+ fromValue = realFloatValue++instance (Typeable a, Integral a) => FromMaybeValue (Ratio a)+instance (Typeable a, Integral a) => FromValue (Ratio a) where+ fromValue = fractionalValue++instance FromMaybeValue Scientific+instance FromValue Scientific where+ fromValue = scientificValue++scientificValue :: ValueParser Scientific+scientificValue =+ ValueParser $ \v ->+ case v of+ Number r -> (Just r, mempty)+ _ -> (Nothing, typeErr v)+ where+ fn = "scientificValue"+ typeErr v = singleError (typeError fn v (typeOf (undefined :: Scientific)))++instance (Typeable a, RealFloat a) => FromMaybeValue (Complex a)+instance (Typeable a, RealFloat a) => FromValue (Complex a) where+ fromValue = (:+ 0) <$> realFloatValue_ (typeOf (undefined :: Complex a))++instance (Typeable a, HasResolution a) => FromMaybeValue (Fixed a)+instance (Typeable a, HasResolution a) => FromValue (Fixed a) where+ fromValue = fixedValue++instance FromMaybeValue Text+instance FromValue Text where+ fromValue = textValue++textValue :: ValueParser Text+textValue = textValue_ (typeOf (undefined :: Text))++textValue_ :: TypeRep -> ValueParser Text+textValue_ typ =+ ValueParser $ \v ->+ case v of+ String r -> (Just r, mempty)+ _ -> (Nothing, typeErr v typ)+ where+ fn = "textValue"+ typeErr v t = singleError (typeError fn v t)++instance FromMaybeValue Char+instance FromValue Char where+ fromValue = charValue++charValue :: ValueParser Char+charValue =+ ValueParser $ \v ->+ case v of+ String txt ->+ case T.uncons txt of+ Nothing -> (Nothing, charErr txt)+ Just (c,txt')+ | T.null txt' -> (Just c, mempty)+ | otherwise -> (Nothing, charErr txt)+ _ -> (Nothing, typeErr v)+ where+ fn = "charValue"+ typ = typeOf (undefined :: Char)+ msg = "expecting exactly one character"+ charErr v = singleError (valueError fn (String v) typ msg)+ typeErr v = singleError (typeError fn v typ)++instance FromMaybeValue L.Text+instance FromValue L.Text where+ fromValue = L.fromStrict <$> textValue_ (typeOf (undefined :: L.Text))++instance FromMaybeValue B.ByteString+instance FromValue B.ByteString where+ fromValue = encodeUtf8 <$> textValue_ (typeOf (undefined :: B.ByteString))++instance FromMaybeValue LB.ByteString+instance FromValue LB.ByteString where+ fromValue = convert <$> textValue_ (typeOf (undefined :: LB.ByteString))+ where convert = LB.fromStrict . encodeUtf8++instance FromMaybeValue String+instance FromValue String where+ fromValue = T.unpack <$> textValue_ (typeOf (undefined :: String))++instance ( Typeable a, FromValue a+ , Typeable b, FromValue b ) => FromMaybeValue (a,b)+instance ( Typeable a, FromValue a+ , Typeable b, FromValue b ) => FromValue (a,b) where+ fromValue = listValue fromListValue+instance ( Typeable a, FromValue a+ , Typeable b, FromValue b ) => FromListValue (a,b) where+ fromListValue = (,) <$> listElem fromValue <*> listElem fromValue++instance ( Typeable a, FromValue a+ , Typeable b, FromValue b+ , Typeable c, FromValue c ) => FromMaybeValue (a,b,c)+instance ( Typeable a, FromValue a+ , Typeable b, FromValue b+ , Typeable c, FromValue c ) => FromValue (a,b,c) where+ fromValue = listValue fromListValue+instance ( Typeable a, FromValue a+ , Typeable b, FromValue b+ , Typeable c, FromValue c ) => FromListValue (a,b,c) where+ fromListValue = (,,) <$> listElem fromValue <*> listElem fromValue+ <*> listElem fromValue++instance (Typeable a, FromValue a) => FromMaybeValue [a]+instance (Typeable a, FromValue a) => FromValue [a] where+ fromValue = listValue (many (listElem fromValue))++instance ( Typeable a, FromValue a+ , Typeable b, FromValue b+ , Typeable c, FromValue c+ , Typeable d, FromValue d ) => FromMaybeValue (a,b,c,d)+instance ( Typeable a, FromValue a+ , Typeable b, FromValue b+ , Typeable c, FromValue c+ , Typeable d, FromValue d ) => FromValue (a,b,c,d) where+ fromValue = listValue fromListValue+instance ( Typeable a, FromValue a+ , Typeable b, FromValue b+ , Typeable c, FromValue c+ , Typeable d, FromValue d ) => FromListValue (a,b,c,d) where+ fromListValue = (,,,) <$> listElem fromValue <*> listElem fromValue+ <*> listElem fromValue <*> listElem fromValue++{--+parserFail :: forall a. Typeable a => T.Text -> Maybe T.Text -> ValueParser a+parserFail loc msg = ValueParser $ \st -> (Nothing, failError, st)+ where+ failError = singleError defaultConversionError {+ conversionErrorLoc = loc+ conversionErrorWhy = MonadFail,+ conversionErrorType = Just (typeRep (undefined :: a)),+ conversionErrorMsg = msg+ }+--}++{--+defaultValue :: Typeable a => a -> ValueParser a -> ValueParser a+defaultValue def m =+ ValueParser $ \vs ->+ case vs of+ (Nothing:vs') -> (Just def, mempty, vs')+ _+--}
+ Data/Configurator/FromValue/Internal.hs view
@@ -0,0 +1,15 @@+-- |+-- Module: Data.Configurator.FromValue.Internal+-- Copyright: (c) 2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>++module Data.Configurator.FromValue.Internal+ ( ConversionErrors+ , ValueParser(..)+ , MaybeParser(..)+ , ListParserResult(..)+ , ListParser(..)+ ) where++import Data.Configurator.FromValue.Implementation
+ Data/Configurator/Parser.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections #-}++-- |+-- Module: Data.Configurator.Parser+-- Copyright: (c) 2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- A set of combinators for high-level configuration parsing.++module Data.Configurator.Parser+ ( ConfigParser+ , ConfigParserA+ , ConfigParserM+ , ConfigError (..)+ , ConfigErrorLocation (..)+ , ConversionError (..)+ , ConversionErrorWhy (..)+ , Config+ , ConfigTransform+ , unsafeBind+ , runParser+ , runParserA+ , runParserM+ , parserA+ , parserM+ , subassocs+ , subassocs'+ , subgroups+ , localConfig+ , union+ , subconfig+ , superconfig+ , recover+ , key+ , keyWith+ ) where++import Prelude hiding (null)++import Data.DList (DList)+import qualified Data.DList as DL++#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid(Monoid(..))+#endif+import Data.Monoid((<>))+import Data.Configurator.Config+ ( Config )+import Data.Configurator.Types.Internal hiding (Group)+import Data.Configurator.FromValue+ ( FromMaybeValue(fromMaybeValue)+ , MaybeParser+ , runMaybeParser+ )+import qualified Data.Configurator.Config as C+import qualified Data.Configurator.Config.Internal as CI+import Data.Configurator.Parser.Implementation++runParser :: ConfigParser m => m a -> Config -> (Maybe a, [ConfigError])+runParser m conf = let (ma, errs) = unConfigParser_ m conf+ in (ma, toErrors errs)++{- | Returns all the value bindings from the current configuration context+-- that is contained within the given subgroup, in lexicographic order.+-- For example, given the following context:++@+x = 1+foo {+ x = 2+ bar {+ y = on+ }+}+foo = \"Hello\"+@++Then the following arguments to 'subassocs' would return the following lists:++@+subassocs "" ==> [("foo",String \"Hello\"),("x",Number 1)]+subassocs "foo" ==> [("foo.x",Number 2)]+subassocs "foo.bar" ==> [("foo.bar.x",Bool True)]+@++All other arguments to subassocs would return [] in the given context.+-}+++subassocs :: ConfigParser m => Name -> m [(Name, Value)]+subassocs t = configParser_ (\c -> (Just (C.subassocs t c), mempty))++{- | Returns all the value bindings from the current configuration context+-- that is contained within the given subgroup and all of it's subgroups+-- in lexicographic order. For example, given the following context:++@+x = 1+foo {+ x = 2+ bar {+ y = on+ }+}+foo = \"Hello\"+@++Then the following arguments to 'subassocs\'' would return the following lists:++@+subassocs\' "" ==> [ ("foo" , String \"Hello\")+ , ("foo.bar.y" , Bool True )+ , ("foo.x" , Number 2 )+ , ("x" , Number 1 )+ ]+subassocs\' "foo" ==> [ ("foo.bar.y" , Bool True )+ , ("foo.x" , Number 2 )+ ]+subassocs\' "foo.bar" ==> [ ("foo.bar.y" , Bool True )+ ]+@++All other arguments to @subassocs\'@ would return @[]@ in the given context.+-}++subassocs' :: ConfigParser m => Name -> m [(Name, Value)]+subassocs' t = configParser_ (\c -> (Just (C.subassocs' t c), mempty))++{- | Returns all the non-empty value groupings that is directly under+-- the argument grouping in the current configuration context.+-- For example, given the following context:++@+foo { }+bar {+ a {+ x = 1+ }+ b {+ c {+ y = 2+ }+ }+}+default+ a {+ x = 3+ }+}+@++Then the following arguments to 'subgroups' would return the following lists:++@+subgroups "" ==> [ "bar", "default" ]+subgroups "bar" ==> [ "bar.a", "bar.b" ]+subgroups "bar.b" ==> [ "bar.b.c" ]+subgroups "default" ==> [ "default.a" ]+@++All other arguments to @subgroups@ would return @[]@ in the given context.+-}++subgroups :: ConfigParser m => Name -> m [Name]+subgroups t = configParser_ (\c -> (Just (C.subgroups t c), mempty))++-- | Modifies the 'Config' that a subparser is operating on.+-- This is perfectly analogous to 'Control.Monad.Reader.local'.++localConfig :: ConfigParser m => ConfigTransform -> m a -> m a+localConfig f m = configParser_ (\r -> unConfigParser_ m (interpConfigTransform f r))++-- | Exactly the same as 'runParser', except less polymorphic++runParserA :: ConfigParserA a -> Config -> (Maybe a, [ConfigError])+runParserA = runParser++-- | Exactly the same as 'runParser', except less polymorphic++runParserM :: ConfigParserM a -> Config -> (Maybe a, [ConfigError])+runParserM = runParser++-- | Lift a 'ConfigParserM' action into a generic 'ConfigParser'+-- action. Note that this does not change the semantics of the+-- argument, it just allows a 'ConfigParserM' computation to be+-- embedded in another 'ConfigParser' computation of either variant.++parserM :: ConfigParser m => ConfigParserM a -> m a+parserM (ConfigParserM m) = configParser_ m++-- | Lift a 'ConfigParserA' action into a generic 'ConfigParser'+-- action. Note that this does not change the semantics of the+-- argument, it just allows a 'ConfigParserA' computation to be+-- embedded in another 'ConfigParser' computation of either variant.++parserA :: ConfigParser m => ConfigParserA a -> m a+parserA (ConfigParserA m) = configParser_ m++-- | Given the expression @'recover' action@, the @action@ will be+-- run, and if it returns no value, @recover action@ will return+-- 'Nothing'. If @action@ returns the value @a@, then+-- @recover action@ will return the value @'Just' a@. Any errors+-- or warnings are passed through as-is.++recover :: ConfigParser m => m a -> m (Maybe a)+recover m = configParser_ $ \r -> let (ma, errs) = unConfigParser_ m r+ in (Just ma, errs)++-- Look up a given value in the current configuration context, and convert+-- the value using the 'fromMaybeValue' method.++key :: (ConfigParser m, FromMaybeValue a) => Name -> m a+key name = keyWith name fromMaybeValue++-- Look up a given value in the current configuration context, and convert+-- the value using the 'MaybeParser' argument.++keyWith :: (ConfigParser m) => Name -> MaybeParser a -> m a+keyWith name parser =+ configParser_ $ \(CI.Config c) ->+ case CI.lookupWithName name c of+ Nothing ->+ convert (KeyMissing (DL.toList (getLookupPlan name c))) Nothing+ Just (name', v) ->+ convert (Key "" name') (Just v)+ where+ convert loc mv =+ case runMaybeParser parser mv of+ (Nothing, errs) ->+ (Nothing, singleError (ConfigError loc (Just errs)))+ (Just a, []) ->+ (Just a, mempty)+ (Just a, errs@(_:_)) ->+ (Just a, singleError (ConfigError loc (Just errs)))++getLookupPlan :: Name -> CI.ConfigPlan a -> DList Name+getLookupPlan = CI.foldPlan DL.empty (<>) (\k _ -> DL.singleton k)
+ Data/Configurator/Parser/Implementation.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}++-- |+-- Module: Data.Configurator.Parser.Implementation+-- Copyright: (c) 2015-2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>++module Data.Configurator.Parser.Implementation where++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative+#endif+import Control.Monad (ap)+import Data.Configurator.Config (Config)+import qualified Data.Configurator.Config as C+import Data.Configurator.Config.Implementation (ConfigPlan(..))+import Data.Configurator.Types (ConfigError)+import Data.DList (DList)+import Data.Monoid+import Data.Text (Text)+import Data.Typeable (Typeable)++type RMW r w a = r -> (Maybe a, w)++type ConfigErrors = Maybe (DList ConfigError)++-- | A @'ConfigParserM' a@ computation produces a value of type @'Maybe' a@+-- from a given 'Config', in addition to a list of diagnostic messages+-- which may be interpreted as warnings or errors as deemed appropriate.+-- If the value returned by a computation is 'Nothing', then no subsequent+-- actions (e.g. via @\<*\>@ or @>>=@) will be performed.++newtype ConfigParserM a+ = ConfigParserM { unConfigParserM :: RMW Config ConfigErrors a }+ deriving (Typeable, Functor)++instance Applicative ConfigParserM where+ pure a = ConfigParserM $ \_ -> (pure a, mempty)+ (<*>) = ap++instance Monad ConfigParserM where+#if !(MIN_VERSION_base(4,8,0))+ return = pure+#endif+ m >>= k = ConfigParserM $ \r ->+ let (ma, w ) = unConfigParserM m r+ in case ma of+ Nothing -> (Nothing, w)+ Just a -> let (mb, w') = unConfigParserM (k a) r+ in (mb, w <> w')++-- | A @'ConfigParserM' a@ computation produces a value of type @'Maybe' a@+-- from a given 'Config', in addition to a list of diagnostic messages.+-- After executing a subcomputation that returns a 'Nothing' value,+-- computations of type 'ConfigParserA' will continue to run in order to+-- produce more error messages. For this reason, 'ConfigParserA' does+-- not have a proper 'Monad' instance. (But see 'unsafeBind')++newtype ConfigParserA a+ = ConfigParserA { unConfigParserA :: RMW Config ConfigErrors a }+ deriving (Typeable, Functor)++instance Applicative ConfigParserA where+ pure a = ConfigParserA $ \_ -> (pure a, mempty)+ f <*> a = ConfigParserA $ \r ->+ let (mf, w ) = unConfigParserA f r+ (ma, w') = unConfigParserA a r+ in (mf <*> ma, w <> w')++#if __GLASGOW_HASKELL__ >= 800+{-# DEPRECATED unsafeBind "Use the ApplicativeDo language extension instead" #-}+#endif++-- | The purpose of this function is to make it convenient to use do-notation+-- with 'ConfigParserA', either by defining a Monad instance or locally+-- rebinding '(>>=)'. Be warned that this is an abuse, and incorrect+-- usage can result in exceptions. A safe way to use this function+-- would be to treat is as applicative-do notation. A safer alternative+-- would be to use the @ApplicativeDo@ language extension available in+-- GHC 8.0 and not use this function at all.++unsafeBind :: ConfigParserA a -> (a -> ConfigParserA b) -> ConfigParserA b+unsafeBind m k = ConfigParserA $ \r ->+ case unConfigParserA m r of+ (Nothing, w) -> let (_, w') = unConfigParserA (k err) r+ in (Nothing, w <> w')+ (Just a, w) -> let (mb, w') = unConfigParserA (k a) r+ in (mb, w <> w')+ where err = error "unsafeBind on ConfigParserA used incorrectly"+++{--+--- There are at least three obvious "implementations" of <|> on ConfigParserM+--- TODO: check alternative laws and pick an appropriate instance for each++instance Alternative ConfigParserM where+ empty = ConfigParserM $ \_ -> (Nothing, mempty)+ f <|> g = ConfigParserM $ \r ->+ case unConfigParserM m0 r of+ (Nothing, _errs0) -> unConfigParserM m1 r+ res -> res++instance Alternative ConfigParserA where+ empty = ConfigParserA $ \_ -> (Nothing, mempty)+ f <|> g = ConfigParserA $ \r -> let (mf, w ) = unConfigParserA f r+ (mg, w') = unConfigParserA g r+ in (mf <|> mg, w <> w')+++instance Alternative ConfigParserA where+ empty = ConfigParserA $ \_ -> (Nothing, mempty)+ f <|> g = ConfigParserA $ \r -> let (mf, w ) = unConfigParserA f r+ (mg, w') = unConfigParserA g r+ in case mf of+ (Just f) -> (mf, w)+ Nothing -> (mg, w <> w')++--}++-- | The 'ConfigParser' type class abstracts over 'ConfigParserM' and+-- 'ConfigParserA'. This is intended to be a closed typeclass, without+-- any additional instances.++class Applicative m => ConfigParser m where+ configParser_ :: RMW Config ConfigErrors a -> m a+ unConfigParser_ :: m a -> RMW Config ConfigErrors a++{--+--- Unfortunately, this doesn't work (yet?) because of MonadReader's+--- Monad superclass.++instance ConfigParser m => MonadReader m where+ ask = configParser_ $ \c -> (Just c, mempty)+++Data.Configurator.Parser.Internal++--}++instance ConfigParser ConfigParserM where+ configParser_ = ConfigParserM+ unConfigParser_ = unConfigParserM++instance ConfigParser ConfigParserA where+ configParser_ = ConfigParserA+ unConfigParser_ = unConfigParserA++-- | Conceptually, a 'ConfigTransform' is a function 'Config' @->@ 'Config'.+-- It's a restricted subset of such functions as to preserve the possibility+-- of reliable dependency tracking in later versions of configurator-ng.+newtype ConfigTransform = ConfigTransform (ConfigPlan ())++-- | 'mempty' is the identity 'ConfigTransform', 'mappend' is the composition+-- of two 'ConfigTransform's.+instance Monoid ConfigTransform where+ mempty = ConfigTransform (ConfigPlan ())+ (ConfigTransform x) `mappend` (ConfigTransform y) = (ConfigTransform (go x))+ where+ go (ConfigPlan _) = y+ go (Union a b) = Union (go a) (go b)+ go (Superconfig pre a) = Superconfig pre (go a)+ go (Subconfig pre a) = Subconfig pre (go a)+ go Empty = Empty++-- Conceptually, @'union' f g = \config -> union\' (f config) (g config)@,+-- where @union\'@ is the left-biased union of two 'Config's.+union :: ConfigTransform -> ConfigTransform -> ConfigTransform+union (ConfigTransform x) (ConfigTransform y) = ConfigTransform (Union x y)++-- @'subconfig' group@ restricts the configuration to those values that+-- are contained within @group@ (either directly, or contained within a+-- descendant value grouping), and removes the @group@ prefix from all+-- of the keys in the map. It's analogous to the @cd@ (change directory)+-- command on common operating systems, except that @subconfig@ can only+-- descend down the directory tree, and cannot ascend into a parent+-- directory.+subconfig :: Text -> ConfigTransform -> ConfigTransform+subconfig k (ConfigTransform x) = ConfigTransform (Subconfig k x)++-- @'superconfig' group@ adds the @group@ prefix to all keys in the map.+-- It is vaguely analogous to the @mount@ command on unix operating systems.+superconfig :: Text -> ConfigTransform -> ConfigTransform+superconfig k (ConfigTransform x) = ConfigTransform (Superconfig k x)++interpConfigTransform :: ConfigTransform -> Config -> Config+interpConfigTransform (ConfigTransform x) config = go x+ where+ go Empty = C.empty+ go (ConfigPlan _) = config+ go (Superconfig k x) = C.superconfig k (go x)+ go (Subconfig k x) = C.subconfig k (go x)+ go (Union x y) = C.union (go x) (go y)
+ Data/Configurator/Parser/Internal.hs view
@@ -0,0 +1,17 @@+-- |+-- Module: Data.Configurator.Parser.Internal+-- Copyright: (c) 2015-2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+++module Data.Configurator.Parser.Internal + ( RMW+ , ConfigParser (..)+ , ConfigParserM (..)+ , ConfigParserA (..)+ , ConfigTransform(..)+ , interpConfigTransform+ ) where++import Data.Configurator.Parser.Implementation
+ Data/Configurator/Syntax.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Data.Configurator.Syntax+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2015-2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- A parser for configuration files.++module Data.Configurator.Syntax+ (+ topLevel+ , interp+ ) where++import Control.Applicative+import Control.Exception (throw)+import Control.Monad (when)+import Data.Attoparsec.Text as A+import Data.Bits (shiftL)+import Data.Char (chr, isAlpha, isAlphaNum, isSpace)+import Data.Configurator.Types.Internal+import Data.Monoid (Monoid(..))+import Data.Text (Text)+import Data.Text.Lazy.Builder (fromText, singleton, toLazyText)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L++topLevel :: Parser [Directive]+topLevel = directives <* skipLWS <* endOfInput++directive :: Parser Directive+directive =+ mconcat [+ string "import" *> skipLWS *> (Import <$> string_)+ , string "#;" *> skipHWS *> (DirectiveComment <$> directive)+ , Bind <$> try (ident <* skipLWS <* char '=' <* skipLWS) <*> value+ , Group <$> try (ident <* skipLWS <* char '{' <* skipLWS)+ <*> directives <* skipLWS <* char '}'+ ]++directives :: Parser [Directive]+directives = (skipLWS *> directive <* skipHWS) `sepBy`+ (satisfy $ \c -> c == '\r' || c == '\n')++data Skip = Space | Comment++-- | Skip lines, comments, or horizontal white space.+skipLWS :: Parser ()+skipLWS = loop+ where+ loop = A.takeWhile isSpace >> ((comment >> loop) <|> return ())++ comment = try beginComment >> A.takeWhile (\c -> c /= '\r' && c /= '\n')++ beginComment = do+ _ <- A.char '#'+ mc <- peekChar+ case mc of+ Just ';' -> fail ""+ _ -> return ()++-- | Skip comments or horizontal white space.+skipHWS :: Parser ()+skipHWS = scan Space go *> pure ()+ where go Space ' ' = Just Space+ go Space '\t' = Just Space+ go Space '#' = Just Comment+ go Space _ = Nothing+ go Comment '\r' = Nothing+ go Comment '\n' = Nothing+ go Comment _ = Just Comment++data IdentState = First | Follow++ident :: Parser Name+ident = do+ n <- scan First go+ when (n == "import") $+ throw (ParseError "" $ "reserved word (" ++ show n ++ ") used as identifier")+ when (T.null n) $ fail "no identifier found"+ when (T.last n == '.') $ fail "identifier must not end with a dot"+ return n+ where+ go First c =+ if isAlpha c+ then Just Follow+ else Nothing+ go Follow c =+ if isAlphaNum c || c == '_' || c == '-'+ then Just Follow+ else if c == '.'+ then Just First+ else Nothing++value :: Parser Value+value = mconcat [+ string "on" *> pure (Bool True)+ , string "off" *> pure (Bool False)+ , string "true" *> pure (Bool True)+ , string "false" *> pure (Bool False)+ , String <$> string_+ , Number <$> scientific+ , List <$> brackets '[' ']'+ ((value <* skipLWS) `sepBy` (char ',' <* skipLWS))+ ]++string_ :: Parser Text+string_ = do+ s <- char '"' *> scan False isChar <* char '"'+ if "\\" `T.isInfixOf` s+ then unescape s+ else return s+ where+ isChar True _ = Just False+ isChar _ '"' = Nothing+ isChar _ c = Just (c == '\\')++brackets :: Char -> Char -> Parser a -> Parser a+brackets open close p = char open *> skipLWS *> p <* char close++embed :: Parser a -> Text -> Parser a+embed p s = case parseOnly p s of+ Left err -> fail err+ Right v -> return v++unescape :: Text -> Parser Text+unescape = fmap (L.toStrict . toLazyText) . embed (p mempty)+ where+ p acc = do+ h <- A.takeWhile (/='\\')+ let rest = do+ let cont c = p (acc `mappend` fromText h `mappend` singleton c)+ c <- char '\\' *> satisfy (inClass "ntru\"\\")+ case c of+ 'n' -> cont '\n'+ 't' -> cont '\t'+ 'r' -> cont '\r'+ '"' -> cont '"'+ '\\' -> cont '\\'+ _ -> cont =<< hexQuad+ done <- atEnd+ if done+ then return (acc `mappend` fromText h)+ else rest++hexQuad :: Parser Char+hexQuad = do+ a <- embed hexadecimal =<< A.take 4+ if a < 0xd800 || a > 0xdfff+ then return (chr a)+ else do+ b <- embed hexadecimal =<< string "\\u" *> A.take 4+ if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff+ then return $! chr (((a - 0xd800) `shiftL` 10) + (b - 0xdc00) + 0x10000)+ else fail "invalid UTF-16 surrogates"++-- | Parse a string interpolation spec.+--+-- The sequence @$$@ is treated as a single @$@ character. The+-- sequence @$(@ begins a section to be interpolated, and @)@ ends it.+interp :: Parser [Interpolate]+interp = reverse <$> p []+ where+ p acc = do+ h <- Literal <$> A.takeWhile (/='$')+ let rest = do+ let cont x = p (x : h : acc)+ c <- char '$' *> satisfy (\c -> c == '$' || c == '(')+ case c of+ '$' -> cont (Literal (T.singleton '$'))+ _ -> (cont . Interpolate) =<< A.takeWhile1 (/=')') <* char ')'+ done <- atEnd+ if done+ then return (h : acc)+ else rest
+ Data/Configurator/Types.hs view
@@ -0,0 +1,32 @@+-- |+-- Module: Data.Configurator.Types+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2015-2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- Types for working with configuration files.++module Data.Configurator.Types+ (+ AutoConfig(..)+ , ConfigCache+ , Name+ , Value(..)+ , Worth(..)+ -- * Exceptions+ , ParseError(..)+ , ConfigError(..)+ , ConfigErrorLocation(..)+ , ConversionError(..)+ , ConversionErrorWhy(..)+ , defaultConversionError+ , KeyError(..)+ -- * Notification of configuration changes+ , Pattern+ , ChangeHandler+ ) where++import Data.Configurator.Types.Internal
+ Data/Configurator/Types/Internal.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings #-}++-- |+-- Module: Data.Configurator.Types.Internal+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2015-2016 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- Types for working with configuration files.++module Data.Configurator.Types.Internal+ (+ ConfigCache(..)+ , AutoConfig(..)+ , Worth(..)+ , Name+ , Value(..)+ , Binding+ , Path+ , Directive(..)+ , ParseError(..)+ , ConfigError(..)+ , ConfigErrorLocation(..)+ , ConversionError(..)+ , ConversionErrorWhy(..)+ , defaultConversionError+ , MultiErrors+ , singleError+ , toErrors+ , KeyError(..)+ , Interpolate(..)+ , Pattern(..)+ , exact+ , prefix+ , ChangeHandler+ ) where++import Control.Exception+import Data.Data (Data)+import Data.DList (DList)+import qualified Data.DList as DList+import Data.Hashable (Hashable(..))+import Data.IORef (IORef)+import Data.List (isSuffixOf)+import Data.String (IsString(..))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (Typeable, TypeRep)+import Data.Scientific(Scientific)+import Prelude hiding (lookup)+import qualified Data.HashMap.Lazy as H+import qualified Data.CritBit.Map.Lazy as CB++data Worth a = Required { worth :: a }+ | Optional { worth :: a }+ deriving (Show, Typeable)++instance IsString (Worth FilePath) where+ fromString = Required++instance (Eq a) => Eq (Worth a) where+ a == b = worth a == worth b++instance (Hashable a) => Hashable (Worth a) where+ hashWithSalt salt v = hashWithSalt salt (worth v)++-- | Global configuration data. This is the top-level config from which+-- 'Config' values are derived by choosing a root location.+data ConfigCache = ConfigCache {+ cfgAuto :: Maybe AutoConfig+ , cfgPaths :: IORef [(Name, Worth Path)]+ -- ^ The files from which the 'Config' was loaded.+ , cfgMap :: IORef (CB.CritBit Name Value)+ , cfgSubs :: IORef (H.HashMap Pattern [ChangeHandler])+ }++instance Functor Worth where+ fmap f (Required a) = Required (f a)+ fmap f (Optional a) = Optional (f a)++-- | An action to be invoked if a configuration property is changed.+--+-- If this action is invoked and throws an exception, the 'onError'+-- function will be called.+type ChangeHandler = Name+ -- ^ Name of the changed property.+ -> Maybe Value+ -- ^ Its new value, or 'Nothing' if it has+ -- vanished.+ -> IO ()++-- | A pattern specifying the name of a property that has changed.+--+-- This type is an instance of the 'IsString' class. If you use the+-- @OverloadedStrings@ language extension and want to write a+-- 'prefix'-matching pattern as a literal string, do so by suffixing+-- it with \"@.*@\", for example as follows:+--+-- > "foo.*"+--+-- If a pattern written as a literal string does not end with+-- \"@.*@\", it is assumed to be 'exact'.+data Pattern = Exact Name+ -- ^ An exact match.+ | Prefix Name+ -- ^ A prefix match. Given @'Prefix' \"foo\"@, this will+ -- match @\"foo.bar\"@, but not @\"foo\"@ or+ -- @\"foobar\"@.+ deriving (Eq, Show, Typeable, Data)++-- | A pattern that must match exactly.+exact :: Text -> Pattern+exact = Exact++-- | A pattern that matches on a prefix of a property name. Given+-- @\"foo\"@, this will match @\"foo.bar\"@, but not @\"foo\"@ or+-- @\"foobar\"@.+prefix :: Text -> Pattern+prefix p = Prefix (p `T.snoc` '.')++instance IsString Pattern where+ fromString s+ | ".*" `isSuffixOf` s = Prefix . T.init . T.pack $ s+ | otherwise = Exact (T.pack s)++instance Hashable Pattern where+ hashWithSalt salt (Exact n) = hashWithSalt salt n+ hashWithSalt salt (Prefix n) = hashWithSalt salt n++-- | An error occurred during the low-level parsing of a configuration file.+data ParseError = ParseError FilePath String+ deriving (Show, Typeable)++instance Exception ParseError++-- | An error (or warning) from a higher-level parser of a configuration file.+data ConfigError = ConfigError {+ configErrorLocation :: ConfigErrorLocation+ , configConversionError :: Maybe [ConversionError]+ } deriving (Eq, Show, Typeable)++instance Exception ConfigError++data ConfigErrorLocation+ = KeyMissing [Name]+ | Key FilePath Name+ deriving (Eq, Show, Typeable)++data ConversionError = ConversionError {+ conversionErrorLoc :: Text,+ conversionErrorWhy :: ConversionErrorWhy,+ conversionErrorVal :: !(Maybe Value),+ conversionErrorType :: !(Maybe TypeRep),+ conversionErrorMsg :: !(Maybe Text)+ } deriving (Eq, Show, Typeable)++instance Exception ConversionError++data ConversionErrorWhy =+ MissingValue+ | ExtraValues+ | ExhaustedValues+ | TypeError+ | ValueError+ | MonadFail+ | OtherError+ deriving (Eq, Typeable, Show)++defaultConversionError :: ConversionError+defaultConversionError =+ ConversionError "" OtherError Nothing Nothing Nothing++type MultiErrors a = Maybe (DList a)++singleError :: a -> MultiErrors a+singleError = Just . DList.singleton++toErrors :: MultiErrors a -> [a]+toErrors = maybe [] DList.toList++-- | An error occurred while lookup up the given 'Name'.+data KeyError = KeyError Name+ deriving (Show, Typeable)++instance Exception KeyError++-- | Directions for automatically reloading 'Config' data.+data AutoConfig = AutoConfig {+ interval :: Int+ -- ^ Interval (in seconds) at which to check for updates to config+ -- files. The smallest allowed interval is one second.+ , onError :: SomeException -> IO ()+ -- ^ Action invoked when an attempt to reload a 'Config' or notify+ -- a 'ChangeHandler' causes an exception to be thrown.+ --+ -- If this action rethrows its exception or throws a new+ -- exception, the modification checking thread will be killed.+ -- You may want your application to treat that as a fatal error,+ -- as its configuration may no longer be consistent.+ } deriving (Typeable)++instance Show AutoConfig where+ show c = "AutoConfig {interval = " ++ show (interval c) ++ "}"++-- | The name of a 'Config' value.+type Name = Text++-- | A packed 'FilePath'.+type Path = Text++-- | A name-value binding.+type Binding = (Name,Value)++-- | A directive in a configuration file.+data Directive = Import Path+ | Bind Name Value+ | Group Name [Directive]+ | DirectiveComment Directive+ deriving (Eq, Show, Typeable, Data)++-- | A value in a 'Config'.+data Value = Bool Bool+ -- ^ A Boolean. Represented in a configuration file as @on@+ -- or @off@, @true@ or @false@ (case sensitive).+ | String Text+ -- ^ A Unicode string. Represented in a configuration file+ -- as text surrounded by double quotes.+ --+ -- Escape sequences:+ --+ -- * @\\n@ - newline+ --+ -- * @\\r@ - carriage return+ --+ -- * @\\t@ - horizontal tab+ --+ -- * @\\\\@ - backslash+ --+ -- * @\\\"@ - quotes+ --+ -- * @\\u@/xxxx/ - Unicode character, encoded as four+ -- hexadecimal digits+ --+ -- * @\\u@/xxxx/@\\u@/xxxx/ - Unicode character (as two+ -- UTF-16 surrogates)+ | Number Scientific+ -- ^ Integer.+ | List [Value]+ -- ^ Heterogeneous list. Represented in a configuration+ -- file as an opening square bracket \"@[@\", followed by a+ -- comma-separated series of values, ending with a closing+ -- square bracket \"@]@\".+ deriving (Eq, Show, Typeable, Data)++-- | An interpolation directive.+data Interpolate = Literal Text+ | Interpolate Text+ deriving (Eq, Show)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2011, MailRank, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,359 @@+# [configurator-ng](https://github.com/lpsmith/configurator-ng)+##What is this?++This is a massively breaking revision of the application interface of+[configurator]. The configuration file syntax is backward compatible,+and mostly forward compatible as well. This fork is not (yet?) intended+for widespread public consumption. Rather, this repo is being used as+a stopgap measure in some of my own projects as well as a playground+and laboratory for a new configurator-like package that may be+released sometime in the future.++## Manifesto++(Note that this section is mildly aspirational at a few points,+ and/or contains errors.)++The application interface of `configurator` has numerous problems:+ * it makes it easy to introduce race conditions+ * it makes it difficult to write an application that is relatively+ robust to misconfiguration errors+ * does not scale well to moderately complex configuration scenarios+ * the configuration change notifications are particularly difficult+ to use beyond the most trivial of use cases.++The aim of `configurator-ng` is to improve these issues, with the+initial efforts focused on the first three. I hope to make more+correct solutions easier, and less correct solutions harder, all+wrapped up in a more expressive interface.++### Race conditions++The interface of `configurator` basically is:++ data Config = Config (IORef (HashMap Text Value))++ lookup :: Configured a => Config -> Text -> IO (Maybe a)++The `IORef` is there to support configuration file reloading, which+is often done automatically. So this results in the race condition:++ do+ key0 <- lookup config "key0"+ reload config {- in another thread -}+ key1 <- lookup config "key1"+ return (key0, key1)++Thus, we have taken `key0` and `key1` from two versions of the+configuration files, with a overall result that is not necessarily+consistent with either version.++There is a way to solve this race condition\*, though it is by no+means convenient and it provides even less support for turning the+result into configuration parameters:++ getMap :: Config -> IO (HashMap Text Value)++This obtains a consistent\* snapshot of the configuration, from which+you can pull out multiple values. But in addition to being+less obvious and inconvenient, the fact that the `HashMap` returned+is not an abstract type makes means that changing the representation+breaks client code that uses this approach.++`configurator-ng` makes the latter mode of use much more convenient by+introducing `ConfigParser`s, a applicative/monadic high-level parsing+interface to read configuration info from a single snapshot. See the+module `Data.Configurator.Parser`. The basic ideas behind the revised+interface is as follows:++ data ConfigCache = ConfigCache (IORef Config)++ readConfig :: ConfigCache -> IO Config++ runParser :: ConfigParser m => m a -> Config -> (Maybe a, [ConfigError])++(Here, `ConfigError` could be an error condition, or it might be more+analogous to a warning or informational message; thus a parser can+return a result *and* some `ConfigError`s.)++Finally, we could define a `ConfigParser` to read from key1 and key2+by writing:++ getKeys :: ConfigParser m => m (Text, Int)+ getKeys = (,) <$> key "key0" <*> key "key1"++(\*It's important to point out that `getMap` only avoids introducing+additional race conditions; commonly used filesystems are racey+software artifacts, so this is only consistent relative to filesystem+reads. For a complete solution, one would have to take care in the+precise filesystem calls used to manipulate the configuration file(s).+Most popular text editors should be ok as far as the consistency of a+single file, consistent reads of multiple files is trickier.)++### Configuration validation++Another advantage of the `ConfigParser` interface is that it makes it+easier and more convenient to validate a (sub-)configuration as an+entirety, and thus also make more intelligent decisions about to do+in cases of misconfigurations. For example, one might want to continue+running on the last known good configuration, and raise a big red+flag in a monitoring solution. The goal is to provide mechanism,+not policy.++### Greater Expressive Power++Consider the following use case: you have an event processor, that+watches several named sources for events. You might like your+configuration file to look something like this:++~~~+event-sources {+ amazon-cloud {+ postgres {+ host = "cloudevents.mydomain.com"+ port = 5433+ dbname = "eventdb"+ sslmode = "verify-full"+ sslcert = "${HOME}/credentials/pgclient.crt"+ sslkey = "${HOME}/credentials/pgclient.key"+ }+ heartbeat-interval = 15+ heartbeat-timeout = 15+ }+ chicago-service-center {+ postgres {+ host = "pgevents.customerdomain.com"+ port = 5433+ dbname = "eventdb"+ sslmode = "verify-full"+ sslcert = "${HOME}/credentials/pgclient.crt"+ sslkey = "${HOME}/credentials/pgclient.key"+ }+ heartbeat-interval = 15+ heartbeat-timeout = 15+ }+}+~~~++Now, `amazon-cloud` and `chicago-service-center` are names of the source+useful for whatever purposes (logging, API endpoints, etc), that the+event processor doesn't know about in advance. Since `configurator`+is tied down to `HashMap`, the data structure offers no support for+efficiently discovering these names. In order to fix this,+`configurator-ng` moved to [`critbit`][critbit]. which allows us to+efficiently iterate over these keys (in alphabetical order). So+`configurator-ng` offers the following operator:++ subgroups :: ConfigParser m => Text -> m [Text]++`subgroups` returns the non-empty value groupings of it's argument,+so for example when evaluated in the context of the configuration above:++ subgroups "" ==> [ "event-sources" ]++ subgroups "event-sources" ==> [ "event-sources.amazon-cloud"+ , "event-sources.chicago-service-center" ]++Another issue is that there's a lot of redundancy here, so maybe we'd like to+refactor the configuration file into something like this:++~~~+event-sources {+ amazon-cloud {+ postgres.host = "cloudevents.mydomain.com"+ }+ chicago-service-center {+ postgres.host = "pgevents.customerdomain.com"+ }+ default {+ postgres {+ port = 5433+ dbname = "eventdb"+ sslmode = "verify-full"+ sslcert = "${HOME}/credentials/pgclient.crt"+ sslkey = "${HOME}/credentials/pgclient.key"+ }+ heartbeat-interval = 15+ heartbeat-timeout = 15+ }+}+~~~++So now the problem is that we want to turn this configuration into a+list of `EventSource`s:++~~~+data EventSource = EventSource {+ name :: !Text,+ libpqConnParams :: [(Text,Value)],+ heartbeatInterval :: !Micro,+ heartbeatTimeout :: !Micro,+ }+~~~++Now, even ignoring the issue of the names mentioned above, handling+this sort of customizable defaulting in `configurator` would be rather+painful. But it's actually quite easy with `configurator-ng`:++~~~+{-# LANGUAGE ApplicativeDo, RecordWildCards #-}++mapA :: Applicative f => (a -> f b) -> [a] -> f [b]+mapA f = foldr (liftA2 (:)) (pure []) . map f++eventSources :: ConfigParserA [EventSource]+eventSources = do+ localConfig (subconfig "event-sources") $ do+ mapA eventSource . filter (/= "default") <$> subgroups ""++eventSource :: Text -> ConfigParserA EventSource+eventSource name = do+ localConfig (union (subconfig name )+ (subconfig "default")) $ do+ libpqConnParams <- localConfig (subconfig "postgres") (subassocs "")+ heartbeatInterval <- key "heartbeat-interval"+ heartbeatTimeout <- key "heartbeat-timeout"+ pure $! EventSource{..}+~~~++This example uses the `ConfigParserA` variant of `ConfigParser`, so+that the parser continues to run after encountering an error in order+to generate more error messages. It also uses `localConfig` operator+to run a subparser in a different configuration context. There are+a few operators for modifying the configuration context:++~~~+localConfig :: ConfigParser m => ConfigTransform -> m a -> m a++data ConfigTransform -- Conceptually, type ConfigTransform = Config -> Config++instance Monoid ConfigTransform+ -- mempty is identity transformation+ -- mappend is composition of transformations++-- | Left-biased union of two configurations+union :: ConfigTransform -> ConfigTransform -> ConfigTransform++-- | Restrict a configuration to a given group, and remove that group+-- prefix from all key names.+subconfig :: Text -> ConfigTransform++-- | Add a group name as a prefix to all key names+superconfig :: Text -> ConfigTransform+~~~++Note that these operators are implemented "symbolically", so that+they run in sub-linear (Possibly `O(1)`?) time. Instead, the cost of+these are paid on each `(key,value)` lookup.++### Syntactic extensions++Datum comments have been implemented, not unlike Scheme and Clojure.+The `configurator-ng` parser will ignore any binding preceded by a `#;`+token; the binding following `#;` must be begin on the same line, and+must be syntactically correct, but will otherwise be ignored.++This is a significant convenience for use cases like the event source+example above: for example one could disable `chicago-service-center`+by putting `#;` before the name. One can also use this as a slightly+restricted means of block comments, by writing `#; comment {` (the+name doesn't matter) to begin the block comment, and a matching `}`+to end the comment. Of course, the intervening bindings must be+syntactically correct, so this isn't an exact substitute for block+comments.++Also, `configurator-ng` also allows group names to be inlined into other+group and key names, separated by a dot character. For example, these+configuration snippets are all equivalent:++~~~+foo {+ bar {+ x = "Hello"+ y = "World"+ }+}+++foo.bar {+ x = "Hello"+ y = "World"+}+++foo {+ bar.x = "Hello"+ bar.y = "World"+}+++foo.bar.x = "Hello"+foo.bar.y = "World"+~~~~++With the original `configurator`, only the first snippet is+syntactically legal.++Finally, `configurator-ng` supports scientific notation for numerical+values, via the+[`scientific`](https://hackage.haskell.org/package/scientific)+package, which corresponds closely to typical floating point syntax.++### Configuration Change Subscriptions++`Configurator`'s change notification system is also painful to+use except in the most trivial of cases, not least because+the callback is called for a single changed `(key,value)` pair at a+time. Determining how that impacts a given configuration record (like+`EventSource` above) is up to the user.++Soon, configurator-ng will offer something along the lines of the+following function:++~~~+subscribe :: ConfigParser m => ConfigCache -> m a -> (a -> IO ()) -> IO ()+~~~++When the configuration files are reloaded, every subscribed+`ConfigParser` is rerun, and the result is passed on to the+callback. Now, of course, many callbacks won't want to be called+unless their configuration actually changes. However, this is+actually a reasonable thing to punt to the callback, because+we can write a generic callback wrapper to handle this issue:++~~~+debounce :: (a -> a -> Bool) -> (a -> IO ()) -> IO (a -> IO ())+debounce notEq callback = do+ last_seen <- newIORef Nothing+ return $ \new -> do+ m_old <- readIORef last_seen+ if case m_old of+ Nothing -> True+ Just old -> notEq old new+ then do+ writeIORef last_seen (Just new)+ callback new+ else do+ return ()+~~~++#### Optimizing subscribe++It would be more efficient to run only those `ConfigParser`s that have+the possibility of changing. If we design the `configurator-ng`+interface carefully, we can determine all the keys that a parser+depends on. We can then use this information to rerun only those+parsers whose result might possibly change. (Though, `debounce` could+still be useful, as `ConfigParser`s aren't guaranteed to be 1-1+functions.)++However, once we have dependency tracking that works, there are+further applications this could enable, such as:+ * providing tools to sysadmins to understand which parts of+ the configuration files affect which parts of the system.+ * finding values in configuration files that have no effect at all+ * more speculatively, using this information to generate sample+ configuration files.++ [configurator]: https://hackage.haskell.org/package/configurator+ [critbit]: https://hackage.haskell.org/package/critbit
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ configurator-ng.cabal view
@@ -0,0 +1,110 @@+name: configurator-ng+version: 0.0.0.0+license: BSD3+license-file: LICENSE+category: Configuration, Data+copyright: Copyright 2011 MailRank, Inc.+ Copyright 2011-2014 Bryan O'Sullivan+ Copyright 2015-2016 Leon P Smith+author: Bryan O'Sullivan, Leon P Smith+maintainer: Leon P Smith <leon@melding-monads.com>+stability: experimental+-- tested-with: GHC == 7.0, GHC == 7.2, GHC == 7.4, GHC == 7.6, GHC == 7.8+synopsis: The next generation of configuration management+cabal-version: >= 1.8+homepage: http://github.com/lpsmith/configurator-ng+bug-reports: http://github.com/lpsmith/configurator-ng/issues+build-type: Simple+description:+ A configuration management library for programs and daemons.+ .+ Features include:+ .+ * A simple, but flexible, configuration language, supporting several+ of the most commonly needed types of data, along with+ interpolation of strings from the configuration or the system+ environment (e.g. @$(HOME)@).+ .+ * An @import@ directive allows the configuration of a complex+ application to be split across several smaller files, or common+ configuration data to be shared across several applications.+ .+ * An expressive applicative/monadic high-level parsing interface+ to gracefully scale to more complicated configuration needs, with+ powerful diagnostic messaging mechanism.+ .+ For details of the configuration file format, see+ <http://hackage.haskell.org/packages/archive/configurator/latest/doc/html/Data-Configurator.html>.++extra-source-files:+ README.markdown++data-files: tests/resources/*.cfg++flag developer+ description: operate in developer mode+ default: False+ manual: True++library+ exposed-modules:+ Data.Configurator+ Data.Configurator.Config+ Data.Configurator.Config.Internal+ Data.Configurator.FromValue+ Data.Configurator.FromValue.Internal+ Data.Configurator.Parser+ Data.Configurator.Parser.Internal+ Data.Configurator.Types++ other-modules:+ Data.Configurator.Config.Implementation+ Data.Configurator.Parser.Implementation+ Data.Configurator.FromValue.Implementation+ Data.Configurator.Syntax+ Data.Configurator.Types.Internal++ build-depends:+ attoparsec >= 0.11.3.0,+ base == 4.*,+ bytestring,+ critbit,+ dlist,+ directory,+ data-ordlist,+ fail,+ hashable,+ scientific,+ text >= 0.11.1.0,+ unix-compat,+ unordered-containers++ if flag(developer)+ ghc-options: -Werror+ ghc-prof-options: -auto-all++ ghc-options: -Wall -fno-warn-name-shadowing++source-repository head+ type: git+ location: http://github.com/bos/configurator++source-repository head+ type: mercurial+ location: http://bitbucket.org/bos/configurator++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Test.hs+ hs-source-dirs: tests+ build-depends:+ HUnit,+ base,+ bytestring,+ configurator-ng,+ directory,+ filepath,+ test-framework,+ test-framework-hunit,+ text+ ghc-options: -Wall -fno-warn-unused-do-bind
+ tests/Test.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Prelude hiding (lookup)++import Control.Concurrent+import Control.Exception+import Control.Monad+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Configurator+import Data.Configurator.Parser+import Data.Configurator.Types+import Data.Functor+import Data.Int+import Data.Maybe+import Data.Text (Text)+import Data.Word+import System.Directory+import System.Environment+import System.FilePath+import System.IO+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests =+ [ testCase "load" loadTest+ , testCase "types" typesTest+ , testCase "interp" interpTest+ , testCase "scoped-interp" scopedInterpTest+ , testCase "import" importTest+-- , testCase "reload" reloadTest+ ]++withLoad :: FilePath -> (ConfigCache -> IO ()) -> IO ()+withLoad name t = do+ mb <- try $ load (testFile name)+ case mb of+ Left (err :: SomeException) -> assertFailure (show err)+ Right cfg -> t cfg++withReload :: FilePath -> ([Maybe FilePath] -> ConfigCache -> IO ()) -> IO ()+withReload name t = do+ tmp <- getTemporaryDirectory+ temps <- forM (testFile name) $ \f -> do+ exists <- doesFileExist (worth f)+ if exists+ then do+ (p,h) <- openBinaryTempFile tmp "test.cfg"+ L.hPut h =<< L.readFile (worth f)+ hClose h+ return (p <$ f, Just p)+ else do+ return (f, Nothing)+ flip finally (mapM_ removeFile (catMaybes (map snd temps))) $ do+ mb <- try $ autoReload autoConfig (map fst temps)+ case mb of+ Left (err :: SomeException) -> assertFailure (show err)+ Right (cfg, tid) -> t (map snd temps) cfg >> killThread tid++testFile :: FilePath -> [Worth FilePath]+testFile name = [Required $ "tests" </> "resources" </> name]++takeMVarTimeout :: Int -> MVar a -> IO (Maybe a)+takeMVarTimeout millis v = do+ w <- newEmptyMVar+ tid <- forkIO $ do+ putMVar w . Just =<< takeMVar v+ forkIO $ do+ threadDelay (millis * 1000)+ killThread tid+ tryPutMVar w Nothing+ return ()+ takeMVar w++loadTest :: Assertion+loadTest =+ withLoad "pathological.cfg" $ \cfgcache -> do+ cfg <- readConfig cfgcache++ let (aa, _errs) = runParserM (key "aa") cfg+ assertEqual "int property" aa $ (Just 1 :: Maybe Int)++ let (ab, _errs) = runParserM (key "ab") cfg+ assertEqual "string property" ab (Just "foo" :: Maybe Text)++ let (acx, _errs) = runParserM (key "ac.x") cfg+ assertEqual "nested int" acx (Just 1 :: Maybe Int)++ let (acy, _errs) = runParserM (key "ac.y") cfg+ assertEqual "nested bool" acy (Just True :: Maybe Bool)++ let (ad, _errs) = runParserM (key "ad") cfg+ assertEqual "simple bool" ad (Just False :: Maybe Bool)++ let (ae, _errs) = runParserM (key "ae") cfg+ assertEqual "simple int 2" ae (Just 1 :: Maybe Int)++ let (af, _errs) = runParserM (key "af") cfg+ assertEqual "list property" af (Just (2,3) :: Maybe (Int,Int))++ let (deep, _errs) = runParserM (key "ag.q-e.i_u9.a") cfg+ assertEqual "deep bool" deep (Just False :: Maybe Bool)++ let (notacomment, _errs) = runParserM (key "notacomment") cfg+ assertEqual "not a comment" notacomment (Just 42 :: Maybe Int)++ let (comment, _errs) = runParserM (key "comment.x") cfg+ assertEqual "comment" comment (Nothing :: Maybe Value)++typesTest :: Assertion+typesTest =+ withLoad "pathological.cfg" $ \cfgcache -> do+ cfg <- readConfig cfgcache++ let (asInt, _errs) = runParserM (key "aa" :: ConfigParserM Int) cfg+ assertEqual "int" asInt (Just 1)++ let (asInteger, _errs) = runParserM (key "aa" :: ConfigParserM Integer) cfg+ assertEqual "int" asInteger (Just 1)++ let (asWord, _errs) = runParserM (key "aa" :: ConfigParserM Word) cfg+ assertEqual "int" asWord (Just 1)++ let (asInt8, _errs) = runParserM (key "aa" :: ConfigParserM Int8) cfg+ assertEqual "int8" asInt8 (Just 1)++ let (asInt16, _errs) = runParserM (key "aa" :: ConfigParserM Int16) cfg+ assertEqual "int16" asInt16 (Just 1)++ let (asInt32, _errs) = runParserM (key "aa" :: ConfigParserM Int32) cfg+ assertEqual "int32" asInt32 (Just 1)++ let (asInt64, _errs) = runParserM (key "aa" :: ConfigParserM Int64) cfg+ assertEqual "int64" asInt64 (Just 1)++ let (asWord8, _errs) = runParserM (key "aa" :: ConfigParserM Word8) cfg+ assertEqual "word8" asWord8 (Just 1)++ let (asWord16, _errs) = runParserM (key "aa" :: ConfigParserM Word16) cfg+ assertEqual "word16" asWord16 (Just 1)++ let (asWord32, _errs) = runParserM (key "aa" :: ConfigParserM Word32) cfg+ assertEqual "word32" asWord32 (Just 1)++ let (asWord64, _errs) = runParserM (key "aa" :: ConfigParserM Word64) cfg+ assertEqual "word64" asWord64 (Just 1)++ let (asTextBad, _errs) = runParserM (key "aa" :: ConfigParserM Text) cfg+ assertEqual "bad text" asTextBad Nothing++ let (asTextGood, _errs) = runParserM (key "ab" :: ConfigParserM Text) cfg+ assertEqual "good text" asTextGood (Just "foo")++ let (asStringGood, _errs) = runParserM (key "ab" :: ConfigParserM String) cfg+ assertEqual "string" asStringGood (Just "foo")++ let (asInts, _errs) = runParserM (key "xs" :: ConfigParserM [Int]) cfg+ assertEqual "ints" asInts (Just [1,2,3])++ let (asChar, _errs) = runParserM (key "c" :: ConfigParserM Char) cfg+ assertEqual "char" asChar (Just 'x')++interpTest :: Assertion+interpTest =+ withLoad "pathological.cfg" $ \cfgcache -> do+ cfg <- readConfig cfgcache++ home <- getEnv "HOME"+ let (cfgHome, _errs) = runParserM (key "ba") cfg+ assertEqual "home interp" (Just home) cfgHome++scopedInterpTest :: Assertion+scopedInterpTest = withLoad "interp.cfg" $ \cfgcache -> do+ cfg <- readConfig cfgcache+ home <- getEnv "HOME"++ let (a, _err) = runParserM (key "myprogram.exec") cfg+ assertEqual "myprogram.exec" (Just $ home++"/services/myprogram/myprogram") a++ let (b, _err) = runParserM (key "myprogram.stdout") cfg+ assertEqual "myprogram.stdout" (Just $ home++"/services/myprogram/stdout") b++ let (c, _err) = runParserM (key "top.layer1.layer2.dir") cfg+ assertEqual "nested scope" (Just $ home++"/top/layer1/layer2") c++importTest :: Assertion+importTest =+ withLoad "import.cfg" $ \cfgcache -> do+ cfg <- readConfig cfgcache+ let (aa, _errs) = runParserM (key "x.aa" :: ConfigParserM Int) cfg+ assertEqual "simple" aa (Just 1)+ let (acx, _errs) = runParserM (key "x.ac.x" :: ConfigParserM Int) cfg+ assertEqual "nested" acx (Just 1)++{--+reloadTest :: Assertion+reloadTest =+ withReload "pathological.cfg" $ \[Just f] cfgcache -> do+ aa <- lookup cfg "aa"+ assertEqual "simple property 1" aa $ Just (1 :: Int)++ dongly <- newEmptyMVar+ wongly <- newEmptyMVar+ subscribe cfg "dongly" $ \ _ _ -> putMVar dongly ()+ subscribe cfg "wongly" $ \ _ _ -> putMVar wongly ()+ L.appendFile f "\ndongly = 1"+ r1 <- takeMVarTimeout 2000 dongly+ assertEqual "notify happened" r1 (Just ())+ r2 <- takeMVarTimeout 2000 wongly+ assertEqual "notify not happened" r2 Nothing+--}
+ tests/resources/import.cfg view
@@ -0,0 +1,4 @@+x {+ import "pathological.cfg"+}+
+ tests/resources/interp.cfg view
@@ -0,0 +1,18 @@+services = "$(HOME)/services"+root = "can be overwritten by inner block."+myprogram {+ name = "myprogram"+ root = "$(services)/$(name)"+ exec = "$(root)/$(name)"+ stdout = "$(root)/stdout"+ stderr = "$(root)/stderr"+ delay = 1+}+dir = "$(HOME)"+top {+ dir = "$(dir)/top"+ layer1 {+ dir = "$(dir)/layer1"+ layer2.dir = "$(dir)/layer2"+ }+}
+ tests/resources/pathological.cfg view
@@ -0,0 +1,47 @@+# Comment++aa # Comment+= # Comment+ 1 # Comment++ab =+"foo"+++ac {+ # fnord+ x=1++ y=true++ #blorg+}++ad = false+ae = 1+af+=+[+2+#foo+,+#bar+3+#baz+]#quux++ag { q-e { i_u9 { a=false}}}++ba = "$(HOME)"++xs = [1,2,3]++c = "x"++#+notacomment = 42++#; comment {+ x = 1+ msg = "foo"+}