diff --git a/Data/Configurator.hs b/Data/Configurator.hs --- a/Data/Configurator.hs +++ b/Data/Configurator.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards, - ScopedTypeVariables #-} + ScopedTypeVariables, TupleSections #-} -- | -- Module: Data.Configurator @@ -36,6 +36,7 @@ Worth(..) -- * Loading configuration data , autoReload + , autoReloadGroups , autoConfig , empty -- * Lookup functions @@ -49,7 +50,11 @@ , subscribe -- * Low-level loading functions , load + , loadGroups , reload + , subconfig + , addToConfig + , addGroupsToConfig -- * Helper functions , display , getMap @@ -63,7 +68,7 @@ import Data.Configurator.Parser (interp, topLevel) import Data.Configurator.Types.Internal import Data.IORef (atomicModifyIORef, newIORef, readIORef) -import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Monoid (mconcat) import Data.Text.Lazy.Builder (fromString, fromText, toLazyText) import Data.Text.Lazy.Builder.Int (decimal) @@ -87,11 +92,11 @@ let rewrap n = const n <$> path wpath = worth path path' <- rewrap <$> interpolate wpath H.empty - ds <- loadOne (T.unpack <$> path') + 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 $ ds - + foldM go seen' . filter notSeen . importsOf wpath $ ds + -- | Create a 'Config' from the contents of the named files. Throws an -- exception on error, such as if files do not exist or contain errors. -- @@ -99,29 +104,64 @@ -- first time they are opened, so you can specify a file name such as -- @\"$(HOME)/myapp.cfg\"@. load :: [Worth FilePath] -> IO Config -load = load' Nothing +load files = fmap (Config "") $ load' Nothing (map (\f -> ("", f)) files) -load' :: Maybe AutoConfig -> [Worth FilePath] -> IO Config +-- | Create a 'Config' from the contents of the named files, placing them +-- into named prefixes. If a prefix is non-empty, it should end in a +-- dot. +loadGroups :: [(Name, Worth FilePath)] -> IO Config +loadGroups files = fmap (Config "") $ load' Nothing files + +load' :: Maybe AutoConfig -> [(Name, Worth FilePath)] -> IO BaseConfig load' auto paths0 = do - let paths = map (fmap T.pack) paths0 - ds <- loadFiles paths + 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 Config { + return BaseConfig { cfgAuto = auto - , cfgPaths = H.keys ds + , cfgPaths = p , cfgMap = m , cfgSubs = s } +-- | Gives a 'Config' corresponding to just a single group of the original +-- 'Config'. The subconfig can be used just like the original 'Config', but +-- see the documentation for 'reload'. +subconfig :: Name -> Config -> Config +subconfig g (Config root cfg) = Config (T.concat [root, g, "."]) cfg + -- | Forcibly reload a 'Config'. Throws an exception on error, such as --- if files no longer exist or contain errors. +-- if files no longer exist or contain errors. If the provided 'Config' is +-- a 'subconfig', this will reload the entire top-level configuration, not just +-- the local section. reload :: Config -> IO () -reload cfg@Config{..} = do - m' <- flatten cfgPaths =<< loadFiles cfgPaths +reload (Config _ cfg@BaseConfig{..}) = reloadBase cfg + +reloadBase :: BaseConfig -> IO () +reloadBase cfg@BaseConfig{..} = do + paths <- readIORef cfgPaths + m' <- flatten paths =<< loadFiles (map snd paths) m <- atomicModifyIORef cfgMap $ \m -> (m', m) notifySubscribers cfg m m' =<< readIORef cfgSubs +-- | Add additional files to a 'Config', causing it to be reloaded to add +-- their contents. +addToConfig :: [Worth FilePath] -> Config -> IO () +addToConfig paths0 cfg = addGroupsToConfig (map (\x -> ("",x)) paths0) cfg + +-- | Add additional files to named groups in a 'Config', causing it to be +-- reloaded to add their contents. If the prefixes are non-empty, they should +-- end in dots. +addGroupsToConfig :: [(Name, Worth FilePath)] -> Config -> IO () +addGroupsToConfig paths0 (Config root cfg@BaseConfig{..}) = do + let fix (x,y) = (root `T.append` x, fmap T.pack y) + paths = map fix paths0 + atomicModifyIORef cfgPaths $ \prev -> (prev ++ paths, ()) + reloadBase cfg + -- | Defaults for automatic 'Config' reloading when using -- 'autoReload'. The 'interval' is one second, while the 'onError' -- action ignores its argument and does nothing. @@ -151,19 +191,25 @@ -> [Worth FilePath] -- ^ Configuration files to load. -> IO (Config, ThreadId) -autoReload AutoConfig{..} _ - | interval < 1 = error "autoReload: negative interval" -autoReload _ [] = error "autoReload: no paths to load" -autoReload auto@AutoConfig{..} paths = do +autoReload auto paths = autoReloadGroups auto (map (\x -> ("", x)) paths) + +autoReloadGroups :: AutoConfig + -> [(Name, Worth FilePath)] + -> IO (Config, ThreadId) +autoReloadGroups AutoConfig{..} _ + | interval < 1 = error "autoReload: negative interval" +autoReloadGroups _ [] = error "autoReload: no paths to load" +autoReloadGroups auto@AutoConfig{..} paths = do cfg <- load' (Just auto) paths - let loop meta = do + let files = map snd paths + loop meta = do threadDelay (max interval 1 * 1000000) - meta' <- getMeta paths + meta' <- getMeta files if meta' == meta then loop meta - else (reload cfg `catch` onError) >> loop meta' - tid <- forkIO $ loop =<< getMeta paths - return (cfg, tid) + else (reloadBase cfg `catch` onError) >> loop meta' + tid <- forkIO $ loop =<< getMeta files + return (Config "" cfg, tid) -- | Save both a file's size and its last modification date, so we -- have a better chance of detecting a modification on a crappy @@ -180,15 +226,15 @@ -- the value can be 'convert'ed to the desired type, return the -- converted value, otherwise 'Nothing'. lookup :: Configured a => Config -> Name -> IO (Maybe a) -lookup Config{..} name = - (join . fmap convert . H.lookup name) <$> readIORef cfgMap +lookup (Config root BaseConfig{..}) name = + (join . fmap convert . H.lookup (root `T.append` name)) <$> readIORef cfgMap -- | Look up a name in the given 'Config'. If a binding exists, and -- the value can be 'convert'ed to the desired type, return the -- converted value, otherwise throw a 'KeyError'. require :: Configured a => Config -> Name -> IO a -require Config{..} name = do - val <- (join . fmap convert . H.lookup name) <$> readIORef cfgMap +require cfg name = do + val <- lookup cfg name case val of Just v -> return v _ -> throwIO . KeyError $ name @@ -205,27 +251,33 @@ -- | Perform a simple dump of a 'Config' to @stdout@. display :: Config -> IO () -display Config{..} = print =<< readIORef cfgMap +display (Config root BaseConfig{..}) = print . (root,) =<< readIORef cfgMap -- | Fetch the 'H.HashMap' that maps names to values. getMap :: Config -> IO (H.HashMap Name Value) -getMap = readIORef . cfgMap +getMap = readIORef . cfgMap . baseCfg -flatten :: [Worth Path] -> H.HashMap (Worth Path) [Directive] -> IO (H.HashMap Name Value) -flatten roots files = foldM (directive "") H.empty . - concat . catMaybes . map (`H.lookup` files) $ roots +flatten :: [(Name, Worth Path)] + -> H.HashMap (Worth Path) [Directive] + -> IO (H.HashMap Name Value) +flatten roots files = foldM doPath H.empty roots where - directive pfx m (Bind name (String value)) = do + 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 value m return $! H.insert (T.append pfx name) (String v) m - directive pfx m (Bind name value) = + directive pfx _ m (Bind name value) = return $! H.insert (T.append pfx name) value m - directive pfx m (Group name xs) = foldM (directive pfx') m xs + directive pfx f m (Group name xs) = foldM (directive pfx' f) m xs where pfx' = T.concat [pfx, name, "."] - directive pfx m (Import path) = - case H.lookup (Required path) files of - Just ds -> foldM (directive pfx) m ds - _ -> return m + directive pfx f m (Import path) = + let f' = relativize f path + in case H.lookup (Required (relativize f path)) files of + Just ds -> foldM (directive pfx f') m ds + _ -> return m interpolate :: T.Text -> H.HashMap Name Value -> IO T.Text interpolate s env @@ -248,12 +300,18 @@ throwIO . ParseError "" $ "no such variable " ++ show name Right x -> return (fromString x) -importsOf :: [Directive] -> [Worth Path] -importsOf (Import path : xs) = Required path : importsOf xs -importsOf (Group _ ys : xs) = importsOf ys ++ importsOf xs -importsOf (_ : xs) = importsOf xs -importsOf _ = [] +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 @@ -274,14 +332,18 @@ -- when any change occurs to a configuration property matching the -- supplied pattern. subscribe :: Config -> Pattern -> ChangeHandler -> IO () -subscribe Config{..} pat act = do +subscribe (Config root BaseConfig{..}) pat act = do m' <- atomicModifyIORef cfgSubs $ \m -> - let m' = H.insertWith (++) pat [act] m in (m', m') + let m' = H.insertWith (++) (localPattern root pat) [act] m in (m', m') evaluate m' >> return () -notifySubscribers :: Config -> H.HashMap Name Value -> H.HashMap Name Value +localPattern :: Name -> Pattern -> Pattern +localPattern pfx (Exact s) = Exact (pfx `T.append` s) +localPattern pfx (Prefix s) = Prefix (pfx `T.append` s) + +notifySubscribers :: BaseConfig -> H.HashMap Name Value -> H.HashMap Name Value -> H.HashMap Pattern [ChangeHandler] -> IO () -notifySubscribers Config{..} m m' subs = H.foldrWithKey go (return ()) subs +notifySubscribers BaseConfig{..} m m' subs = H.foldrWithKey go (return ()) subs where changedOrGone = H.foldrWithKey check [] m where check n v nvs = case H.lookup n m' of @@ -306,12 +368,13 @@ -- | A completely empty configuration. empty :: Config -empty = unsafePerformIO $ do +empty = Config "" $ unsafePerformIO $ do + p <- newIORef [] m <- newIORef H.empty s <- newIORef H.empty - return Config { + return BaseConfig { cfgAuto = Nothing - , cfgPaths = [] + , cfgPaths = p , cfgMap = m , cfgSubs = s } @@ -427,8 +490,10 @@ -- -- > import "$(HOME)/etc/myapp.cfg" -- --- It is an error for an @import@ directive to name a file that does --- not exist, cannot be read, or contains errors. +-- 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 diff --git a/Data/Configurator/Types.hs b/Data/Configurator/Types.hs --- a/Data/Configurator/Types.hs +++ b/Data/Configurator/Types.hs @@ -11,7 +11,7 @@ module Data.Configurator.Types ( AutoConfig(..) - , Config(cfgPaths) + , Config , Name , Value(..) , Configured(..) diff --git a/Data/Configurator/Types/Internal.hs b/Data/Configurator/Types/Internal.hs --- a/Data/Configurator/Types/Internal.hs +++ b/Data/Configurator/Types/Internal.hs @@ -12,7 +12,8 @@ module Data.Configurator.Types.Internal ( - Config(..) + BaseConfig(..) + , Config(..) , Configured(..) , AutoConfig(..) , Worth(..) @@ -55,14 +56,18 @@ instance (Hashable a) => Hashable (Worth a) where hash = hash . worth --- | Configuration data. -data Config = Config { +-- | Global configuration data. This is the top-level config from which +-- 'Config' values are derived by choosing a root location. +data BaseConfig = BaseConfig { cfgAuto :: Maybe AutoConfig - , cfgPaths :: [Worth Path] + , cfgPaths :: IORef [(Name, Worth Path)] -- ^ The files from which the 'Config' was loaded. , cfgMap :: IORef (H.HashMap Name Value) , cfgSubs :: IORef (H.HashMap Pattern [ChangeHandler]) } + +-- | Configuration data. +data Config = Config { root :: Text, baseCfg :: BaseConfig } instance Functor Worth where fmap f (Required a) = Required (f a) diff --git a/configurator.cabal b/configurator.cabal --- a/configurator.cabal +++ b/configurator.cabal @@ -1,5 +1,5 @@ name: configurator -version: 0.0.1.1 +version: 0.1.0.0 license: BSD3 license-file: LICENSE category: Configuration, Data diff --git a/tests/Setup.hs b/tests/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Prelude hiding (lookup) + +import Control.Concurrent +import Control.Exception +import Control.Monad +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Configurator +import Data.Configurator.Types +import Data.Functor +import Data.Int +import Data.Maybe +import Data.Text (Text) +import Data.Word +import System.Directory +import System.Environment +import System.IO +import Test.HUnit + +main :: IO () +main = runTestTT tests >> return () + +tests :: Test +tests = TestList [ + "load" ~: loadTest, + "types" ~: typesTest, + "interp" ~: interpTest, + "import" ~: importTest, + "reload" ~: reloadTest + ] + +withLoad :: [Worth FilePath] -> (Config -> IO ()) -> IO () +withLoad files t = do + mb <- try $ load files + case mb of + Left (err :: SomeException) -> assertFailure (show err) + Right cfg -> t cfg + +withReload :: [Worth FilePath] -> ([Maybe FilePath] -> Config -> IO ()) -> IO () +withReload files t = do + tmp <- getTemporaryDirectory + temps <- forM files $ \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 + +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 [Required "resources/pathological.cfg"] $ \cfg -> do + aa <- lookup cfg "aa" + assertEqual "int property" aa $ (Just 1 :: Maybe Int) + + ab <- lookup cfg "ab" + assertEqual "string property" ab (Just "foo" :: Maybe Text) + + acx <- lookup cfg "ac.x" + assertEqual "nested int" acx (Just 1 :: Maybe Int) + + acy <- lookup cfg "ac.y" + assertEqual "nested bool" acy (Just True :: Maybe Bool) + + ad <- lookup cfg "ad" + assertEqual "simple bool" ad (Just False :: Maybe Bool) + + ae <- lookup cfg "ae" + assertEqual "simple int 2" ae (Just 1 :: Maybe Int) + + af <- lookup cfg "af" + assertEqual "list property" af (Just (2,3) :: Maybe (Int,Int)) + + deep <- lookup cfg "ag.q-e.i_u9.a" + assertEqual "deep bool" deep (Just False :: Maybe Bool) + +typesTest :: Assertion +typesTest = withLoad [Required "resources/pathological.cfg"] $ \ cfg -> do + asInt <- lookup cfg "aa" :: IO (Maybe Int) + assertEqual "int" asInt (Just 1) + + asInteger <- lookup cfg "aa" :: IO (Maybe Integer) + assertEqual "int" asInteger (Just 1) + + asWord <- lookup cfg "aa" :: IO (Maybe Word) + assertEqual "int" asWord (Just 1) + + asInt8 <- lookup cfg "aa" :: IO (Maybe Int8) + assertEqual "int8" asInt8 (Just 1) + + asInt16 <- lookup cfg "aa" :: IO (Maybe Int16) + assertEqual "int16" asInt16 (Just 1) + + asInt32 <- lookup cfg "aa" :: IO (Maybe Int32) + assertEqual "int32" asInt32 (Just 1) + + asInt64 <- lookup cfg "aa" :: IO (Maybe Int64) + assertEqual "int64" asInt64 (Just 1) + + asWord8 <- lookup cfg "aa" :: IO (Maybe Word8) + assertEqual "word8" asWord8 (Just 1) + + asWord16 <- lookup cfg "aa" :: IO (Maybe Word16) + assertEqual "word16" asWord16 (Just 1) + + asWord32 <- lookup cfg "aa" :: IO (Maybe Word32) + assertEqual "word32" asWord32 (Just 1) + + asWord64 <- lookup cfg "aa" :: IO (Maybe Word64) + assertEqual "word64" asWord64 (Just 1) + + asTextBad <- lookup cfg "aa" :: IO (Maybe Text) + assertEqual "word64" asTextBad Nothing + + asTextGood <- lookup cfg "ab" :: IO (Maybe Text) + assertEqual "word64" asTextGood (Just "foo") + +interpTest :: Assertion +interpTest = withLoad [Required "resources/pathological.cfg"] $ \ cfg -> do + home <- getEnv "HOME" + cfgHome <- lookup cfg "ba" + assertEqual "home interp" (Just home) cfgHome + +importTest :: Assertion +importTest = withLoad [Required "resources/import.cfg"] $ \ cfg -> do + aa <- lookup cfg "x.aa" :: IO (Maybe Int) + assertEqual "simple" aa (Just 1) + acx <- lookup cfg "x.ac.x" :: IO (Maybe Int) + assertEqual "nested" acx (Just 1) + +reloadTest :: Assertion +reloadTest = withReload [Required "resources/pathological.cfg"] $ \[Just f] cfg -> do + aa <- lookup cfg "aa" + assertEqual "simple property 1" aa $ Just (1 :: Int) + + dongly <- newEmptyMVar + wongly <- newEmptyMVar + subscribe cfg "dongly" $ \ _ _ -> putMVar dongly () + subscribe cfg "wongly" $ \ _ _ -> putMVar wongly () + L.appendFile f "\ndongly = 1" + r1 <- takeMVarTimeout 2000 dongly + assertEqual "notify happened" r1 (Just ()) + r2 <- takeMVarTimeout 2000 wongly + assertEqual "notify not happened" r2 Nothing + diff --git a/tests/TestLoad.hs b/tests/TestLoad.hs deleted file mode 100644 --- a/tests/TestLoad.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -import Control.Exception (SomeException, try) -import Control.Monad (forM_) -import Data.Configurator -import System.Environment - -main = do - args <- getArgs - putStrLn $ "files: " ++ show args - e <- try $ load args - case e of - Left (err::SomeException) -> putStrLn $ "error: " ++ show err - Right c -> putStr "ok: " >> display c diff --git a/tests/TestReload.hs b/tests/TestReload.hs deleted file mode 100644 --- a/tests/TestReload.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Control.Exception -import Control.Concurrent -import Data.Configurator -import Data.Configurator.Types -import qualified Data.ByteString.Lazy.Char8 as L -import System.Environment -import System.Directory -import Control.Monad -import System.IO - -main = do - args <- getArgs - tmpDir <- getTemporaryDirectory - temps <- forM args $ \arg -> do - (p,h) <- openBinaryTempFile tmpDir "test.cfg" - L.hPut h =<< L.readFile arg - hClose h - return p - flip finally (mapM_ removeFile temps) $ do - done <- newEmptyMVar - let myConfig = autoConfig { - onError = \e -> hPutStrLn stderr $ "uh oh: " ++ show e - } - (c,_) <- autoReload myConfig temps - display c - subscribe c "dongly" $ \n v -> print (n,v) >> putMVar done () - forM_ temps $ \t -> L.appendFile t "\ndongly = 1\n" - takeMVar done