Bryan O'Sullivan avatar Bryan O'Sullivan committed 920fe1e

Allow config files to be specified as required or optional.

Comments (0)

Files changed (4)

Data/Configurator.hs

     -- ** Importing files
     -- $import
 
+    -- * Types
+      Worth(..)
     -- * Loading configuration data
-      autoReload
+    , autoReload
     , autoConfig
     -- * Lookup functions
     , lookup
     , lookupDefault
+    , require
     -- * Notification of configuration changes
     -- $notify
     , prefix
 import qualified Data.Text.Lazy as L
 import qualified Data.Text.Lazy.IO as L
 
-loadFiles :: [Path] -> IO (H.HashMap Path [Directive])
+loadFiles :: [Worth Path] -> IO (H.HashMap (Worth Path) [Directive])
 loadFiles = foldM go H.empty
  where
    go seen path = do
-     ds <- loadOne . T.unpack =<< interpolate path H.empty
+     let rewrap n = const n <$> path
+         wpath = worth path
+     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
      foldM go seen' . filter notSeen . importsOf $ ds
 -- File names have any environment variables expanded prior to the
 -- first time they are opened, so you can specify a file name such as
 -- @\"$(HOME)/myapp.cfg\"@.
-load :: [FilePath] -> IO Config
+load :: [Worth FilePath] -> IO Config
 load = load' Nothing
 
-load' :: Maybe AutoConfig -> [FilePath] -> IO Config
+load' :: Maybe AutoConfig -> [Worth FilePath] -> IO Config
 load' auto paths0 = do
-  let paths = map T.pack paths0
+  let paths = map (fmap T.pack) paths0
   ds <- loadFiles paths
   m <- newIORef =<< flatten paths ds
   s <- newIORef H.empty
 autoReload :: AutoConfig
            -- ^ Directions for when to reload and how to handle
            -- errors.
-           -> [FilePath]
+           -> [Worth FilePath]
            -- ^ Configuration files to load.
            -> IO (Config, ThreadId)
 autoReload AutoConfig{..} _
 -- filesystem with timestamp resolution of 1 second or worse.
 type Meta = (FileOffset, EpochTime)
 
-getMeta :: [FilePath] -> IO [Maybe Meta]
+getMeta :: [Worth FilePath] -> IO [Maybe Meta]
 getMeta paths = forM paths $ \path ->
    handle (\(_::SomeException) -> return Nothing) . fmap Just $ do
-     st <- getFileStatus path
+     st <- getFileStatus (worth path)
      return (fileSize st, modificationTime st)
 
 -- | Look up a name in the given 'Config'.  If a binding exists, and
     (join . fmap convert . H.lookup 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
+  case val of
+    Just v -> return v
+    _      -> throwIO . KeyError $ name
+
+-- | Look up a name in the given 'Config'.  If a binding exists, and
 -- the value can be converted to the desired type, return it,
 -- otherwise return the default value.
 lookupDefault :: Configured a =>
 getMap :: Config -> IO (H.HashMap Name Value)
 getMap = readIORef . cfgMap
 
-flatten :: [Path] -> H.HashMap Path [Directive] -> IO (H.HashMap Name Value)
+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
  where
   directive pfx m (Group name xs) = foldM (directive pfx') m xs
       where pfx' = T.concat [pfx, name, "."]
   directive pfx m (Import path) =
-      case H.lookup path files of
+      case H.lookup (Required path) files of
         Just ds -> foldM (directive pfx) m ds
         _       -> return m
 
                 throwIO . ParseError "" $ "no such variable " ++ show name
             Right x -> return (fromString x)
 
-importsOf :: [Directive] -> [Path]
-importsOf (Import path : xs) = path : importsOf xs
+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 _                  = []
 
-loadOne :: FilePath -> IO [Directive]
+loadOne :: Worth FilePath -> IO [Directive]
 loadOne path = do
-  s <- L.readFile path
-  p <- evaluate (L.eitherResult $ L.parse topLevel s)
-       `catch` \(e::ConfigError) ->
-       throwIO $ case e of
-                   ParseError _ err -> ParseError path err
-  case p of
-    Left err -> throwIO (ParseError path err)
-    Right ds -> return ds
+  es <- try . L.readFile . worth $ path
+  case es of
+    Left (err::SomeException) -> case path of
+                                   Required _ -> throwIO err
+                                   _          -> return []
+    Right s -> do
+            p <- evaluate (L.eitherResult $ L.parse topLevel s)
+                 `catch` \(e::ConfigError) ->
+                 throwIO $ case e of
+                             ParseError _ err -> ParseError (worth path) err
+            case p of
+              Left err -> throwIO (ParseError (worth path) err)
+              Right ds -> return ds
 
 -- | Subscribe for notifications.  The given action will be invoked
 -- when any change occurs to a configuration property matching the

Data/Configurator/Instances.hs

 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

Data/Configurator/Types.hs

     , Name
     , Value(..)
     , Configured(..)
+    , Worth(..)
+    -- * Exceptions
+    , ConfigError(..)
+    , KeyError(..)
     -- * Notification of configuration changes
     , Pattern
     , ChangeHandler

Data/Configurator/Types/Internal.hs

-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}
 
 -- |
 -- Module:      Data.Configurator.Types.Internal
       Config(..)
     , Configured(..)
     , AutoConfig(..)
+    , Worth(..)
     , Name
     , Value(..)
     , Binding
     , Path
     , Directive(..)
     , ConfigError(..)
+    , KeyError(..)
     , Interpolate(..)
     , Pattern(..)
     , exact
 import Prelude hiding (lookup)
 import qualified Data.HashMap.Lazy as H
 
+data Worth a = Required { worth :: a }
+             | Optional { worth :: a }
+               deriving (Show, Typeable)
+                    
+instance IsString (Worth FilePath) where
+    fromString = Required
+
+instance (Eq a) => Eq (Worth a) where
+    a == b = worth a == worth b
+
+instance (Hashable a) => Hashable (Worth a) where
+    hash = hash . worth
+
 -- | Configuration data.
 data Config = Config {
       cfgAuto :: Maybe AutoConfig
-    , cfgPaths :: [Path]
+    , cfgPaths :: [Worth Path]
     -- ^ The files from which the 'Config' was loaded.
     , cfgMap :: IORef (H.HashMap Name Value)
     , cfgSubs :: IORef (H.HashMap Pattern [ChangeHandler])
     }
 
+instance Functor Worth where
+    fmap f (Required a) = Required (f a)
+    fmap f (Optional a) = Optional (f a)
+
 -- | An action to be invoked if a configuration property is changed.
 --
 -- If this action is invoked and throws an exception, the 'onError'
 data ConfigError = ParseError FilePath String
                    deriving (Show, Typeable)
 
+instance Exception ConfigError
+
+-- | An error occurred while lookup up the given 'Name'.
+data KeyError = KeyError Name
+              deriving (Show, Typeable)
+
+instance Exception KeyError
+
 -- | Directions for automatically reloading 'Config' data.
 data AutoConfig = AutoConfig {
       interval :: Int
 instance Show AutoConfig where
     show c = "AutoConfig {interval = " ++ show (interval c) ++ "}"
 
-instance Exception ConfigError
-
 -- | The name of a 'Config' value.
 type Name = Text
 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.