configurator 0.0.1.1 → 0.1.0.0

raw patch · 8 files changed

+299/−103 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Configurator.hs +118/−53
• Data/Configurator/Types.hs +1/−1
• Data/Configurator/Types/Internal.hs +9/−4
• configurator.cabal +1/−1
• tests/Setup.hs +2/−0
• tests/Test.hs +168/−0
• tests/TestLoad.hs +0/−14
• tests/TestReload.hs +0/−30

@@ -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

@@ -11,7 +11,7 @@ module Data.Configurator.Types     (       AutoConfig(..)-    , Config(cfgPaths)+    , Config     , Name     , Value(..)     , Configured(..)

@@ -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)

@@ -1,5 +1,5 @@ name:            configurator-version:         0.0.1.1+version:         0.1.0.0 license:         BSD3 license-file:    LICENSE category:        Configuration, Data

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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+

@@ -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

@@ -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