configurator (empty) → 0.0.0.1
raw patch · 11 files changed
+1048/−0 lines, 11 filesdep +attoparsec-textdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec-text, base, bytestring, directory, hashable, text, unix-compat, unordered-containers
Files
- Data/Configurator.hs +418/−0
- Data/Configurator/Instances.hs +57/−0
- Data/Configurator/Parser.hs +160/−0
- Data/Configurator/Types.hs +23/−0
- Data/Configurator/Types/Internal.hs +186/−0
- LICENSE +30/−0
- README.markdown +48/−0
- Setup.lhs +3/−0
- configurator.cabal +79/−0
- tests/TestLoad.hs +14/−0
- tests/TestReload.hs +30/−0
+ Data/Configurator.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards,+ ScopedTypeVariables #-}++-- |+-- Module: Data.Configurator+-- Copyright: (c) 2011 MailRank, Inc.+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>+-- Stability: experimental+-- Portability: portable+--+-- A simple (yet powerful) library for working with configuration+-- files.++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++ -- * Loading configuration data+ autoReload+ , autoConfig+ -- * Lookup functions+ , lookup+ , lookupDefault+ -- * Notification of configuration changes+ -- $notify+ , prefix+ , exact+ , subscribe+ -- * Low-level loading functions+ , load+ , reload+ -- * Helper functions+ , display+ , getMap+ ) where++import Control.Applicative ((<$>))+import Control.Concurrent (ThreadId, forkIO, threadDelay)+import Control.Exception (SomeException, catch, evaluate, handle, throwIO, try)+import Control.Monad (foldM, forM, forM_, join, when)+import Data.Configurator.Instances ()+import Data.Configurator.Parser (interp, topLevel)+import Data.Configurator.Types.Internal+import Data.IORef (atomicModifyIORef, newIORef, readIORef)+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.Monoid (mconcat)+import Data.Text.Lazy.Builder (fromString, fromText, toLazyText)+import Data.Text.Lazy.Builder.Int (decimal)+import Prelude hiding (catch, 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 Data.Attoparsec.Text as T+import qualified Data.Attoparsec.Text.Lazy as L+import qualified Data.HashMap.Lazy as H+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L++loadFiles :: [Path] -> IO (H.HashMap Path [Directive])+loadFiles = foldM go H.empty+ where+ go seen path = do+ ds <- loadOne . T.unpack =<< interpolate path H.empty+ let !seen' = H.insert path ds seen+ notSeen n = not . isJust . H.lookup n $ seen+ foldM go seen' . filter notSeen . importsOf $ ds+ +-- | Create a 'Config' 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 :: [FilePath] -> IO Config+load = load' Nothing++load' :: Maybe AutoConfig -> [FilePath] -> IO Config+load' auto paths0 = do+ let paths = map T.pack paths0+ ds <- loadFiles paths+ m <- newIORef =<< flatten paths ds+ s <- newIORef H.empty+ return Config {+ cfgAuto = auto+ , cfgPaths = H.keys ds+ , cfgMap = m+ , cfgSubs = s+ }++-- | Forcibly reload a 'Config'. Throws an exception on error, such as+-- if files no longer exist or contain errors.+reload :: Config -> IO ()+reload cfg@Config{..} = do+ m' <- flatten cfgPaths =<< loadFiles cfgPaths+ m <- atomicModifyIORef cfgMap $ \m -> (m', m)+ notifySubscribers cfg m m' =<< readIORef cfgSubs++-- | 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 'Config' 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 'Config' 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.+ -> [FilePath]+ -- ^ Configuration files to load.+ -> IO (Config, ThreadId)+autoReload AutoConfig{..} _+ | interval < 1 = error "autoReload: negative interval"+autoReload _ [] = error "autoReload: no paths to load"+autoReload auto@AutoConfig{..} paths = do+ cfg <- load' (Just auto) paths+ let loop meta = do+ threadDelay (max interval 1 * 1000000)+ meta' <- getMeta paths+ if meta' == meta+ then loop meta+ else (reload cfg `catch` onError) >> loop meta'+ tid <- forkIO $ loop =<< getMeta paths+ 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 :: [FilePath] -> IO [Maybe Meta]+getMeta paths = forM paths $ \path ->+ handle (\(_::SomeException) -> return Nothing) . fmap Just $ do+ st <- getFileStatus path+ return (fileSize st, modificationTime st)++-- | Look up a name in the given 'Config'. If a binding exists, and+-- the value can be 'convert'ed to the desired type, return the+-- converted value, otherwise 'Nothing'.+lookup :: Configured a => Config -> Name -> IO (Maybe a)+lookup Config{..} name =+ (join . fmap convert . H.lookup name) <$> readIORef cfgMap++-- | Look up a name in the given 'Config'. 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.+ -> Config -> Name -> IO a+lookupDefault def cfg name = fromMaybe def <$> lookup cfg name++-- | Perform a simple dump of a 'Config' to @stdout@.+display :: Config -> IO ()+display Config{..} = print =<< readIORef cfgMap++-- | Fetch the 'H.HashMap' that maps names to values.+getMap :: Config -> IO (H.HashMap Name Value)+getMap = readIORef . cfgMap++flatten :: [Path] -> H.HashMap Path [Directive] -> IO (H.HashMap Name Value)+flatten roots files = foldM (directive "") H.empty .+ concat . catMaybes . map (`H.lookup` files) $ roots+ where+ directive pfx m (Bind name (String value)) = do+ v <- interpolate value m+ return $! H.insert (T.append pfx name) (String v) m+ directive pfx m (Bind name value) =+ return $! H.insert (T.append pfx name) value m+ directive pfx m (Group name xs) = foldM (directive pfx') m xs+ where pfx' = T.concat [pfx, name, "."]+ directive pfx m (Import path) =+ case H.lookup path files of+ Just ds -> foldM (directive pfx) m ds+ _ -> return m++interpolate :: T.Text -> H.HashMap Name Value -> IO T.Text+interpolate 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+ interpret (Literal x) = return (fromText x)+ interpret (Interpolate name) =+ case H.lookup name env of+ Just (String x) -> return (fromText x)+ Just (Number n) -> return (decimal n)+ 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 :: [Directive] -> [Path]+importsOf (Import path : xs) = path : importsOf xs+importsOf (Group _ ys : xs) = importsOf ys ++ importsOf xs+importsOf (_ : xs) = importsOf xs+importsOf _ = []++loadOne :: FilePath -> IO [Directive]+loadOne path = do+ s <- L.readFile path+ p <- evaluate (L.eitherResult $ L.parse topLevel s)+ `catch` \(e::ConfigError) ->+ throwIO $ case e of+ ParseError _ err -> ParseError path err+ case p of+ Left err -> throwIO (ParseError 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 :: Config -> Pattern -> ChangeHandler -> IO ()+subscribe Config{..} pat act = do+ m' <- atomicModifyIORef cfgSubs $ \m ->+ let m' = H.insertWith (++) pat [act] m in (m', m')+ evaluate m' >> return ()++notifySubscribers :: Config -> H.HashMap Name Value -> H.HashMap Name Value+ -> H.HashMap Pattern [ChangeHandler] -> IO ()+notifySubscribers Config{..} m m' subs = H.foldrWithKey go (return ()) subs+ where+ changedOrGone = H.foldrWithKey check [] m+ where check n v nvs = case H.lookup n m' of+ Just v' | v /= v' -> (n,Just v'):nvs+ | otherwise -> nvs+ _ -> (n,Nothing):nvs+ new = H.foldrWithKey check [] m'+ where check n v nvs = case H.lookup n m of+ Nothing -> (n,v):nvs+ _ -> nvs+ notify p n v a = a n v `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' = H.lookup n m'+ when (H.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@!+--+-- * Integers, represented in base 10.+--+-- * 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"+--+-- 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/Instances.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.Configurator.Instances () where++import Control.Applicative+import Data.Configurator.Types.Internal+import Data.Text.Encoding (encodeUtf8)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as T+import qualified Data.Text.Lazy as L++instance Configured Value where+ convert = Just++instance Configured Bool where+ convert (Bool v) = Just v+ convert _ = Nothing++instance Configured Int where+ convert (Number v) = Just v+ convert _ = Nothing++instance Configured T.Text where+ convert (String v) = Just v+ convert _ = Nothing++instance Configured [Char] where+ convert = fmap T.unpack . convert++instance Configured L.Text where+ convert = fmap L.fromStrict . convert++instance Configured B.ByteString where+ convert = fmap encodeUtf8 . convert++instance Configured LB.ByteString where+ convert = fmap (LB.fromChunks . (:[])) . convert++instance (Configured a) => Configured [a] where+ convert (List xs) = mapM convert xs+ convert _ = Nothing++instance (Configured a, Configured b) => Configured (a,b) where+ convert (List [a,b]) = (,) <$> convert a <*> convert b+ convert _ = Nothing++instance (Configured a, Configured b, Configured c) => Configured (a,b,c) where+ convert (List [a,b,c]) = (,,) <$> convert a <*> convert b <*> convert c+ convert _ = Nothing++instance (Configured a, Configured b, Configured c, Configured d)+ => Configured (a,b,c,d) where+ convert (List [a,b,c,d]) = (,,,) <$> convert a <*> convert b <*> convert c+ <*> convert d+ convert _ = Nothing
+ Data/Configurator/Parser.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module: Data.Configurator.Parser+-- Copyright: (c) 2011 MailRank, Inc.+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>+-- Stability: experimental+-- Portability: portable+--+-- A parser for configuration files.++module Data.Configurator.Parser+ (+ 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_)+ , 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 = scan Space go *> pure ()+ where go Space c | isSpace c = Just Space+ go Space '#' = Just Comment+ go Space _ = Nothing+ go Comment '\r' = Just Space+ go Comment '\n' = Just Space+ go Comment _ = Just Comment++-- | 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++ident :: Parser Name+ident = do+ n <- T.cons <$> satisfy isAlpha <*> A.takeWhile isCont+ when (n == "import") $+ throw (ParseError "" $ "reserved word (" ++ show n ++ ") used as identifier")+ return n+ where+ isCont c = isAlphaNum c || c == '_' || c == '-'++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 <$> decimal+ , 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,23 @@+-- |+-- Module: Data.Configurator.Types+-- Copyright: (c) 2011 MailRank, Inc.+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>+-- Stability: experimental+-- Portability: portable+--+-- Types for working with configuration files.++module Data.Configurator.Types+ (+ AutoConfig(..)+ , Config(cfgPaths)+ , Name+ , Value(..)+ , Configured(..)+ -- * Notification of configuration changes+ , Pattern+ , ChangeHandler+ ) where++import Data.Configurator.Types.Internal
+ Data/Configurator/Types/Internal.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module: Data.Configurator.Types.Internal+-- Copyright: (c) 2011 MailRank, Inc.+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>+-- Stability: experimental+-- Portability: portable+--+-- Types for working with configuration files.++module Data.Configurator.Types.Internal+ (+ Config(..)+ , Configured(..)+ , AutoConfig(..)+ , Name+ , Value(..)+ , Binding+ , Path+ , Directive(..)+ , ConfigError(..)+ , Interpolate(..)+ , Pattern(..)+ , exact+ , prefix+ , ChangeHandler+ ) where++import Control.Exception+import Data.Data (Data)+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)+import Prelude hiding (lookup)+import qualified Data.HashMap.Lazy as H++-- | Configuration data.+data Config = Config {+ cfgAuto :: Maybe AutoConfig+ , cfgPaths :: [Path]+ -- ^ The files from which the 'Config' was loaded.+ , cfgMap :: IORef (H.HashMap Name Value)+ , cfgSubs :: IORef (H.HashMap Pattern [ChangeHandler])+ }++-- | 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+ hash (Exact n) = hash n+ hash (Prefix n) = hash n++-- | This class represents types that can be automatically and safely+-- converted /from/ a 'Value' /to/ a destination type. If conversion+-- fails because the types are not compatible, 'Nothing' is returned.+--+-- For an example of compatibility, a 'Value' of 'Bool' 'True' cannot+-- be 'convert'ed to an 'Int'.+class Configured a where+ convert :: Value -> Maybe a++-- | An error occurred while processing a configuration file.+data ConfigError = ParseError FilePath String+ deriving (Show, Typeable)++-- | 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) ++ "}"++instance Exception ConfigError++-- | 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]+ 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 Int+ -- ^ 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,48 @@+# Welcome to configurator++This is a library for configuring Haskell daemons and programs.++Its features include:++* Automatic, dynamic reloading in response to modifications to+ configuration files.++* 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)`).++* Subscription-based notification of changes to configuration+ properties.++* An `import` directive allows the configuration of a complex+ application to be split across several smaller files, or+ configuration data to be shared across several applications.++# Configuration file format++For details of the configuration file format, see [the Haddock documentation](http://hackage.haskell.org/packages/archive/configurator/latest/doc/html/Data-Configurator.html).++# Join in!++We are happy to receive bug reports, fixes, documentation enhancements,+and other improvements.++Please report bugs via the+[github issue tracker](http://github.com/mailrank/configurator/issues).++Master [git repository](http://github.com/mailrank/configurator):++* `git clone git://github.com/mailrank/configurator.git`++There's also a [Mercurial mirror](http://bitbucket.org/bos/configurator):++* `hg clone http://bitbucket.org/bos/configurator`++(You can create and contribute changes using either git or Mercurial.)++Authors+-------++This library is written and maintained by Bryan O'Sullivan,+<bos@mailrank.com>.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ configurator.cabal view
@@ -0,0 +1,79 @@+name: configurator+version: 0.0.0.1+license: BSD3+license-file: LICENSE+category: Configuration, Data+copyright: Copyright 2011 MailRank, Inc.+author: Bryan O'Sullivan <bos@mailrank.com>+maintainer: Bryan O'Sullivan <bos@mailrank.com>+stability: experimental+tested-with: GHC == 7.0.3+synopsis: Configuration management+cabal-version: >= 1.8+homepage: http://github.com/mailrank/configurator+bug-reports: http://github.com/mailrank/configurator/issues+build-type: Simple+description:+ A configuration management library for programs and daemons.+ .+ Features include:+ .+ * Automatic, dynamic reloading in response to modifications to+ configuration files.+ .+ * 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)@).+ .+ * Subscription-based notification of changes to configuration+ properties.+ .+ * 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.+ .+ 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+ tests/*.hs++flag developer+ description: operate in developer mode+ default: False++library+ exposed-modules:+ Data.Configurator+ Data.Configurator.Types++ other-modules:+ Data.Configurator.Instances+ Data.Configurator.Parser+ Data.Configurator.Types.Internal++ build-depends:+ attoparsec-text >= 0.8.5.0,+ base == 4.*,+ bytestring,+ directory,+ hashable,+ text >= 0.11.1.0,+ unix-compat,+ unordered-containers ++ if flag(developer)+ ghc-options: -Werror+ ghc-prof-options: -auto-all++ ghc-options: -Wall++source-repository head+ type: git+ location: http://github.com/mailrank/configurator++source-repository head+ type: mercurial+ location: http://bitbucket.org/bos/configurator
+ tests/TestLoad.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Exception (SomeException, try)+import Control.Monad (forM_)+import Data.Configurator+import System.Environment++main = do+ args <- getArgs+ putStrLn $ "files: " ++ show args+ e <- try $ load args+ case e of+ Left (err::SomeException) -> putStrLn $ "error: " ++ show err+ Right c -> putStr "ok: " >> display c
+ tests/TestReload.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Exception+import Control.Concurrent+import Data.Configurator+import Data.Configurator.Types+import qualified Data.ByteString.Lazy.Char8 as L+import System.Environment+import System.Directory+import Control.Monad+import System.IO++main = do+ args <- getArgs+ tmpDir <- getTemporaryDirectory+ temps <- forM args $ \arg -> do+ (p,h) <- openBinaryTempFile tmpDir "test.cfg"+ L.hPut h =<< L.readFile arg+ hClose h+ return p+ flip finally (mapM_ removeFile temps) $ do+ done <- newEmptyMVar+ let myConfig = autoConfig {+ onError = \e -> hPutStrLn stderr $ "uh oh: " ++ show e+ }+ (c,_) <- autoReload myConfig temps+ display c+ subscribe c "dongly" $ \n v -> print (n,v) >> putMVar done ()+ forM_ temps $ \t -> L.appendFile t "\ndongly = 1\n"+ takeMVar done