Commits

Bryan O'Sullivan committed 224c512

Substantial progress in fleshing things out.

Comments (0)

Files changed (7)

Data/Configurator.hs

-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
+
+-- |
+-- Module:      Data.Configurator
+-- Copyright:   (c) 2011 MailRank, Inc.
+-- License:     BSD3
+-- Maintainer:  Bryan O'Sullivan <bos@mailrank.com>
+-- Stability:   experimental
+-- Portability: portable
+--
+-- Types for working with configuration files.
 
 module Data.Configurator
     (
-      load
+    -- * Loading configuration data
+      autoReload
+    , autoConfig
+    -- * Lookup functions
+    , lookup
+    , lookupDefault
+    -- * Low-level loading functions
+    , load
+    , reload
+    -- * Helper functions
+    , display
+    , getMap
     ) where
 
-import Data.List
-import Control.Exception
-import Control.Applicative
-import Data.Monoid
-import Control.Monad
+import Control.Applicative ((<$>))
+import Control.Concurrent (ThreadId, forkIO, threadDelay)
+import Control.Exception (SomeException, catch, evaluate, throwIO, try)
+import Control.Monad (foldM, join)
+import Data.Configurator.Instances ()
+import Data.Configurator.Parser (interp, topLevel)
+import Data.Configurator.Types.Internal
+import Data.IORef (newIORef, readIORef, writeIORef)
+import Data.List (foldl')
+import Data.Maybe (catMaybes, fromMaybe, isJust)
+import Data.Monoid (mconcat)
+import Data.Text.Lazy.Builder (fromString, fromText, toLazyText)
+import Data.Text.Lazy.Builder.Int (decimal)
+import Prelude hiding (catch, lookup)
+import System.Directory (getModificationTime)
+import System.Environment (getEnv)
+import System.Time (ClockTime(..))
+import qualified Data.Attoparsec.Text as T
+import qualified Data.Attoparsec.Text.Lazy as L
+import qualified Data.HashMap.Lazy as H
+import qualified Data.Text as T
 import qualified Data.Text.Lazy as L
 import qualified Data.Text.Lazy.IO as L
-import Data.Text.Lazy.Builder.Int (decimal)
-import Data.Text.Lazy.Builder (fromString, fromText, toLazyText)
-import qualified Data.Attoparsec.Text.Lazy as L
-import qualified Data.Attoparsec.Text as T
-import System.Environment (getEnv)
-import Data.Configurator.Parser
-import Data.Configurator.Types.Internal
-import System.IO
-import qualified Data.HashMap.Lazy as H
-import Data.Maybe
-import Prelude hiding (catch)
-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)
+     ds <- loadOne . T.unpack =<< interpolate path H.empty
      let seen' = H.insert path ds seen
          notSeen n = not . isJust . H.lookup n $ seen
      foldM go seen' . filter notSeen . importsOf $ ds
   
-load :: [Path] -> IO (H.HashMap Name Value)
-load paths = do
+-- | 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.
+load :: [FilePath] -> IO Config
+load paths0 = do
+  let paths = map T.pack paths0
   ds <- loadFiles paths
