diff --git a/Data/Configurator.hs b/Data/Configurator.hs --- a/Data/Configurator.hs +++ b/Data/Configurator.hs @@ -63,11 +63,12 @@ import Control.Applicative ((<$>)) import Control.Concurrent (ThreadId, forkIO, threadDelay) import Control.Exception (SomeException, evaluate, handle, throwIO, try) -import Control.Monad (foldM, forM, forM_, join, when) +import Control.Monad (foldM, forM, forM_, join, when, msum) import Data.Configurator.Instances () import Data.Configurator.Parser (interp, topLevel) import Data.Configurator.Types.Internal import Data.IORef (atomicModifyIORef, newIORef, readIORef) +import Data.List (tails) import Data.Maybe (fromMaybe, isJust) import Data.Monoid (mconcat) import Data.Ratio (denominator, numerator) @@ -94,7 +95,7 @@ go seen path = do let rewrap n = const n <$> path wpath = worth path - path' <- rewrap <$> interpolate wpath H.empty + path' <- rewrap <$> interpolate "" wpath H.empty ds <- loadOne (T.unpack <$> path') let !seen' = H.insert path ds seen notSeen n = not . isJust . H.lookup n $ seen @@ -270,7 +271,7 @@ Just ds -> foldM (directive pfx (worth f)) m ds directive pfx _ m (Bind name (String value)) = do - v <- interpolate value m + v <- interpolate pfx value m return $! H.insert (T.append pfx name) (String v) m directive pfx _ m (Bind name value) = return $! H.insert (T.append pfx name) value m @@ -282,17 +283,26 @@ Just ds -> foldM (directive pfx f') m ds _ -> return m -interpolate :: T.Text -> H.HashMap Name Value -> IO T.Text -interpolate s env +interpolate :: T.Text -> T.Text -> H.HashMap Name Value -> IO T.Text +interpolate pfx s env | "$" `T.isInfixOf` s = case T.parseOnly interp s of Left err -> throwIO $ ParseError "" err Right xs -> (L.toStrict . toLazyText . mconcat) <$> mapM interpret xs | otherwise = return s where + lookupEnv name = msum $ map (flip H.lookup env) fullnames + where fullnames = map (T.intercalate ".") -- ["a.b.c.x","a.b.x","a.x","x"] + . map (reverse . (name:)) -- [["a","b","c","x"],["a","b","x"],["a","x"],["x"]] + . tails -- [["c","b","a"],["b","a"],["a"],[]] + . reverse -- ["c","b","a"] + . filter (not . T.null) -- ["a","b","c"] + . T.split (=='.') -- ["a","b","c",""] + $ pfx -- "a.b.c." + interpret (Literal x) = return (fromText x) interpret (Interpolate name) = - case H.lookup name env of + case lookupEnv name of Just (String x) -> return (fromText x) Just (Number r) | denominator r == 1 -> return (decimal $ numerator r) diff --git a/Data/Configurator/Instances.hs b/Data/Configurator/Instances.hs --- a/Data/Configurator/Instances.hs +++ b/Data/Configurator/Instances.hs @@ -91,8 +91,11 @@ convert (String v) = Just v convert _ = Nothing -instance Configured [Char] where - convert = fmap T.unpack . convert +instance Configured Char where + convert (String txt) | T.length txt == 1 = Just $ T.head txt + convert _ = Nothing + + convertList = fmap T.unpack . convert instance Configured L.Text where convert = fmap L.fromStrict . convert diff --git a/Data/Configurator/Types.hs b/Data/Configurator/Types.hs --- a/Data/Configurator/Types.hs +++ b/Data/Configurator/Types.hs @@ -14,7 +14,7 @@ , Config , Name , Value(..) - , Configured(..) + , Configured, convert , Worth(..) -- * Exceptions , ConfigError(..) 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 @@ -131,6 +131,13 @@ class Configured a where convert :: Value -> Maybe a + convertList :: Value -> Maybe [a] + convertList (List xs) = mapM convert xs + convertList _ = Nothing + +instance Configured a => Configured [a] where + convert = convertList + -- | An error occurred while processing a configuration file. data ConfigError = ParseError FilePath String deriving (Show, Typeable) diff --git a/configurator.cabal b/configurator.cabal --- a/configurator.cabal +++ b/configurator.cabal @@ -1,13 +1,14 @@ name: configurator -version: 0.2.0.2 +version: 0.3.0.0 license: BSD3 license-file: LICENSE category: Configuration, Data copyright: Copyright 2011 MailRank, Inc. + Copyright 2011-2014 Bryan O'Sullivan author: Bryan O'Sullivan maintainer: Bryan O'Sullivan stability: experimental -tested-with: GHC == 7.0.3 +tested-with: GHC == 7.0, GHC == 7.2, GHC == 7.4, GHC == 7.6, GHC == 7.8 synopsis: Configuration management cabal-version: >= 1.8 homepage: http://github.com/bos/configurator @@ -38,11 +39,13 @@ extra-source-files: README.markdown - tests/*.hs +data-files: tests/resources/*.cfg + flag developer description: operate in developer mode default: False + manual: True library exposed-modules: @@ -62,7 +65,7 @@ hashable, text >= 0.11.1.0, unix-compat, - unordered-containers + unordered-containers if flag(developer) ghc-options: -Werror @@ -77,3 +80,19 @@ source-repository head type: mercurial location: http://bitbucket.org/bos/configurator + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: tests + build-depends: + HUnit, + base, + bytestring, + configurator, + directory, + filepath, + test-framework, + test-framework-hunit, + text + ghc-options: -Wall -fno-warn-unused-do-bind diff --git a/tests/Setup.hs b/tests/Setup.hs deleted file mode 100644 --- a/tests/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -18,32 +18,36 @@ import Data.Word import System.Directory import System.Environment +import System.FilePath import System.IO -import Test.HUnit +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) main :: IO () -main = runTestTT tests >> return () +main = defaultMain tests -tests :: Test -tests = TestList [ - "load" ~: loadTest, - "types" ~: typesTest, - "interp" ~: interpTest, - "import" ~: importTest, - "reload" ~: reloadTest +tests :: [Test] +tests = + [ testCase "load" loadTest + , testCase "types" typesTest + , testCase "interp" interpTest + , testCase "scoped-interp" scopedInterpTest + , testCase "import" importTest + , testCase "reload" reloadTest ] -withLoad :: [Worth FilePath] -> (Config -> IO ()) -> IO () -withLoad files t = do - mb <- try $ load files +withLoad :: FilePath -> (Config -> IO ()) -> IO () +withLoad name t = do + mb <- try $ load (testFile name) case mb of Left (err :: SomeException) -> assertFailure (show err) Right cfg -> t cfg -withReload :: [Worth FilePath] -> ([Maybe FilePath] -> Config -> IO ()) -> IO () -withReload files t = do +withReload :: FilePath -> ([Maybe FilePath] -> Config -> IO ()) -> IO () +withReload name t = do tmp <- getTemporaryDirectory - temps <- forM files $ \f -> do + temps <- forM (testFile name) $ \f -> do exists <- doesFileExist (worth f) if exists then do @@ -59,6 +63,9 @@ 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 @@ -72,7 +79,8 @@ takeMVar w loadTest :: Assertion -loadTest = withLoad [Required "resources/pathological.cfg"] $ \cfg -> do +loadTest = + withLoad "pathological.cfg" $ \cfg -> do aa <- lookup cfg "aa" assertEqual "int property" aa $ (Just 1 :: Maybe Int) @@ -98,7 +106,8 @@ assertEqual "deep bool" deep (Just False :: Maybe Bool) typesTest :: Assertion -typesTest = withLoad [Required "resources/pathological.cfg"] $ \ cfg -> do +typesTest = + withLoad "pathological.cfg" $ \cfg -> do asInt <- lookup cfg "aa" :: IO (Maybe Int) assertEqual "int" asInt (Just 1) @@ -133,26 +142,51 @@ assertEqual "word64" asWord64 (Just 1) asTextBad <- lookup cfg "aa" :: IO (Maybe Text) - assertEqual "word64" asTextBad Nothing + assertEqual "bad text" asTextBad Nothing asTextGood <- lookup cfg "ab" :: IO (Maybe Text) - assertEqual "word64" asTextGood (Just "foo") + assertEqual "good text" asTextGood (Just "foo") + asStringGood <- lookup cfg "ab" :: IO (Maybe String) + assertEqual "string" asStringGood (Just "foo") + + asInts <- lookup cfg "xs" :: IO (Maybe [Int]) + assertEqual "ints" asInts (Just [1,2,3]) + + asChar <- lookup cfg "c" :: IO (Maybe Char) + assertEqual "char" asChar (Just 'x') + interpTest :: Assertion -interpTest = withLoad [Required "resources/pathological.cfg"] $ \ cfg -> do +interpTest = + withLoad "pathological.cfg" $ \cfg -> do home <- getEnv "HOME" cfgHome <- lookup cfg "ba" assertEqual "home interp" (Just home) cfgHome +scopedInterpTest :: Assertion +scopedInterpTest = withLoad "interp.cfg" $ \cfg -> do + home <- getEnv "HOME" + + lookup cfg "myprogram.exec" + >>= assertEqual "myprogram.exec" (Just $ home++"/services/myprogram/myprogram") + + lookup cfg "myprogram.stdout" + >>= assertEqual "myprogram.stdout" (Just $ home++"/services/myprogram/stdout") + + lookup cfg "top.layer1.layer2.dir" + >>= assertEqual "nested scope" (Just $ home++"/top/layer1/layer2") + importTest :: Assertion -importTest = withLoad [Required "resources/import.cfg"] $ \ cfg -> do +importTest = + withLoad "import.cfg" $ \cfg -> do aa <- lookup cfg "x.aa" :: IO (Maybe Int) assertEqual "simple" aa (Just 1) acx <- lookup cfg "x.ac.x" :: IO (Maybe Int) assertEqual "nested" acx (Just 1) reloadTest :: Assertion -reloadTest = withReload [Required "resources/pathological.cfg"] $ \[Just f] cfg -> do +reloadTest = + withReload "pathological.cfg" $ \[Just f] cfg -> do aa <- lookup cfg "aa" assertEqual "simple property 1" aa $ Just (1 :: Int) @@ -165,4 +199,3 @@ 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,20 @@ +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,39 @@ +# 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"