Initial commit

.hgignore

@@ -0,0 +1,9 @@
+.*\.(?:aux|h[ip]|o|orig|out|pdf|prof|ps|rej)$
+^(?:dist|\.DS_Store)$
+
+syntax: glob
+cabal-dev
+*~
+.*.swp
+.\#*
+\#*

Data/Configurator.hs

@@ -0,0 +1,57 @@
+module Data.Configurator
+    (
+    ) where
+
+import Data.List
+import Control.Applicative
+import Control.Monad
+import qualified Data.Text.Lazy as L
+import qualified Data.Text.Lazy.IO as L
+import Data.Attoparsec.Text.Lazy
+import Data.Configurator.Parser
+import Data.Configurator.Types.Internal
+import System.IO
+import qualified Data.HashMap.Lazy as H
+import Data.Maybe
+import qualified Data.Text as T
+
+loadFiles :: [Path] -> IO (H.HashMap Path [Directive])
+loadFiles = foldM go H.empty
+ where
+   go seen path = do
+     ds <- loadOne (T.unpack path)
+     let seen' = H.insert path ds seen
+         notKnown n = not . isJust . H.lookup n $ seen
+     foldM go seen' . filter notKnown . importsOf $ ds
+
+gorb paths = do
+  ds <- loadFiles paths
+  return (flatten paths ds)
+
+flatten :: [Path] -> H.HashMap Path [Directive] -> H.HashMap Name Value
+flatten roots files = foldl' (directive "") H.empty .
+                      concat . catMaybes . map (`H.lookup` files) $ roots
+ where
+  directive prefix m (Bind name value) =
+      case value of
+        Group xs -> foldl' (directive prefix') m xs
+        v        -> H.insert (T.append prefix name) v m
+    where prefix' | T.null prefix = name `T.snoc` '.'
+                  | otherwise = T.concat [prefix, name, "."]
+  directive prefix m (Import path) =
+      case H.lookup path files of
+        Just ds -> foldl' (flob prefix) m ds
+        _       -> m
+
+importsOf :: [Directive] -> [Path]
+importsOf (Import path : xs)       = path : importsOf xs
+importsOf (Bind _ (Group ys) : xs) = importsOf ys ++ importsOf xs
+importsOf (_ : xs)                 = importsOf xs
+importsOf _                        = []
+
+loadOne :: FilePath -> IO [Directive]
+loadOne path = do
+  s <- L.readFile path
+  case eitherResult $ parse topLevel s of
+    Left err -> hPutStrLn stderr err >> return []
+    Right ds -> return ds

Data/Configurator/Parser.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Configurator.Parser
+    (
+      topLevel
+    ) where
+
+import Control.Applicative
+import Control.Monad (when)
+import Data.Attoparsec.Text as A
+import Data.Bits (shiftL)
+import Data.Char (chr, isAlpha, isAlphaNum)
+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 = seriesOf directive <* endOfInput
+
+directive :: Parser Directive
+directive = string "import" *> skipSpace *> (Import <$> string_)
+        <|> Bind <$> (ident <* skipSpace) <*>
+                     ((char '=' *> skipSpace *> atom <* skipHSpace) <|>
+                      (brackets '{' '}' (Group <$> seriesOf directive)))
+
+seriesOf :: Parser a -> Parser [a]
+seriesOf p =
+    (p <* skipHSpace) `sepBy` (endItem <* skipSpace) <* optional endItem
+  where endItem = satisfy $ \c -> c == '\n' || c == ';'
+
+skipHSpace :: Parser ()
+skipHSpace = skipWhile $ \c -> c == ' ' || c == '\t'
+
+ident :: Parser Text
+ident = do
+  n <- T.cons <$> satisfy isAlpha <*> A.takeWhile isCont
+  when (n == "import") $
+    fail $ "reserved word (" ++ show n ++ ") used as identifier"
+  return n
+ where
+  isCont c = isAlphaNum c || c == '_' || c == '-'
+
+atom :: Parser Value
+atom = mconcat [
+          string "on" *> pure (Bool True)
+        , string "off" *> pure (Bool False)
+        , string "true" *> pure (Bool True)
+        , string "false" *> pure (Bool False)
+        , String <$> string_
+        , list
+        , Number <$> decimal
+        ]
+
+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 *> skipSpace *> p <* skipSpace <* char close
+
+list :: Parser Value
+list = List <$> brackets '[' ']'
+       ((atom <* skipSpace) `sepBy` (char ',' <* skipSpace))
+
+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 <- A.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"
+

Data/Configurator/Types/Internal.hs

@@ -0,0 +1,23 @@
+module Data.Configurator.Types.Internal
+    (
+      Name
+    , Path
+    , Directive(..)
+    , Value(..)
+    ) where
+
+import Data.Text (Text)
+
+type Name = Text
+type Path = Text
+
+data Directive = Import Path
+               | Bind Text Value
+                 deriving (Eq, Show)
+
+data Value = Bool Bool
+           | String Text
+           | Number Int
+           | List [Value]
+           | Group [Directive]
+             deriving (Eq, Show)

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.

README.markdown

@@ -0,0 +1,27 @@
+# Welcome to configurator
+
+This is a library for configuring Haskell daemons and programs.
+
+# Join in!
+
+We are happy to receive bug reports, fixes, documentation enhancements,
+and other improvements.
+
+Please report bugs via the
+[github issue tracker](http://github.com/mailrank/configurator/issues).
+
+Master [git repository](http://github.com/mailrank/configurator):
+
+* `git clone git://github.com/mailrank/configurator.git`
+
+There's also a [Mercurial mirror](http://bitbucket.org/bos/configurator):
+
+* `hg clone http://bitbucket.org/bos/configurator`
+
+(You can create and contribute changes using either git or Mercurial.)
+
+Authors
+-------
+
+This library is written and maintained by Bryan O'Sullivan,
+<bos@mailrank.com>.

Setup.lhs

@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain

configurator.cabal

@@ -0,0 +1,52 @@
+name:            configurator
+version:         0.0.0.1
+license:         BSD3
+license-file:    LICENSE
+category:        Configuration, Data
+copyright:       Copyright 2011 MailRank, Inc.
+author:          Bryan O'Sullivan <bos@mailrank.com>
+maintainer:      Bryan O'Sullivan <bos@mailrank.com>
+stability:       experimental
+tested-with:     GHC == 7.0.3
+synopsis:        Configuration management
+cabal-version:   >= 1.8
+homepage:        http://github.com/mailrank/configurator
+bug-reports:     http://github.com/mailrank/configurator/issues
+build-type:      Simple
+description:
+  A configuration management library for programs and daemons.
+
+extra-source-files:
+    README.markdown
+
+flag developer
+  description: operate in developer mode
+  default: False
+
+library
+  exposed-modules:
+    Data.Configurator
+
+  other-modules:
+    Data.Configurator.Parser
+    Data.Configurator.Types.Internal
+
+  build-depends:
+    attoparsec-text >= 0.8.5.0,
+    base == 4.*,
+    text >= 0.11.0.2,
+    unordered-containers	
+
+  if flag(developer)
+    ghc-options: -Werror
+    ghc-prof-options: -auto-all
+
+  ghc-options:      -Wall
+
+source-repository head
+  type:     git
+  location: http://github.com/mailrank/configurator
+
+source-repository head
+  type:     mercurial
+  location: http://bitbucket.org/bos/configurator