-  return (flatten paths ds)
+  m <- newIORef $ flatten paths ds
+  return Config {
+               cfgPaths = paths
+             , cfgMap = m
+             }
+
+-- | Forcibly reload a 'Config'. Throws an exception on error, such as
+-- if files no longer exist or contain errors.
+reload :: Config -> IO ()
+reload Config{..} = writeIORef cfgMap . flatten cfgPaths =<< loadFiles cfgPaths
+
+-- | Defaults for automatic 'Config' reloading when using
+-- 'autoReload'.  The 'interval' is one second, while the 'onError'
+-- action ignores its argument and does nothing.
+autoConfig :: AutoConfig
+autoConfig = AutoConfig {
+               interval = 1
+             , onError = const $ return ()
+             }
+
+-- | Load a 'Config' from the given 'FilePath's.
+--
+-- At intervals, a thread checks for modifications to both the
+-- original files and any files they refer to in @import@ directives,
+-- and reloads the 'Config' if any files have been modified.
+--
+-- If the initial attempt to load the configuration files fails, an
+-- exception is thrown.  If the initial load succeeds, but a
+-- subsequent attempt fails, the 'onError' handler is invoked.
+autoReload :: AutoConfig
+           -- ^ Directions for when to reload and how to handle
+           -- errors.
+           -> [FilePath]
+           -- ^ Configuration files to load.
+           -> IO (Config, ThreadId)
+autoReload AutoConfig{..} _
+    | interval < 1 = error "autoReload: negative interval"
+autoReload _ []    = error "autoReload: no paths to load"
+autoReload AutoConfig{..} paths = do
+  cfg <- load paths
+  let loop newest = do
+        threadDelay (max interval 1 * 1000000)
+        newest' <- getNewest paths
+        if newest' == newest
+          then loop newest
+          else (reload cfg `catch` onError) >> loop newest'
+  tid <- forkIO $ loop =<< getNewest paths
+  return (cfg, tid)
+  
+getNewest :: [FilePath] -> IO ClockTime
+getNewest = flip foldM (TOD 0 0) $ \t -> fmap (max t) . getModificationTime
+
+lookup :: Configured a => Config -> Name -> IO (Maybe a)
+lookup Config{..} name =
+    (join . fmap convert . H.lookup name) <$> readIORef cfgMap
+
+lookupDefault :: Configured a => a -> Config -> Name -> IO a
+lookupDefault def cfg name = fromMaybe def <$> lookup cfg name
+
+-- | Perform a simple dump of a 'Config' to @stdout@.
+display :: Config -> IO ()
+display Config{..} = print =<< readIORef cfgMap
+
+-- | Fetch the 'H.HashMap' that maps names to values.
+getMap :: Config -> IO (H.HashMap Name Value)
+getMap = readIORef . cfgMap
 
 flatten :: [Path] -> H.HashMap Path [Directive] -> H.HashMap Name Value
 flatten roots files = foldl' (directive "") H.empty .

Data/Configurator/Instances.hs

+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Configurator.Instances () where
+
+import Control.Applicative
+import Data.Configurator.Types.Internal
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as L
+
+instance Configured Value where
+    convert = Just
+
+instance Configured Bool where
+    convert (Bool v) = Just v
+    convert _        = Nothing
+
+instance Configured Int where
+    convert (Number v) = Just v
+    convert _          = Nothing
+
+instance Configured T.Text where
+    convert (String v) = Just v
+    convert _          = Nothing
+
+instance Configured [Char] where
+    convert = fmap T.unpack . convert
+
+instance Configured L.Text where
+    convert = fmap L.fromStrict . convert
+
+instance Configured B.ByteString where
+    convert = fmap encodeUtf8 . convert
+
+instance Configured LB.ByteString where
+    convert = fmap (LB.fromChunks . (:[])) . convert
+
+instance (Configured a) => Configured [a] where
+    convert (List xs) = mapM convert xs
+    convert _         = Nothing
+
+instance (Configured a, Configured b) => Configured (a,b) where
+    convert (List [a,b]) = (,) <$> convert a <*> convert b
+    convert _            = Nothing
+
+instance (Configured a, Configured b, Configured c) => Configured (a,b,c) where
+    convert (List [a,b,c]) = (,,) <$> convert a <*> convert b <*> convert c
+    convert _              = Nothing
+
+instance (Configured a, Configured b, Configured c, Configured d)
+    => Configured (a,b,c,d) where
+    convert (List [a,b,c,d]) = (,,,) <$> convert a <*> convert b <*> convert c
+                                     <*> convert d
+    convert _                = Nothing

