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