diff --git a/Data/Configurator.hs b/Data/Configurator.hs new file mode 100644 --- /dev/null +++ b/Data/Configurator.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards, + ScopedTypeVariables #-} + +-- | +-- 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 + + -- * 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. diff --git a/Data/Configurator/Instances.hs b/Data/Configurator/Instances.hs new file mode 100644 --- /dev/null +++ b/Data/Configurator/Instances.hs @@ -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 diff --git a/Data/Configurator/Parser.hs b/Data/Configurator/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/Configurator/Parser.hs @@ -0,0 +1,160 @@ +{-# 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 <$> 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 diff --git a/Data/Configurator/Types.hs b/Data/Configurator/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Configurator/Types.hs @@ -0,0 +1,23 @@ +-- | +-- 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(cfgPaths) + , Name + , Value(..) + , Configured(..) + -- * Notification of configuration changes + , Pattern + , ChangeHandler + ) where + +import Data.Configurator.Types.Internal diff --git a/Data/Configurator/Types/Internal.hs b/Data/Configurator/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Configurator/Types/Internal.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | +-- 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 + ( + 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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -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, +. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/configurator.cabal b/configurator.cabal new file mode 100644 --- /dev/null +++ b/configurator.cabal @@ -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 +maintainer: Bryan O'Sullivan +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 + . + +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 diff --git a/tests/TestLoad.hs b/tests/TestLoad.hs new file mode 100644 --- /dev/null +++ b/tests/TestLoad.hs @@ -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 diff --git a/tests/TestReload.hs b/tests/TestReload.hs new file mode 100644 --- /dev/null +++ b/tests/TestReload.hs @@ -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