Data/Configurator/Parser.hs

 {-# LANGUAGE OverloadedStrings #-}
 
+-- |
+-- Module:      Data.Configurator.Parser
+-- Copyright:   (c) 2011 MailRank, Inc.
+-- License:     BSD3
+-- Maintainer:  Bryan O'Sullivan <bos@mailrank.com>
+-- Stability:   experimental
+-- Portability: portable
+--
+-- A parser for configuration files.
+
 module Data.Configurator.Parser
     (
       topLevel
 import Control.Monad (when)
 import Data.Attoparsec.Text as A
 import Data.Bits (shiftL)
-import Data.Char (chr, isAlpha, isAlphaNum)
+import Data.Char (chr, isAlpha, isAlphaNum, isSpace)
 import Data.Configurator.Types.Internal
 import Data.Monoid (Monoid(..))
 import Data.Text (Text)
 import qualified Data.Text.Lazy as L
 
 topLevel :: Parser [Directive]
-topLevel = seriesOf directive <* endOfInput
+topLevel = directives <* skipLWS <* endOfInput
   
 directive :: Parser Directive
 directive =
   mconcat [
-    string "import" *> skipSpace *> (Import <$> string_)
-  , Bind <$> try (ident <* skipSpace <* char '=' <* skipSpace)
-         <*> value <* skipHSpace
-  , Group <$> try (ident <* skipSpace <* char '{' <* skipSpace)
-          <*> seriesOf directive <* skipSpace <* char '}' <* skipHSpace
+    string "import" *> skipLWS *> (Import <$> string_)
+  , Bind <$> try (ident <* skipLWS <* char '=' <* skipLWS) <*> value
+  , Group <$> try (ident <* skipLWS <* char '{' <* skipLWS)
+          <*> directives <* skipLWS <* char '}'
   ]
 
-seriesOf :: Parser a -> Parser [a]
-seriesOf p =
-    (p <* skipHSpace) `sepBy` (endItem <* skipSpace) <* optional endItem
-  where endItem = satisfy $ \c -> c == '\n' || c == ';'
+directives :: Parser [Directive]
+directives = (skipLWS *> directive <* skipHWS) `sepBy`
+             (satisfy $ \c -> c == '\r' || c == '\n')
 
-skipHSpace :: Parser ()
-skipHSpace = skipWhile $ \c -> c == ' ' || c == '\t'
+data Skip = Space | Comment
+
+-- | Skip lines, comments, or horizontal white space.
+skipLWS :: Parser ()
+skipLWS = scan Space go *> pure ()
+  where go Space c | isSpace c = Just Space
+        go Space '#'           = Just Comment
+        go Space _             = Nothing
+        go Comment '\r'        = Just Space
+        go Comment '\n'        = Just Space
+        go Comment _           = Just Comment
+
+-- | Skip comments or horizontal white space.
+skipHWS :: Parser ()
+skipHWS = scan Space go *> pure ()
+  where go Space ' '           = Just Space
+        go Space '\t'          = Just Space
+        go Space '#'           = Just Comment
+        go Space _             = Nothing
+        go Comment '\r'        = Nothing
+        go Comment '\n'        = Nothing
+        go Comment _           = Just Comment
 
 ident :: Parser Name
 ident = do
         , String <$> string_
         , Number <$> decimal
         , List <$> brackets '[' ']'
-                   ((value <* skipSpace) `sepBy` (char ',' <* skipSpace))
+                   ((value <* skipLWS) `sepBy` (char ',' <* skipLWS))
         ]
 
 string_ :: Parser Text
   isChar _ c    = Just (c == '\\')
 
 brackets :: Char -> Char -> Parser a -> Parser a
-brackets open close p = char open *> skipSpace *> p <* skipSpace <* char close
+brackets open close p = char open *> skipLWS *> p <* char close
 
 embed :: Parser a -> Text -> Parser a
 embed p s = case parseOnly p s of
         then return $! chr (((a - 0xd800) `shiftL` 10) + (b - 0xdc00) + 0x10000)
         else fail "invalid UTF-16 surrogates"
                    
+-- | Parse a string interpolation spec.
+--
+-- The sequence @$$@ is treated as a single @$@ sign.  The sequence
+-- @$(@ begins a section to be interpolated, and @)@ ends it.
 interp :: Parser [Interp]
-interp = p []
+interp = reverse <$> p []
  where
   p acc = do
     h <- Literal <$> A.takeWhile (/='$')

Data/Configurator/Types.hs

+-- |
+-- Module:      Data.Configurator.Types
+-- Copyright:   (c) 2011 MailRank, Inc.
+-- License:     BSD3
+-- Maintainer:  Bryan O'Sullivan <bos@mailrank.com>
+-- Stability:   experimental
+-- Portability: portable
+--
+-- Types for working with configuration files.
+
+module Data.Configurator.Types
+    (
+      AutoConfig(..)
+    , Config(cfgPaths)
+    , Name
+    , Value
+    , Configured(..)
+    ) where
+
+import Data.Configurator.Types.Internal

Data/Configurator/Types/Internal.hs

 {-# LANGUAGE DeriveDataTypeable #-}
 
+-- |
+-- Module:      Data.Configurator.Types.Internal
+-- Copyright:   (c) 2011 MailRank, Inc.
+-- License:     BSD3
+-- Maintainer:  Bryan O'Sullivan <bos@mailrank.com>
+-- Stability:   experimental
+-- Portability: portable
+--
+-- Types for working with configuration files.
+
 module Data.Configurator.Types.Internal
     (
-      Name
+      Config(..)
+    , Configured(..)
+    , AutoConfig(..)
+    , Name
     , Value(..)
     , Binding
     , Path
 
 import Control.Exception
 import Data.Data (Data)
+import Data.IORef (IORef)
 import Data.Text (Text)
 import Data.Typeable (Typeable)
+import Prelude hiding (lookup)
+import qualified Data.HashMap.Lazy as H
 
+-- | Configuration data.
+data Config = Config {
+      cfgPaths :: [Path]
+    -- ^ The files from which the 'Config' was loaded.
+    , cfgMap :: IORef (H.HashMap Name Value)
+    }
+
+-- | This class represents types that can be automatically and safely
+-- converted from a 'Value'.  If conversion fails, 'Nothing' is
+-- returned.
+class Configured a where
+    convert :: Value -> Maybe a
+
+-- | An error occurred while processing a configuration file.
 data ConfigError = ParseError FilePath String
                    deriving (Show, Typeable)
 
+-- | Directions for automatically reloading 'Config' data.
+data AutoConfig = AutoConfig {
+      interval :: Int
+    -- ^ Interval (in seconds) at which to check for updates to config
+    -- files.  The smallest allowed interval is one second.
+    , onError :: SomeException -> IO ()
+    -- ^ Action invoked when an attempt to reload a 'Config' fails.
+    -- If this action rethrows its exception or throws a new
+    -- exception, the modification checking thread will be killed.
+    } deriving (Typeable)
+
+instance Show AutoConfig where
+    show c = "AutoConfig {interval = " ++ show (interval c) ++ "}"
+
 instance Exception ConfigError
 
+-- | The name of a 'Config' value.
 type Name = Text
+
+-- | A packed 'FilePath'.
 type Path = Text
 
+-- | A name-value binding.
 type Binding = (Name,Value)
 
+-- | A directive in a config file.
 data Directive = Import Path
                | Bind Name Value
                | Group Name [Directive]
                  deriving (Eq, Show, Typeable, Data)
 
+-- | A value in a 'Config'.
 data Value = Bool Bool
            | String Text
            | Number Int
            | List [Value]
              deriving (Eq, Show, Typeable, Data)
 
+-- | An interpolation directive.
 data Interp = Literal Text
             | Interp Text
               deriving (Eq, Show)

configurator.cabal

 library
   exposed-modules:
     Data.Configurator
+    Data.Configurator.Types
 
   other-modules:
+    Data.Configurator.Instances
     Data.Configurator.Parser
     Data.Configurator.Types.Internal
 
   build-depends:
     attoparsec-text >= 0.8.5.0,
     base == 4.*,
+    bytestring,
+    directory,
+    old-time,
     text >= 0.11.1.0,
     unordered-containers	
 

tests/pathological.cfg

+# 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}}}