Permalink
Browse files

Initial commit

  • Loading branch information...
0 parents commit 758c3e7d5211cb185bc235423acb884fe3858e0b @bos committed May 27, 2011
Showing with 311 additions and 0 deletions.
  1. +9 −0 .hgignore
  2. +57 −0 Data/Configurator.hs
  3. +110 −0 Data/Configurator/Parser.hs
  4. +23 −0 Data/Configurator/Types/Internal.hs
  5. +30 −0 LICENSE
  6. +27 −0 README.markdown
  7. +3 −0 Setup.lhs
  8. +52 −0 configurator.cabal
9 .hgignore
@@ -0,0 +1,9 @@
+.*\.(?:aux|h[ip]|o|orig|out|pdf|prof|ps|rej)$
+^(?:dist|\.DS_Store)$
+
+syntax: glob
+cabal-dev
+*~
+.*.swp
+.\#*
+\#*
57 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
110 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"
+
23 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)
30 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.
27 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>.
3 Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
52 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

0 comments on commit 758c3e7

Please sign in to comment.