configurator-0.3.0.0/0000755000000000000000000000000012355066767012561 5ustar0000000000000000configurator-0.3.0.0/configurator.cabal0000644000000000000000000000513512355066767016253 0ustar0000000000000000name: configurator version: 0.3.0.0 license: BSD3 license-file: LICENSE category: Configuration, Data copyright: Copyright 2011 MailRank, Inc. Copyright 2011-2014 Bryan O'Sullivan author: Bryan O'Sullivan maintainer: Bryan O'Sullivan stability: experimental tested-with: GHC == 7.0, GHC == 7.2, GHC == 7.4, GHC == 7.6, GHC == 7.8 synopsis: Configuration management cabal-version: >= 1.8 homepage: http://github.com/bos/configurator bug-reports: http://github.com/bos/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 . 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.Types other-modules: Data.Configurator.Instances Data.Configurator.Parser Data.Configurator.Types.Internal build-depends: attoparsec >= 0.10.0.2, 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/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, directory, filepath, test-framework, test-framework-hunit, text ghc-options: -Wall -fno-warn-unused-do-bind configurator-0.3.0.0/LICENSE0000644000000000000000000000266712355066767013601 0ustar0000000000000000Copyright (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. configurator-0.3.0.0/README.markdown0000644000000000000000000000274512355066767015272 0ustar0000000000000000# 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/bos/configurator/issues). Master [git repository](http://github.com/bos/configurator): * `git clone git://github.com/bos/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, . configurator-0.3.0.0/Setup.lhs0000644000000000000000000000011412355066767014365 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain configurator-0.3.0.0/Data/0000755000000000000000000000000012355066767013432 5ustar0000000000000000configurator-0.3.0.0/Data/Configurator.hs0000644000000000000000000004600012355066767016430 0ustar0000000000000000{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TupleSections #-} -- | -- Module: Data.Configurator -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3 -- Maintainer: Bryan O'Sullivan -- 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 -- * Types Worth(..) -- * Loading configuration data , autoReload , autoReloadGroups , autoConfig , empty -- * Lookup functions , lookup , lookupDefault , require -- * Notification of configuration changes -- $notify , prefix , exact , subscribe -- * Low-level loading functions , load , loadGroups , reload , subconfig , addToConfig , addGroupsToConfig -- * Helper functions , display , getMap ) where import Control.Applicative ((<$>)) import Control.Concurrent (ThreadId, forkIO, threadDelay) import Control.Exception (SomeException, evaluate, handle, throwIO, try) import Control.Monad (foldM, forM, forM_, join, when, msum) import Data.Configurator.Instances () import Data.Configurator.Parser (interp, topLevel) import Data.Configurator.Types.Internal import Data.IORef (atomicModifyIORef, newIORef, readIORef) import Data.List (tails) import Data.Maybe (fromMaybe, isJust) import Data.Monoid (mconcat) import Data.Ratio (denominator, numerator) 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.IO.Unsafe (unsafePerformIO) 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.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 H.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 '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 :: [Worth FilePath] -> IO Config load files = fmap (Config "") $ load' Nothing (map (\f -> ("", f)) files) -- | Create a 'Config' 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 Config loadGroups files = fmap (Config "") $ load' Nothing files load' :: Maybe AutoConfig -> [(Name, Worth FilePath)] -> IO BaseConfig 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 BaseConfig { cfgAuto = auto , cfgPaths = p , cfgMap = m , cfgSubs = s } -- | Gives a 'Config' corresponding to just a single group of the original -- 'Config'. The subconfig can be used just like the original 'Config', but -- see the documentation for 'reload'. subconfig :: Name -> Config -> Config subconfig g (Config root cfg) = Config (T.concat [root, g, "."]) cfg -- | Forcibly reload a 'Config'. Throws an exception on error, such as -- if files no longer exist or contain errors. If the provided 'Config' is -- a 'subconfig', this will reload the entire top-level configuration, not just -- the local section. reload :: Config -> IO () reload (Config _ cfg@BaseConfig{..}) = reloadBase cfg reloadBase :: BaseConfig -> IO () reloadBase cfg@BaseConfig{..} = 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 'Config', causing it to be reloaded to add -- their contents. addToConfig :: [Worth FilePath] -> Config -> IO () addToConfig paths0 cfg = addGroupsToConfig (map (\x -> ("",x)) paths0) cfg -- | Add additional files to named groups in a 'Config', causing it to be -- reloaded to add their contents. If the prefixes are non-empty, they should -- end in dots. addGroupsToConfig :: [(Name, Worth FilePath)] -> Config -> IO () addGroupsToConfig paths0 (Config root cfg@BaseConfig{..}) = do let fix (x,y) = (root `T.append` x, fmap T.pack y) paths = map fix paths0 atomicModifyIORef cfgPaths $ \prev -> (prev ++ paths, ()) reloadBase 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 '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. -> [Worth FilePath] -- ^ Configuration files to load. -> IO (Config, ThreadId) autoReload auto paths = autoReloadGroups auto (map (\x -> ("", x)) paths) autoReloadGroups :: AutoConfig -> [(Name, Worth FilePath)] -> IO (Config, 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 (reloadBase cfg `E.catch` onError) >> loop meta' tid <- forkIO $ loop =<< getMeta files return (Config "" 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 '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 root BaseConfig{..}) name = (join . fmap convert . H.lookup (root `T.append` name)) <$> readIORef cfgMap -- | 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 throw a 'KeyError'. require :: Configured a => Config -> 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 '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 root BaseConfig{..}) = print . (root,) =<< readIORef cfgMap -- | Fetch the 'H.HashMap' that maps names to values. getMap :: Config -> IO (H.HashMap Name Value) getMap = readIORef . cfgMap . baseCfg flatten :: [(Name, Worth Path)] -> H.HashMap (Worth Path) [Directive] -> IO (H.HashMap Name Value) flatten roots files = foldM doPath H.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 $! 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 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 interpolate :: T.Text -> T.Text -> H.HashMap 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 H.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) | denominator r == 1 -> return (decimal $ numerator r) | otherwise -> return $ realFloat (fromRational r :: Double) -- TODO: Use a dedicated Builder for Rationals instead of -- using realFloat on a 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::ConfigError) -> 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 :: Config -> Pattern -> ChangeHandler -> IO () subscribe (Config root BaseConfig{..}) pat act = do m' <- atomicModifyIORef cfgSubs $ \m -> let m' = H.insertWith (++) (localPattern root pat) [act] m in (m', m') evaluate m' >> return () localPattern :: Name -> Pattern -> Pattern localPattern pfx (Exact s) = Exact (pfx `T.append` s) localPattern pfx (Prefix s) = Prefix (pfx `T.append` s) notifySubscribers :: BaseConfig -> H.HashMap Name Value -> H.HashMap Name Value -> H.HashMap Pattern [ChangeHandler] -> IO () notifySubscribers BaseConfig{..} 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 `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' = 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 -- | A completely empty configuration. empty :: Config empty = Config "" $ unsafePerformIO $ do p <- newIORef [] m <- newIORef H.empty s <- newIORef H.empty return BaseConfig { cfgAuto = Nothing , cfgPaths = p , cfgMap = m , cfgSubs = s } {-# NOINLINE empty #-} -- $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" -- -- 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. configurator-0.3.0.0/Data/Configurator/0000755000000000000000000000000012355066767016074 5ustar0000000000000000configurator-0.3.0.0/Data/Configurator/Instances.hs0000644000000000000000000000674612355066767020374 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Configurator.Instances () where import Control.Applicative import Data.Configurator.Types.Internal import Data.Complex (Complex) import Data.Fixed (Fixed, HasResolution) import Data.Int (Int8, Int16, Int32, Int64) import Data.Text.Encoding (encodeUtf8) import Data.Ratio (Ratio, denominator, numerator) import Data.Word (Word, Word8, Word16, Word32, Word64) import Foreign.C.Types (CDouble, CFloat) 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 convertNumberToNum :: (Num a) => Value -> Maybe a convertNumberToNum (Number r) | denominator r == 1 = Just $ fromInteger $ numerator r convertNumberToNum _ = Nothing instance Configured Int where convert = convertNumberToNum instance Configured Integer where convert = convertNumberToNum instance Configured Int8 where convert = convertNumberToNum instance Configured Int16 where convert = convertNumberToNum instance Configured Int32 where convert = convertNumberToNum instance Configured Int64 where convert = convertNumberToNum instance Configured Word where convert = convertNumberToNum instance Configured Word8 where convert = convertNumberToNum instance Configured Word16 where convert = convertNumberToNum instance Configured Word32 where convert = convertNumberToNum instance Configured Word64 where convert = convertNumberToNum convertNumberToFractional :: (Fractional a) => Value -> Maybe a convertNumberToFractional (Number r) = Just $ fromRational r convertNumberToFractional _ = Nothing instance Configured Double where convert = convertNumberToFractional instance Configured Float where convert = convertNumberToFractional instance Configured CDouble where convert = convertNumberToFractional instance Configured CFloat where convert = convertNumberToFractional instance Integral a => Configured (Ratio a) where convert = convertNumberToFractional instance RealFloat a => Configured (Complex a) where convert = convertNumberToFractional instance HasResolution a => Configured (Fixed a) where convert = convertNumberToFractional instance Configured T.Text where convert (String v) = Just v convert _ = Nothing instance Configured Char where convert (String txt) | T.length txt == 1 = Just $ T.head txt convert _ = Nothing convertList = 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 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 configurator-0.3.0.0/Data/Configurator/Parser.hs0000644000000000000000000001146212355066767017670 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module: Data.Configurator.Parser -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3 -- Maintainer: Bryan O'Sullivan -- 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 <$> rational , 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 configurator-0.3.0.0/Data/Configurator/Types.hs0000644000000000000000000000113012355066767017527 0ustar0000000000000000-- | -- Module: Data.Configurator.Types -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3 -- Maintainer: Bryan O'Sullivan -- Stability: experimental -- Portability: portable -- -- Types for working with configuration files. module Data.Configurator.Types ( AutoConfig(..) , Config , Name , Value(..) , Configured, convert , Worth(..) -- * Exceptions , ConfigError(..) , KeyError(..) -- * Notification of configuration changes , Pattern , ChangeHandler ) where import Data.Configurator.Types.Internal configurator-0.3.0.0/Data/Configurator/Types/0000755000000000000000000000000012355066767017200 5ustar0000000000000000configurator-0.3.0.0/Data/Configurator/Types/Internal.hs0000644000000000000000000001576212355066767021323 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-} -- | -- Module: Data.Configurator.Types.Internal -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3 -- Maintainer: Bryan O'Sullivan -- Stability: experimental -- Portability: portable -- -- Types for working with configuration files. module Data.Configurator.Types.Internal ( BaseConfig(..) , Config(..) , Configured(..) , AutoConfig(..) , Worth(..) , Name , Value(..) , Binding , Path , Directive(..) , ConfigError(..) , KeyError(..) , 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 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 BaseConfig = BaseConfig { cfgAuto :: Maybe AutoConfig , cfgPaths :: IORef [(Name, Worth Path)] -- ^ The files from which the 'Config' was loaded. , cfgMap :: IORef (H.HashMap Name Value) , cfgSubs :: IORef (H.HashMap Pattern [ChangeHandler]) } -- | Configuration data. data Config = Config { root :: Text, baseCfg :: BaseConfig } 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 -- | 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 convertList :: Value -> Maybe [a] convertList (List xs) = mapM convert xs convertList _ = Nothing instance Configured a => Configured [a] where convert = convertList -- | An error occurred while processing a configuration file. data ConfigError = ParseError FilePath String deriving (Show, Typeable) instance Exception ConfigError -- | 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] 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 Rational -- ^ 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) configurator-0.3.0.0/tests/0000755000000000000000000000000012355066767013723 5ustar0000000000000000configurator-0.3.0.0/tests/Test.hs0000644000000000000000000001421212355066767015176 0ustar0000000000000000{-# 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.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 -> (Config -> 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] -> Config -> 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" $ \cfg -> do aa <- lookup cfg "aa" assertEqual "int property" aa $ (Just 1 :: Maybe Int) ab <- lookup cfg "ab" assertEqual "string property" ab (Just "foo" :: Maybe Text) acx <- lookup cfg "ac.x" assertEqual "nested int" acx (Just 1 :: Maybe Int) acy <- lookup cfg "ac.y" assertEqual "nested bool" acy (Just True :: Maybe Bool) ad <- lookup cfg "ad" assertEqual "simple bool" ad (Just False :: Maybe Bool) ae <- lookup cfg "ae" assertEqual "simple int 2" ae (Just 1 :: Maybe Int) af <- lookup cfg "af" assertEqual "list property" af (Just (2,3) :: Maybe (Int,Int)) deep <- lookup cfg "ag.q-e.i_u9.a" assertEqual "deep bool" deep (Just False :: Maybe Bool) typesTest :: Assertion typesTest = withLoad "pathological.cfg" $ \cfg -> do asInt <- lookup cfg "aa" :: IO (Maybe Int) assertEqual "int" asInt (Just 1) asInteger <- lookup cfg "aa" :: IO (Maybe Integer) assertEqual "int" asInteger (Just 1) asWord <- lookup cfg "aa" :: IO (Maybe Word) assertEqual "int" asWord (Just 1) asInt8 <- lookup cfg "aa" :: IO (Maybe Int8) assertEqual "int8" asInt8 (Just 1) asInt16 <- lookup cfg "aa" :: IO (Maybe Int16) assertEqual "int16" asInt16 (Just 1) asInt32 <- lookup cfg "aa" :: IO (Maybe Int32) assertEqual "int32" asInt32 (Just 1) asInt64 <- lookup cfg "aa" :: IO (Maybe Int64) assertEqual "int64" asInt64 (Just 1) asWord8 <- lookup cfg "aa" :: IO (Maybe Word8) assertEqual "word8" asWord8 (Just 1) asWord16 <- lookup cfg "aa" :: IO (Maybe Word16) assertEqual "word16" asWord16 (Just 1) asWord32 <- lookup cfg "aa" :: IO (Maybe Word32) assertEqual "word32" asWord32 (Just 1) asWord64 <- lookup cfg "aa" :: IO (Maybe Word64) assertEqual "word64" asWord64 (Just 1) asTextBad <- lookup cfg "aa" :: IO (Maybe Text) assertEqual "bad text" asTextBad Nothing asTextGood <- lookup cfg "ab" :: IO (Maybe Text) assertEqual "good text" asTextGood (Just "foo") asStringGood <- lookup cfg "ab" :: IO (Maybe String) assertEqual "string" asStringGood (Just "foo") asInts <- lookup cfg "xs" :: IO (Maybe [Int]) assertEqual "ints" asInts (Just [1,2,3]) asChar <- lookup cfg "c" :: IO (Maybe Char) assertEqual "char" asChar (Just 'x') interpTest :: Assertion interpTest = withLoad "pathological.cfg" $ \cfg -> do home <- getEnv "HOME" cfgHome <- lookup cfg "ba" assertEqual "home interp" (Just home) cfgHome scopedInterpTest :: Assertion scopedInterpTest = withLoad "interp.cfg" $ \cfg -> do home <- getEnv "HOME" lookup cfg "myprogram.exec" >>= assertEqual "myprogram.exec" (Just $ home++"/services/myprogram/myprogram") lookup cfg "myprogram.stdout" >>= assertEqual "myprogram.stdout" (Just $ home++"/services/myprogram/stdout") lookup cfg "top.layer1.layer2.dir" >>= assertEqual "nested scope" (Just $ home++"/top/layer1/layer2") importTest :: Assertion importTest = withLoad "import.cfg" $ \cfg -> do aa <- lookup cfg "x.aa" :: IO (Maybe Int) assertEqual "simple" aa (Just 1) acx <- lookup cfg "x.ac.x" :: IO (Maybe Int) assertEqual "nested" acx (Just 1) reloadTest :: Assertion reloadTest = withReload "pathological.cfg" $ \[Just f] cfg -> 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 configurator-0.3.0.0/tests/resources/0000755000000000000000000000000012355066767015735 5ustar0000000000000000configurator-0.3.0.0/tests/resources/import.cfg0000644000000000000000000000004512355066767017727 0ustar0000000000000000x { import "pathological.cfg" } configurator-0.3.0.0/tests/resources/interp.cfg0000644000000000000000000000065412355066767017724 0ustar0000000000000000services = "$(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" } } } configurator-0.3.0.0/tests/resources/pathological.cfg0000644000000000000000000000034112355066767021062 0ustar0000000000000000# 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"