├── .hgignore ├── .hgtags ├── Data ├── Configurator.hs └── Configurator │ ├── Instances.hs │ ├── Parser.hs │ ├── Types.hs │ └── Types │ └── Internal.hs ├── LICENSE ├── README.markdown ├── Setup.lhs ├── configurator.cabal └── tests ├── Test.hs └── resources ├── import.cfg ├── interp.cfg └── pathological.cfg /.hgignore: -------------------------------------------------------------------------------- 1 | .*\.(?:aux|h[ip]|o|orig|out|pdf|prof|ps|rej)$ 2 | ^(?:dist|\.DS_Store)$ 3 | 4 | syntax: glob 5 | cabal.sandbox.config 6 | .cabal-sandbox 7 | *~ 8 | .*.swp 9 | .\#* 10 | \#* 11 | -------------------------------------------------------------------------------- /.hgtags: -------------------------------------------------------------------------------- 1 | c786fb69d19feeabf137f9bf2f785a8996af5e80 0.0.0.1 2 | ba3a24d8ba9c167fe897f315deabac626d2fcb44 0.0.1.1 3 | 3bcc05a33c1c7b6bb16adcaf1e712f1b7a3cba7c 0.1.0.0 4 | 0ab58f9aa2bfaff7309c9bbfca86c725e34d8a0a 0.2.0.0 5 | 0ab58f9aa2bfaff7309c9bbfca86c725e34d8a0a 0.2.0.0 6 | d07ef5d924822bd414e98e25773258d062002d95 0.2.0.0 7 | 3f340fd7336bbdf3012c30950e9dbe3c61fbafb8 0.2.0.1 8 | 8ca14a2ce06b3ebf8f48b89747d28f24dae32c4e 0.2.0.2 9 | e53049948a4d77cf2fceb0eec4d743a1becc8a8b 0.3.0.0 10 | -------------------------------------------------------------------------------- /Data/Configurator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards, 2 | ScopedTypeVariables, TupleSections #-} 3 | 4 | -- | 5 | -- Module: Data.Configurator 6 | -- Copyright: (c) 2011 MailRank, Inc. 7 | -- License: BSD3 8 | -- Maintainer: Bryan O'Sullivan 9 | -- Stability: experimental 10 | -- Portability: portable 11 | -- 12 | -- A simple (yet powerful) library for working with configuration 13 | -- files. 14 | 15 | module Data.Configurator 16 | ( 17 | -- * Configuration file format 18 | -- $format 19 | 20 | -- ** Binding a name to a value 21 | -- $binding 22 | 23 | -- *** Value types 24 | -- $types 25 | 26 | -- *** String interpolation 27 | -- $interp 28 | 29 | -- ** Grouping directives 30 | -- $group 31 | 32 | -- ** Importing files 33 | -- $import 34 | 35 | -- * Types 36 | Worth(..) 37 | -- * Loading configuration data 38 | , autoReload 39 | , autoReloadGroups 40 | , autoConfig 41 | , empty 42 | -- * Lookup functions 43 | , lookup 44 | , lookupDefault 45 | , require 46 | -- * Notification of configuration changes 47 | -- $notify 48 | , prefix 49 | , exact 50 | , subscribe 51 | -- * Low-level loading functions 52 | , load 53 | , loadGroups 54 | , reload 55 | , subconfig 56 | , addToConfig 57 | , addGroupsToConfig 58 | -- * Helper functions 59 | , display 60 | , getMap 61 | ) where 62 | 63 | import Control.Applicative ((<$>)) 64 | import Control.Concurrent (ThreadId, forkIO, threadDelay) 65 | import Control.Exception (SomeException, evaluate, handle, throwIO, try) 66 | import Control.Monad (foldM, forM, forM_, join, when, msum) 67 | import Data.Configurator.Instances () 68 | import Data.Configurator.Parser (interp, topLevel) 69 | import Data.Configurator.Types.Internal 70 | import Data.IORef (atomicModifyIORef, newIORef, readIORef) 71 | import Data.List (tails) 72 | import Data.Maybe (fromMaybe, isJust) 73 | import Data.Monoid (mconcat) 74 | import Data.Ratio (denominator, numerator) 75 | import Data.Text.Lazy.Builder (fromString, fromText, toLazyText) 76 | import Data.Text.Lazy.Builder.Int (decimal) 77 | import Data.Text.Lazy.Builder.RealFloat (realFloat) 78 | import Prelude hiding (lookup) 79 | import System.Environment (getEnv) 80 | import System.IO (hPutStrLn, stderr) 81 | import System.IO.Unsafe (unsafePerformIO) 82 | import System.Posix.Types (EpochTime, FileOffset) 83 | import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime) 84 | import qualified Control.Exception as E 85 | import qualified Data.Attoparsec.Text as T 86 | import qualified Data.Attoparsec.Text.Lazy as L 87 | import qualified Data.HashMap.Lazy as H 88 | import qualified Data.Text as T 89 | import qualified Data.Text.Lazy as L 90 | import qualified Data.Text.Lazy.IO as L 91 | 92 | loadFiles :: [Worth Path] -> IO (H.HashMap (Worth Path) [Directive]) 93 | loadFiles = foldM go H.empty 94 | where 95 | go seen path = do 96 | let rewrap n = const n <$> path 97 | wpath = worth path 98 | path' <- rewrap <$> interpolate "" wpath H.empty 99 | ds <- loadOne (T.unpack <$> path') 100 | let !seen' = H.insert path ds seen 101 | notSeen n = not . isJust . H.lookup n $ seen 102 | foldM go seen' . filter notSeen . importsOf wpath $ ds 103 | 104 | -- | Create a 'Config' from the contents of the named files. Throws an 105 | -- exception on error, such as if files do not exist or contain errors. 106 | -- 107 | -- File names have any environment variables expanded prior to the 108 | -- first time they are opened, so you can specify a file name such as 109 | -- @\"$(HOME)/myapp.cfg\"@. 110 | load :: [Worth FilePath] -> IO Config 111 | load files = fmap (Config "") $ load' Nothing (map (\f -> ("", f)) files) 112 | 113 | -- | Create a 'Config' from the contents of the named files, placing them 114 | -- into named prefixes. If a prefix is non-empty, it should end in a 115 | -- dot. 116 | loadGroups :: [(Name, Worth FilePath)] -> IO Config 117 | loadGroups files = fmap (Config "") $ load' Nothing files 118 | 119 | load' :: Maybe AutoConfig -> [(Name, Worth FilePath)] -> IO BaseConfig 120 | load' auto paths0 = do 121 | let second f (x,y) = (x, f y) 122 | paths = map (second (fmap T.pack)) paths0 123 | ds <- loadFiles (map snd paths) 124 | p <- newIORef paths 125 | m <- newIORef =<< flatten paths ds 126 | s <- newIORef H.empty 127 | return BaseConfig { 128 | cfgAuto = auto 129 | , cfgPaths = p 130 | , cfgMap = m 131 | , cfgSubs = s 132 | } 133 | 134 | -- | Gives a 'Config' corresponding to just a single group of the original 135 | -- 'Config'. The subconfig can be used just like the original 'Config', but 136 | -- see the documentation for 'reload'. 137 | subconfig :: Name -> Config -> Config 138 | subconfig g (Config root cfg) = Config (T.concat [root, g, "."]) cfg 139 | 140 | -- | Forcibly reload a 'Config'. Throws an exception on error, such as 141 | -- if files no longer exist or contain errors. If the provided 'Config' is 142 | -- a 'subconfig', this will reload the entire top-level configuration, not just 143 | -- the local section. 144 | reload :: Config -> IO () 145 | reload (Config _ cfg@BaseConfig{..}) = reloadBase cfg 146 | 147 | reloadBase :: BaseConfig -> IO () 148 | reloadBase cfg@BaseConfig{..} = do 149 | paths <- readIORef cfgPaths 150 | m' <- flatten paths =<< loadFiles (map snd paths) 151 | m <- atomicModifyIORef cfgMap $ \m -> (m', m) 152 | notifySubscribers cfg m m' =<< readIORef cfgSubs 153 | 154 | -- | Add additional files to a 'Config', causing it to be reloaded to add 155 | -- their contents. 156 | addToConfig :: [Worth FilePath] -> Config -> IO () 157 | addToConfig paths0 cfg = addGroupsToConfig (map (\x -> ("",x)) paths0) cfg 158 | 159 | -- | Add additional files to named groups in a 'Config', causing it to be 160 | -- reloaded to add their contents. If the prefixes are non-empty, they should 161 | -- end in dots. 162 | addGroupsToConfig :: [(Name, Worth FilePath)] -> Config -> IO () 163 | addGroupsToConfig paths0 (Config root cfg@BaseConfig{..}) = do 164 | let fix (x,y) = (root `T.append` x, fmap T.pack y) 165 | paths = map fix paths0 166 | atomicModifyIORef cfgPaths $ \prev -> (prev ++ paths, ()) 167 | reloadBase cfg 168 | 169 | -- | Defaults for automatic 'Config' reloading when using 170 | -- 'autoReload'. The 'interval' is one second, while the 'onError' 171 | -- action ignores its argument and does nothing. 172 | autoConfig :: AutoConfig 173 | autoConfig = AutoConfig { 174 | interval = 1 175 | , onError = const $ return () 176 | } 177 | 178 | -- | Load a 'Config' from the given 'FilePath's, and start a reload 179 | -- thread. 180 | -- 181 | -- At intervals, a thread checks for modifications to both the 182 | -- original files and any files they refer to in @import@ directives, 183 | -- and reloads the 'Config' if any files have been modified. 184 | -- 185 | -- If the initial attempt to load the configuration files fails, an 186 | -- exception is thrown. If the initial load succeeds, but a 187 | -- subsequent attempt fails, the 'onError' handler is invoked. 188 | -- 189 | -- File names have any environment variables expanded prior to the 190 | -- first time they are opened, so you can specify a file name such as 191 | -- @\"$(HOME)/myapp.cfg\"@. 192 | autoReload :: AutoConfig 193 | -- ^ Directions for when to reload and how to handle 194 | -- errors. 195 | -> [Worth FilePath] 196 | -- ^ Configuration files to load. 197 | -> IO (Config, ThreadId) 198 | autoReload auto paths = autoReloadGroups auto (map (\x -> ("", x)) paths) 199 | 200 | autoReloadGroups :: AutoConfig 201 | -> [(Name, Worth FilePath)] 202 | -> IO (Config, ThreadId) 203 | autoReloadGroups AutoConfig{..} _ 204 | | interval < 1 = error "autoReload: negative interval" 205 | autoReloadGroups _ [] = error "autoReload: no paths to load" 206 | autoReloadGroups auto@AutoConfig{..} paths = do 207 | cfg <- load' (Just auto) paths 208 | let files = map snd paths 209 | loop meta = do 210 | threadDelay (max interval 1 * 1000000) 211 | meta' <- getMeta files 212 | if meta' == meta 213 | then loop meta 214 | else (reloadBase cfg `E.catch` onError) >> loop meta' 215 | tid <- forkIO $ loop =<< getMeta files 216 | return (Config "" cfg, tid) 217 | 218 | -- | Save both a file's size and its last modification date, so we 219 | -- have a better chance of detecting a modification on a crappy 220 | -- filesystem with timestamp resolution of 1 second or worse. 221 | type Meta = (FileOffset, EpochTime) 222 | 223 | getMeta :: [Worth FilePath] -> IO [Maybe Meta] 224 | getMeta paths = forM paths $ \path -> 225 | handle (\(_::SomeException) -> return Nothing) . fmap Just $ do 226 | st <- getFileStatus (worth path) 227 | return (fileSize st, modificationTime st) 228 | 229 | -- | Look up a name in the given 'Config'. If a binding exists, and 230 | -- the value can be 'convert'ed to the desired type, return the 231 | -- converted value, otherwise 'Nothing'. 232 | lookup :: Configured a => Config -> Name -> IO (Maybe a) 233 | lookup (Config root BaseConfig{..}) name = 234 | (join . fmap convert . H.lookup (root `T.append` name)) <$> readIORef cfgMap 235 | 236 | -- | Look up a name in the given 'Config'. If a binding exists, and 237 | -- the value can be 'convert'ed to the desired type, return the 238 | -- converted value, otherwise throw a 'KeyError'. 239 | require :: Configured a => Config -> Name -> IO a 240 | require cfg name = do 241 | val <- lookup cfg name 242 | case val of 243 | Just v -> return v 244 | _ -> throwIO . KeyError $ name 245 | 246 | -- | Look up a name in the given 'Config'. If a binding exists, and 247 | -- the value can be converted to the desired type, return it, 248 | -- otherwise return the default value. 249 | lookupDefault :: Configured a => 250 | a 251 | -- ^ Default value to return if 'lookup' or 'convert' 252 | -- fails. 253 | -> Config -> Name -> IO a 254 | lookupDefault def cfg name = fromMaybe def <$> lookup cfg name 255 | 256 | -- | Perform a simple dump of a 'Config' to @stdout@. 257 | display :: Config -> IO () 258 | display (Config root BaseConfig{..}) = print . (root,) =<< readIORef cfgMap 259 | 260 | -- | Fetch the 'H.HashMap' that maps names to values. 261 | getMap :: Config -> IO (H.HashMap Name Value) 262 | getMap = readIORef . cfgMap . baseCfg 263 | 264 | flatten :: [(Name, Worth Path)] 265 | -> H.HashMap (Worth Path) [Directive] 266 | -> IO (H.HashMap Name Value) 267 | flatten roots files = foldM doPath H.empty roots 268 | where 269 | doPath m (pfx, f) = case H.lookup f files of 270 | Nothing -> return m 271 | Just ds -> foldM (directive pfx (worth f)) m ds 272 | 273 | directive pfx _ m (Bind name (String value)) = do 274 | v <- interpolate pfx value m 275 | return $! H.insert (T.append pfx name) (String v) m 276 | directive pfx _ m (Bind name value) = 277 | return $! H.insert (T.append pfx name) value m 278 | directive pfx f m (Group name xs) = foldM (directive pfx' f) m xs 279 | where pfx' = T.concat [pfx, name, "."] 280 | directive pfx f m (Import path) = 281 | let f' = relativize f path 282 | in case H.lookup (Required (relativize f path)) files of 283 | Just ds -> foldM (directive pfx f') m ds 284 | _ -> return m 285 | 286 | interpolate :: T.Text -> T.Text -> H.HashMap Name Value -> IO T.Text 287 | interpolate pfx s env 288 | | "$" `T.isInfixOf` s = 289 | case T.parseOnly interp s of 290 | Left err -> throwIO $ ParseError "" err 291 | Right xs -> (L.toStrict . toLazyText . mconcat) <$> mapM interpret xs 292 | | otherwise = return s 293 | where 294 | lookupEnv name = msum $ map (flip H.lookup env) fullnames 295 | where fullnames = map (T.intercalate ".") -- ["a.b.c.x","a.b.x","a.x","x"] 296 | . map (reverse . (name:)) -- [["a","b","c","x"],["a","b","x"],["a","x"],["x"]] 297 | . tails -- [["c","b","a"],["b","a"],["a"],[]] 298 | . reverse -- ["c","b","a"] 299 | . filter (not . T.null) -- ["a","b","c"] 300 | . T.split (=='.') -- ["a","b","c",""] 301 | $ pfx -- "a.b.c." 302 | 303 | interpret (Literal x) = return (fromText x) 304 | interpret (Interpolate name) = 305 | case lookupEnv name of 306 | Just (String x) -> return (fromText x) 307 | Just (Number r) 308 | | denominator r == 1 -> return (decimal $ numerator r) 309 | | otherwise -> return $ realFloat (fromRational r :: Double) 310 | -- TODO: Use a dedicated Builder for Rationals instead of 311 | -- using realFloat on a Double. 312 | Just _ -> error "type error" 313 | _ -> do 314 | e <- try . getEnv . T.unpack $ name 315 | case e of 316 | Left (_::SomeException) -> 317 | throwIO . ParseError "" $ "no such variable " ++ show name 318 | Right x -> return (fromString x) 319 | 320 | importsOf :: Path -> [Directive] -> [Worth Path] 321 | importsOf path (Import ref : xs) = Required (relativize path ref) 322 | : importsOf path xs 323 | importsOf path (Group _ ys : xs) = importsOf path ys ++ importsOf path xs 324 | importsOf path (_ : xs) = importsOf path xs 325 | importsOf _ _ = [] 326 | 327 | relativize :: Path -> Path -> Path 328 | relativize parent child 329 | | T.head child == '/' = child 330 | | otherwise = fst (T.breakOnEnd "/" parent) `T.append` child 331 | 332 | loadOne :: Worth FilePath -> IO [Directive] 333 | loadOne path = do 334 | es <- try . L.readFile . worth $ path 335 | case es of 336 | Left (err::SomeException) -> case path of 337 | Required _ -> throwIO err 338 | _ -> return [] 339 | Right s -> do 340 | p <- evaluate (L.eitherResult $ L.parse topLevel s) 341 | `E.catch` \(e::ConfigError) -> 342 | throwIO $ case e of 343 | ParseError _ err -> ParseError (worth path) err 344 | case p of 345 | Left err -> throwIO (ParseError (worth path) err) 346 | Right ds -> return ds 347 | 348 | -- | Subscribe for notifications. The given action will be invoked 349 | -- when any change occurs to a configuration property matching the 350 | -- supplied pattern. 351 | subscribe :: Config -> Pattern -> ChangeHandler -> IO () 352 | subscribe (Config root BaseConfig{..}) pat act = do 353 | m' <- atomicModifyIORef cfgSubs $ \m -> 354 | let m' = H.insertWith (++) (localPattern root pat) [act] m in (m', m') 355 | evaluate m' >> return () 356 | 357 | localPattern :: Name -> Pattern -> Pattern 358 | localPattern pfx (Exact s) = Exact (pfx `T.append` s) 359 | localPattern pfx (Prefix s) = Prefix (pfx `T.append` s) 360 | 361 | notifySubscribers :: BaseConfig -> H.HashMap Name Value -> H.HashMap Name Value 362 | -> H.HashMap Pattern [ChangeHandler] -> IO () 363 | notifySubscribers BaseConfig{..} m m' subs = H.foldrWithKey go (return ()) subs 364 | where 365 | changedOrGone = H.foldrWithKey check [] m 366 | where check n v nvs = case H.lookup n m' of 367 | Just v' | v /= v' -> (n,Just v'):nvs 368 | | otherwise -> nvs 369 | _ -> (n,Nothing):nvs 370 | new = H.foldrWithKey check [] m' 371 | where check n v nvs = case H.lookup n m of 372 | Nothing -> (n,v):nvs 373 | _ -> nvs 374 | notify p n v a = a n v `E.catch` maybe report onError cfgAuto 375 | where report e = hPutStrLn stderr $ 376 | "*** a ChangeHandler threw an exception for " ++ 377 | show (p,n) ++ ": " ++ show e 378 | go p@(Exact n) acts next = (const next =<<) $ do 379 | let v' = H.lookup n m' 380 | when (H.lookup n m /= v') . mapM_ (notify p n v') $ acts 381 | go p@(Prefix n) acts next = (const next =<<) $ do 382 | let matching = filter (T.isPrefixOf n . fst) 383 | forM_ (matching new) $ \(n',v) -> mapM_ (notify p n' (Just v)) acts 384 | forM_ (matching changedOrGone) $ \(n',v) -> mapM_ (notify p n' v) acts 385 | 386 | -- | A completely empty configuration. 387 | empty :: Config 388 | empty = Config "" $ unsafePerformIO $ do 389 | p <- newIORef [] 390 | m <- newIORef H.empty 391 | s <- newIORef H.empty 392 | return BaseConfig { 393 | cfgAuto = Nothing 394 | , cfgPaths = p 395 | , cfgMap = m 396 | , cfgSubs = s 397 | } 398 | {-# NOINLINE empty #-} 399 | 400 | -- $format 401 | -- 402 | -- A configuration file consists of a series of directives and 403 | -- comments, encoded in UTF-8. A comment begins with a \"@#@\" 404 | -- character, and continues to the end of a line. 405 | -- 406 | -- Files and directives are processed from first to last, top to 407 | -- bottom. 408 | 409 | -- $binding 410 | -- 411 | -- A binding associates a name with a value. 412 | -- 413 | -- > my_string = "hi mom! \u2603" 414 | -- > your-int-33 = 33 415 | -- > his_bool = on 416 | -- > HerList = [1, "foo", off] 417 | -- 418 | -- A name must begin with a Unicode letter, which is followed by zero 419 | -- or more of a Unicode alphanumeric code point, hyphen \"@-@\", or 420 | -- underscore \"@_@\". 421 | -- 422 | -- Bindings are created or overwritten in the order in which they are 423 | -- encountered. It is legitimate for a name to be bound multiple 424 | -- times, in which case the last value wins. 425 | -- 426 | -- > a = 1 427 | -- > a = true 428 | -- > # value of a is now true, not 1 429 | 430 | -- $types 431 | -- 432 | -- The configuration file format supports the following data types: 433 | -- 434 | -- * Booleans, represented as @on@ or @off@, @true@ or @false@. These 435 | -- are case sensitive, so do not try to use @True@ instead of 436 | -- @true@! 437 | -- 438 | -- * Integers, represented in base 10. 439 | -- 440 | -- * Unicode strings, represented as text (possibly containing escape 441 | -- sequences) surrounded by double quotes. 442 | -- 443 | -- * Heterogeneous lists of values, represented as an opening square 444 | -- bracket \"@[@\", followed by a series of comma-separated values, 445 | -- ending with a closing square bracket \"@]@\". 446 | -- 447 | -- The following escape sequences are recognised in a text string: 448 | -- 449 | -- * @\\n@ - newline 450 | -- 451 | -- * @\\r@ - carriage return 452 | -- 453 | -- * @\\t@ - horizontal tab 454 | -- 455 | -- * @\\\\@ - backslash 456 | -- 457 | -- * @\\\"@ - double quote 458 | -- 459 | -- * @\\u@/xxxx/ - Unicode character from the basic multilingual 460 | -- plane, encoded as four hexadecimal digits 461 | -- 462 | -- * @\\u@/xxxx/@\\u@/xxxx/ - Unicode character from an astral plane, 463 | -- as two hexadecimal-encoded UTF-16 surrogates 464 | 465 | -- $interp 466 | -- 467 | -- Strings support interpolation, so that you can dynamically 468 | -- construct a string based on data in your configuration or the OS 469 | -- environment. 470 | -- 471 | -- If a string value contains the special sequence \"@$(foo)@\" (for 472 | -- any name @foo@), then the name @foo@ will be looked up in the 473 | -- configuration data and its value substituted. If that name cannot 474 | -- be found, it will be looked up in the OS environment. 475 | -- 476 | -- For security reasons, it is an error for a string interpolation 477 | -- fragment to contain a name that cannot be found in either the 478 | -- current configuration or the environment. 479 | -- 480 | -- To represent a single literal \"@$@\" character in a string, double 481 | -- it: \"@$$@\". 482 | 483 | -- $group 484 | -- 485 | -- It is possible to group a number of directives together under a 486 | -- single prefix: 487 | -- 488 | -- > my-group 489 | -- > { 490 | -- > a = 1 491 | -- > 492 | -- > # groups support nesting 493 | -- > nested { 494 | -- > b = "yay!" 495 | -- > } 496 | -- > } 497 | -- 498 | -- The name of a group is used as a prefix for the items in the 499 | -- group. For instance, the value of \"@a@\" above can be retrieved 500 | -- using 'lookup' by supplying the name \"@my-group.a@\", and \"@b@\" 501 | -- will be named \"@my-group.nested.b@\". 502 | 503 | -- $import 504 | -- 505 | -- To import the contents of another configuration file, use the 506 | -- @import@ directive. 507 | -- 508 | -- > import "$(HOME)/etc/myapp.cfg" 509 | -- 510 | -- Absolute paths are imported as is. Relative paths are resolved with 511 | -- respect to the file they are imported from. It is an error for an 512 | -- @import@ directive to name a file that does not exist, cannot be read, 513 | -- or contains errors. 514 | -- 515 | -- If an @import@ appears inside a group, the group's naming prefix 516 | -- will be applied to all of the names imported from the given 517 | -- configuration file. 518 | -- 519 | -- Supposing we have a file named \"@foo.cfg@\": 520 | -- 521 | -- > bar = 1 522 | -- 523 | -- And another file that imports it into a group: 524 | -- 525 | -- > hi { 526 | -- > import "foo.cfg" 527 | -- > } 528 | -- 529 | -- This will result in a value named \"@hi.bar@\". 530 | 531 | -- $notify 532 | -- 533 | -- To more efficiently support an application's need to dynamically 534 | -- reconfigure, a subsystem may ask to be notified when a 535 | -- configuration property is changed as a result of a reload, using 536 | -- the 'subscribe' action. 537 | -------------------------------------------------------------------------------- /Data/Configurator/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Data.Configurator.Instances () where 5 | 6 | import Control.Applicative 7 | import Data.Configurator.Types.Internal 8 | import Data.Complex (Complex) 9 | import Data.Fixed (Fixed, HasResolution) 10 | import Data.Int (Int8, Int16, Int32, Int64) 11 | import Data.Text.Encoding (encodeUtf8) 12 | import Data.Ratio (Ratio, denominator, numerator) 13 | import Data.Word (Word, Word8, Word16, Word32, Word64) 14 | import Foreign.C.Types (CDouble, CFloat) 15 | import qualified Data.ByteString as B 16 | import qualified Data.ByteString.Lazy as LB 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Lazy as L 19 | 20 | instance Configured Value where 21 | convert = Just 22 | 23 | instance Configured Bool where 24 | convert (Bool v) = Just v 25 | convert _ = Nothing 26 | 27 | convertNumberToNum :: (Num a) => Value -> Maybe a 28 | convertNumberToNum (Number r) 29 | | denominator r == 1 = Just $ fromInteger $ numerator r 30 | convertNumberToNum _ = Nothing 31 | 32 | instance Configured Int where 33 | convert = convertNumberToNum 34 | 35 | instance Configured Integer where 36 | convert = convertNumberToNum 37 | 38 | instance Configured Int8 where 39 | convert = convertNumberToNum 40 | 41 | instance Configured Int16 where 42 | convert = convertNumberToNum 43 | 44 | instance Configured Int32 where 45 | convert = convertNumberToNum 46 | 47 | instance Configured Int64 where 48 | convert = convertNumberToNum 49 | 50 | instance Configured Word where 51 | convert = convertNumberToNum 52 | 53 | instance Configured Word8 where 54 | convert = convertNumberToNum 55 | 56 | instance Configured Word16 where 57 | convert = convertNumberToNum 58 | 59 | instance Configured Word32 where 60 | convert = convertNumberToNum 61 | 62 | instance Configured Word64 where 63 | convert = convertNumberToNum 64 | 65 | convertNumberToFractional :: (Fractional a) => Value -> Maybe a 66 | convertNumberToFractional (Number r) = Just $ fromRational r 67 | convertNumberToFractional _ = Nothing 68 | 69 | instance Configured Double where 70 | convert = convertNumberToFractional 71 | 72 | instance Configured Float where 73 | convert = convertNumberToFractional 74 | 75 | instance Configured CDouble where 76 | convert = convertNumberToFractional 77 | 78 | instance Configured CFloat where 79 | convert = convertNumberToFractional 80 | 81 | instance Integral a => Configured (Ratio a) where 82 | convert = convertNumberToFractional 83 | 84 | instance RealFloat a => Configured (Complex a) where 85 | convert = convertNumberToFractional 86 | 87 | instance HasResolution a => Configured (Fixed a) where 88 | convert = convertNumberToFractional 89 | 90 | instance Configured T.Text where 91 | convert (String v) = Just v 92 | convert _ = Nothing 93 | 94 | instance Configured Char where 95 | convert (String txt) | T.length txt == 1 = Just $ T.head txt 96 | convert _ = Nothing 97 | 98 | convertList = fmap T.unpack . convert 99 | 100 | instance Configured L.Text where 101 | convert = fmap L.fromStrict . convert 102 | 103 | instance Configured B.ByteString where 104 | convert = fmap encodeUtf8 . convert 105 | 106 | instance Configured LB.ByteString where 107 | convert = fmap (LB.fromChunks . (:[])) . convert 108 | 109 | instance (Configured a, Configured b) => Configured (a,b) where 110 | convert (List [a,b]) = (,) <$> convert a <*> convert b 111 | convert _ = Nothing 112 | 113 | instance (Configured a, Configured b, Configured c) => Configured (a,b,c) where 114 | convert (List [a,b,c]) = (,,) <$> convert a <*> convert b <*> convert c 115 | convert _ = Nothing 116 | 117 | instance (Configured a, Configured b, Configured c, Configured d) 118 | => Configured (a,b,c,d) where 119 | convert (List [a,b,c,d]) = (,,,) <$> convert a <*> convert b <*> convert c 120 | <*> convert d 121 | convert _ = Nothing 122 | -------------------------------------------------------------------------------- /Data/Configurator/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | 4 | -- Module: Data.Configurator.Parser 5 | -- Copyright: (c) 2011 MailRank, Inc. 6 | -- License: BSD3 7 | -- Maintainer: Bryan O'Sullivan 8 | -- Stability: experimental 9 | -- Portability: portable 10 | -- 11 | -- A parser for configuration files. 12 | 13 | module Data.Configurator.Parser 14 | ( 15 | topLevel 16 | , interp 17 | ) where 18 | 19 | import Control.Applicative 20 | import Control.Exception (throw) 21 | import Control.Monad (when) 22 | import Data.Attoparsec.Text as A 23 | import Data.Bits (shiftL) 24 | import Data.Char (chr, isAlpha, isAlphaNum, isSpace) 25 | import Data.Configurator.Types.Internal 26 | import Data.Monoid (Monoid(..)) 27 | import Data.Text (Text) 28 | import Data.Text.Lazy.Builder (fromText, singleton, toLazyText) 29 | import qualified Data.Text as T 30 | import qualified Data.Text.Lazy as L 31 | 32 | topLevel :: Parser [Directive] 33 | topLevel = directives <* skipLWS <* endOfInput 34 | 35 | directive :: Parser Directive 36 | directive = 37 | mconcat [ 38 | string "import" *> skipLWS *> (Import <$> string_) 39 | , Bind <$> try (ident <* skipLWS <* char '=' <* skipLWS) <*> value 40 | , Group <$> try (ident <* skipLWS <* char '{' <* skipLWS) 41 | <*> directives <* skipLWS <* char '}' 42 | ] 43 | 44 | directives :: Parser [Directive] 45 | directives = (skipLWS *> directive <* skipHWS) `sepBy` 46 | (satisfy $ \c -> c == '\r' || c == '\n') 47 | 48 | data Skip = Space | Comment 49 | 50 | -- | Skip lines, comments, or horizontal white space. 51 | skipLWS :: Parser () 52 | skipLWS = scan Space go *> pure () 53 | where go Space c | isSpace c = Just Space 54 | go Space '#' = Just Comment 55 | go Space _ = Nothing 56 | go Comment '\r' = Just Space 57 | go Comment '\n' = Just Space 58 | go Comment _ = Just Comment 59 | 60 | -- | Skip comments or horizontal white space. 61 | skipHWS :: Parser () 62 | skipHWS = scan Space go *> pure () 63 | where go Space ' ' = Just Space 64 | go Space '\t' = Just Space 65 | go Space '#' = Just Comment 66 | go Space _ = Nothing 67 | go Comment '\r' = Nothing 68 | go Comment '\n' = Nothing 69 | go Comment _ = Just Comment 70 | 71 | ident :: Parser Name 72 | ident = do 73 | n <- T.cons <$> satisfy isAlpha <*> A.takeWhile isCont 74 | when (n == "import") $ 75 | throw (ParseError "" $ "reserved word (" ++ show n ++ ") used as identifier") 76 | return n 77 | where 78 | isCont c = isAlphaNum c || c == '_' || c == '-' 79 | 80 | value :: Parser Value 81 | value = mconcat [ 82 | string "on" *> pure (Bool True) 83 | , string "off" *> pure (Bool False) 84 | , string "true" *> pure (Bool True) 85 | , string "false" *> pure (Bool False) 86 | , String <$> string_ 87 | , Number <$> rational 88 | , List <$> brackets '[' ']' 89 | ((value <* skipLWS) `sepBy` (char ',' <* skipLWS)) 90 | ] 91 | 92 | string_ :: Parser Text 93 | string_ = do 94 | s <- char '"' *> scan False isChar <* char '"' 95 | if "\\" `T.isInfixOf` s 96 | then unescape s 97 | else return s 98 | where 99 | isChar True _ = Just False 100 | isChar _ '"' = Nothing 101 | isChar _ c = Just (c == '\\') 102 | 103 | brackets :: Char -> Char -> Parser a -> Parser a 104 | brackets open close p = char open *> skipLWS *> p <* char close 105 | 106 | embed :: Parser a -> Text -> Parser a 107 | embed p s = case parseOnly p s of 108 | Left err -> fail err 109 | Right v -> return v 110 | 111 | unescape :: Text -> Parser Text 112 | unescape = fmap (L.toStrict . toLazyText) . embed (p mempty) 113 | where 114 | p acc = do 115 | h <- A.takeWhile (/='\\') 116 | let rest = do 117 | let cont c = p (acc `mappend` fromText h `mappend` singleton c) 118 | c <- char '\\' *> satisfy (inClass "ntru\"\\") 119 | case c of 120 | 'n' -> cont '\n' 121 | 't' -> cont '\t' 122 | 'r' -> cont '\r' 123 | '"' -> cont '"' 124 | '\\' -> cont '\\' 125 | _ -> cont =<< hexQuad 126 | done <- atEnd 127 | if done 128 | then return (acc `mappend` fromText h) 129 | else rest 130 | 131 | hexQuad :: Parser Char 132 | hexQuad = do 133 | a <- embed hexadecimal =<< A.take 4 134 | if a < 0xd800 || a > 0xdfff 135 | then return (chr a) 136 | else do 137 | b <- embed hexadecimal =<< string "\\u" *> A.take 4 138 | if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff 139 | then return $! chr (((a - 0xd800) `shiftL` 10) + (b - 0xdc00) + 0x10000) 140 | else fail "invalid UTF-16 surrogates" 141 | 142 | -- | Parse a string interpolation spec. 143 | -- 144 | -- The sequence @$$@ is treated as a single @$@ character. The 145 | -- sequence @$(@ begins a section to be interpolated, and @)@ ends it. 146 | interp :: Parser [Interpolate] 147 | interp = reverse <$> p [] 148 | where 149 | p acc = do 150 | h <- Literal <$> A.takeWhile (/='$') 151 | let rest = do 152 | let cont x = p (x : h : acc) 153 | c <- char '$' *> satisfy (\c -> c == '$' || c == '(') 154 | case c of 155 | '$' -> cont (Literal (T.singleton '$')) 156 | _ -> (cont . Interpolate) =<< A.takeWhile1 (/=')') <* char ')' 157 | done <- atEnd 158 | if done 159 | then return (h : acc) 160 | else rest 161 | -------------------------------------------------------------------------------- /Data/Configurator/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.Configurator.Types 3 | -- Copyright: (c) 2011 MailRank, Inc. 4 | -- License: BSD3 5 | -- Maintainer: Bryan O'Sullivan 6 | -- Stability: experimental 7 | -- Portability: portable 8 | -- 9 | -- Types for working with configuration files. 10 | 11 | module Data.Configurator.Types 12 | ( 13 | AutoConfig(..) 14 | , Config 15 | , Name 16 | , Value(..) 17 | , Configured, convert 18 | , Worth(..) 19 | -- * Exceptions 20 | , ConfigError(..) 21 | , KeyError(..) 22 | -- * Notification of configuration changes 23 | , Pattern 24 | , ChangeHandler 25 | ) where 26 | 27 | import Data.Configurator.Types.Internal 28 | -------------------------------------------------------------------------------- /Data/Configurator/Types/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-} 2 | 3 | -- | 4 | -- Module: Data.Configurator.Types.Internal 5 | -- Copyright: (c) 2011 MailRank, Inc. 6 | -- License: BSD3 7 | -- Maintainer: Bryan O'Sullivan 8 | -- Stability: experimental 9 | -- Portability: portable 10 | -- 11 | -- Types for working with configuration files. 12 | 13 | module Data.Configurator.Types.Internal 14 | ( 15 | BaseConfig(..) 16 | , Config(..) 17 | , Configured(..) 18 | , AutoConfig(..) 19 | , Worth(..) 20 | , Name 21 | , Value(..) 22 | , Binding 23 | , Path 24 | , Directive(..) 25 | , ConfigError(..) 26 | , KeyError(..) 27 | , Interpolate(..) 28 | , Pattern(..) 29 | , exact 30 | , prefix 31 | , ChangeHandler 32 | ) where 33 | 34 | import Control.Exception 35 | import Data.Data (Data) 36 | import Data.Hashable (Hashable(..)) 37 | import Data.IORef (IORef) 38 | import Data.List (isSuffixOf) 39 | import Data.String (IsString(..)) 40 | import Data.Text (Text) 41 | import qualified Data.Text as T 42 | import Data.Typeable (Typeable) 43 | import Prelude hiding (lookup) 44 | import qualified Data.HashMap.Lazy as H 45 | 46 | data Worth a = Required { worth :: a } 47 | | Optional { worth :: a } 48 | deriving (Show, Typeable) 49 | 50 | instance IsString (Worth FilePath) where 51 | fromString = Required 52 | 53 | instance (Eq a) => Eq (Worth a) where 54 | a == b = worth a == worth b 55 | 56 | instance (Hashable a) => Hashable (Worth a) where 57 | hashWithSalt salt v = hashWithSalt salt (worth v) 58 | 59 | -- | Global configuration data. This is the top-level config from which 60 | -- 'Config' values are derived by choosing a root location. 61 | data BaseConfig = BaseConfig { 62 | cfgAuto :: Maybe AutoConfig 63 | , cfgPaths :: IORef [(Name, Worth Path)] 64 | -- ^ The files from which the 'Config' was loaded. 65 | , cfgMap :: IORef (H.HashMap Name Value) 66 | , cfgSubs :: IORef (H.HashMap Pattern [ChangeHandler]) 67 | } 68 | 69 | -- | Configuration data. 70 | data Config = Config { root :: Text, baseCfg :: BaseConfig } 71 | 72 | instance Functor Worth where 73 | fmap f (Required a) = Required (f a) 74 | fmap f (Optional a) = Optional (f a) 75 | 76 | -- | An action to be invoked if a configuration property is changed. 77 | -- 78 | -- If this action is invoked and throws an exception, the 'onError' 79 | -- function will be called. 80 | type ChangeHandler = Name 81 | -- ^ Name of the changed property. 82 | -> Maybe Value 83 | -- ^ Its new value, or 'Nothing' if it has 84 | -- vanished. 85 | -> IO () 86 | 87 | -- | A pattern specifying the name of a property that has changed. 88 | -- 89 | -- This type is an instance of the 'IsString' class. If you use the 90 | -- @OverloadedStrings@ language extension and want to write a 91 | -- 'prefix'-matching pattern as a literal string, do so by suffixing 92 | -- it with \"@.*@\", for example as follows: 93 | -- 94 | -- > "foo.*" 95 | -- 96 | -- If a pattern written as a literal string does not end with 97 | -- \"@.*@\", it is assumed to be 'exact'. 98 | data Pattern = Exact Name 99 | -- ^ An exact match. 100 | | Prefix Name 101 | -- ^ A prefix match. Given @'Prefix' \"foo\"@, this will 102 | -- match @\"foo.bar\"@, but not @\"foo\"@ or 103 | -- @\"foobar\"@. 104 | deriving (Eq, Show, Typeable, Data) 105 | 106 | -- | A pattern that must match exactly. 107 | exact :: Text -> Pattern 108 | exact = Exact 109 | 110 | -- | A pattern that matches on a prefix of a property name. Given 111 | -- @\"foo\"@, this will match @\"foo.bar\"@, but not @\"foo\"@ or 112 | -- @\"foobar\"@. 113 | prefix :: Text -> Pattern 114 | prefix p = Prefix (p `T.snoc` '.') 115 | 116 | instance IsString Pattern where 117 | fromString s 118 | | ".*" `isSuffixOf` s = Prefix . T.init . T.pack $ s 119 | | otherwise = Exact (T.pack s) 120 | 121 | instance Hashable Pattern where 122 | hashWithSalt salt (Exact n) = hashWithSalt salt n 123 | hashWithSalt salt (Prefix n) = hashWithSalt salt n 124 | 125 | -- | This class represents types that can be automatically and safely 126 | -- converted /from/ a 'Value' /to/ a destination type. If conversion 127 | -- fails because the types are not compatible, 'Nothing' is returned. 128 | -- 129 | -- For an example of compatibility, a 'Value' of 'Bool' 'True' cannot 130 | -- be 'convert'ed to an 'Int'. 131 | class Configured a where 132 | convert :: Value -> Maybe a 133 | 134 | convertList :: Value -> Maybe [a] 135 | convertList (List xs) = mapM convert xs 136 | convertList _ = Nothing 137 | 138 | instance Configured a => Configured [a] where 139 | convert = convertList 140 | 141 | -- | An error occurred while processing a configuration file. 142 | data ConfigError = ParseError FilePath String 143 | deriving (Show, Typeable) 144 | 145 | instance Exception ConfigError 146 | 147 | -- | An error occurred while lookup up the given 'Name'. 148 | data KeyError = KeyError Name 149 | deriving (Show, Typeable) 150 | 151 | instance Exception KeyError 152 | 153 | -- | Directions for automatically reloading 'Config' data. 154 | data AutoConfig = AutoConfig { 155 | interval :: Int 156 | -- ^ Interval (in seconds) at which to check for updates to config 157 | -- files. The smallest allowed interval is one second. 158 | , onError :: SomeException -> IO () 159 | -- ^ Action invoked when an attempt to reload a 'Config' or notify 160 | -- a 'ChangeHandler' causes an exception to be thrown. 161 | -- 162 | -- If this action rethrows its exception or throws a new 163 | -- exception, the modification checking thread will be killed. 164 | -- You may want your application to treat that as a fatal error, 165 | -- as its configuration may no longer be consistent. 166 | } deriving (Typeable) 167 | 168 | instance Show AutoConfig where 169 | show c = "AutoConfig {interval = " ++ show (interval c) ++ "}" 170 | 171 | -- | The name of a 'Config' value. 172 | type Name = Text 173 | 174 | -- | A packed 'FilePath'. 175 | type Path = Text 176 | 177 | -- | A name-value binding. 178 | type Binding = (Name,Value) 179 | 180 | -- | A directive in a configuration file. 181 | data Directive = Import Path 182 | | Bind Name Value 183 | | Group Name [Directive] 184 | deriving (Eq, Show, Typeable, Data) 185 | 186 | -- | A value in a 'Config'. 187 | data Value = Bool Bool 188 | -- ^ A Boolean. Represented in a configuration file as @on@ 189 | -- or @off@, @true@ or @false@ (case sensitive). 190 | | String Text 191 | -- ^ A Unicode string. Represented in a configuration file 192 | -- as text surrounded by double quotes. 193 | -- 194 | -- Escape sequences: 195 | -- 196 | -- * @\\n@ - newline 197 | -- 198 | -- * @\\r@ - carriage return 199 | -- 200 | -- * @\\t@ - horizontal tab 201 | -- 202 | -- * @\\\\@ - backslash 203 | -- 204 | -- * @\\\"@ - quotes 205 | -- 206 | -- * @\\u@/xxxx/ - Unicode character, encoded as four 207 | -- hexadecimal digits 208 | -- 209 | -- * @\\u@/xxxx/@\\u@/xxxx/ - Unicode character (as two 210 | -- UTF-16 surrogates) 211 | | Number Rational 212 | -- ^ Integer. 213 | | List [Value] 214 | -- ^ Heterogeneous list. Represented in a configuration 215 | -- file as an opening square bracket \"@[@\", followed by a 216 | -- comma-separated series of values, ending with a closing 217 | -- square bracket \"@]@\". 218 | deriving (Eq, Show, Typeable, Data) 219 | 220 | -- | An interpolation directive. 221 | data Interpolate = Literal Text 222 | | Interpolate Text 223 | deriving (Eq, Show) 224 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011, MailRank, Inc. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Welcome to configurator 2 | 3 | This is a library for configuring Haskell daemons and programs. 4 | 5 | Its features include: 6 | 7 | * Automatic, dynamic reloading in response to modifications to 8 | configuration files. 9 | 10 | * A simple, but flexible, configuration language, supporting several 11 | of the most commonly needed types of data, along with interpolation 12 | of strings from the configuration or the system environment 13 | (e.g. `$(HOME)`). 14 | 15 | * Subscription-based notification of changes to configuration 16 | properties. 17 | 18 | * An `import` directive allows the configuration of a complex 19 | application to be split across several smaller files, or 20 | configuration data to be shared across several applications. 21 | 22 | # Configuration file format 23 | 24 | For details of the configuration file format, see [the Haddock documentation](http://hackage.haskell.org/packages/archive/configurator/latest/doc/html/Data-Configurator.html). 25 | 26 | # Join in! 27 | 28 | We are happy to receive bug reports, fixes, documentation enhancements, 29 | and other improvements. 30 | 31 | Please report bugs via the 32 | [github issue tracker](http://github.com/bos/configurator/issues). 33 | 34 | Master [git repository](http://github.com/bos/configurator): 35 | 36 | * `git clone git://github.com/bos/configurator.git` 37 | 38 | There's also a [Mercurial mirror](http://bitbucket.org/bos/configurator): 39 | 40 | * `hg clone http://bitbucket.org/bos/configurator` 41 | 42 | (You can create and contribute changes using either git or Mercurial.) 43 | 44 | Authors 45 | ------- 46 | 47 | This library is written and maintained by Bryan O'Sullivan, 48 | . 49 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /configurator.cabal: -------------------------------------------------------------------------------- 1 | name: configurator 2 | version: 0.3.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | category: Configuration, Data 6 | copyright: Copyright 2011 MailRank, Inc. 7 | Copyright 2011-2014 Bryan O'Sullivan 8 | author: Bryan O'Sullivan 9 | maintainer: Bryan O'Sullivan 10 | stability: experimental 11 | tested-with: GHC == 7.0, GHC == 7.2, GHC == 7.4, GHC == 7.6, GHC == 7.8 12 | synopsis: Configuration management 13 | cabal-version: >= 1.8 14 | homepage: http://github.com/bos/configurator 15 | bug-reports: http://github.com/bos/configurator/issues 16 | build-type: Simple 17 | description: 18 | A configuration management library for programs and daemons. 19 | . 20 | Features include: 21 | . 22 | * Automatic, dynamic reloading in response to modifications to 23 | configuration files. 24 | . 25 | * A simple, but flexible, configuration language, supporting several 26 | of the most commonly needed types of data, along with 27 | interpolation of strings from the configuration or the system 28 | environment (e.g. @$(HOME)@). 29 | . 30 | * Subscription-based notification of changes to configuration 31 | properties. 32 | . 33 | * An @import@ directive allows the configuration of a complex 34 | application to be split across several smaller files, or common 35 | configuration data to be shared across several applications. 36 | . 37 | For details of the configuration file format, see 38 | . 39 | 40 | extra-source-files: 41 | README.markdown 42 | 43 | data-files: tests/resources/*.cfg 44 | 45 | flag developer 46 | description: operate in developer mode 47 | default: False 48 | manual: True 49 | 50 | library 51 | exposed-modules: 52 | Data.Configurator 53 | Data.Configurator.Types 54 | 55 | other-modules: 56 | Data.Configurator.Instances 57 | Data.Configurator.Parser 58 | Data.Configurator.Types.Internal 59 | 60 | build-depends: 61 | attoparsec >= 0.10.0.2, 62 | base == 4.*, 63 | bytestring, 64 | directory, 65 | hashable, 66 | text >= 0.11.1.0, 67 | unix-compat, 68 | unordered-containers 69 | 70 | if flag(developer) 71 | ghc-options: -Werror 72 | ghc-prof-options: -auto-all 73 | 74 | ghc-options: -Wall 75 | 76 | source-repository head 77 | type: git 78 | location: http://github.com/bos/configurator 79 | 80 | source-repository head 81 | type: mercurial 82 | location: http://bitbucket.org/bos/configurator 83 | 84 | test-suite tests 85 | type: exitcode-stdio-1.0 86 | main-is: Test.hs 87 | hs-source-dirs: tests 88 | build-depends: 89 | HUnit, 90 | base, 91 | bytestring, 92 | configurator, 93 | directory, 94 | filepath, 95 | test-framework, 96 | test-framework-hunit, 97 | text 98 | ghc-options: -Wall -fno-warn-unused-do-bind 99 | -------------------------------------------------------------------------------- /tests/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Prelude hiding (lookup) 7 | 8 | import Control.Concurrent 9 | import Control.Exception 10 | import Control.Monad 11 | import qualified Data.ByteString.Lazy.Char8 as L 12 | import Data.Configurator 13 | import Data.Configurator.Types 14 | import Data.Functor 15 | import Data.Int 16 | import Data.Maybe 17 | import Data.Text (Text) 18 | import Data.Word 19 | import System.Directory 20 | import System.Environment 21 | import System.FilePath 22 | import System.IO 23 | import Test.Framework 24 | import Test.Framework.Providers.HUnit 25 | import Test.HUnit hiding (Test) 26 | 27 | main :: IO () 28 | main = defaultMain tests 29 | 30 | tests :: [Test] 31 | tests = 32 | [ testCase "load" loadTest 33 | , testCase "types" typesTest 34 | , testCase "interp" interpTest 35 | , testCase "scoped-interp" scopedInterpTest 36 | , testCase "import" importTest 37 | , testCase "reload" reloadTest 38 | ] 39 | 40 | withLoad :: FilePath -> (Config -> IO ()) -> IO () 41 | withLoad name t = do 42 | mb <- try $ load (testFile name) 43 | case mb of 44 | Left (err :: SomeException) -> assertFailure (show err) 45 | Right cfg -> t cfg 46 | 47 | withReload :: FilePath -> ([Maybe FilePath] -> Config -> IO ()) -> IO () 48 | withReload name t = do 49 | tmp <- getTemporaryDirectory 50 | temps <- forM (testFile name) $ \f -> do 51 | exists <- doesFileExist (worth f) 52 | if exists 53 | then do 54 | (p,h) <- openBinaryTempFile tmp "test.cfg" 55 | L.hPut h =<< L.readFile (worth f) 56 | hClose h 57 | return (p <$ f, Just p) 58 | else do 59 | return (f, Nothing) 60 | flip finally (mapM_ removeFile (catMaybes (map snd temps))) $ do 61 | mb <- try $ autoReload autoConfig (map fst temps) 62 | case mb of 63 | Left (err :: SomeException) -> assertFailure (show err) 64 | Right (cfg, tid) -> t (map snd temps) cfg >> killThread tid 65 | 66 | testFile :: FilePath -> [Worth FilePath] 67 | testFile name = [Required $ "tests" "resources" name] 68 | 69 | takeMVarTimeout :: Int -> MVar a -> IO (Maybe a) 70 | takeMVarTimeout millis v = do 71 | w <- newEmptyMVar 72 | tid <- forkIO $ do 73 | putMVar w . Just =<< takeMVar v 74 | forkIO $ do 75 | threadDelay (millis * 1000) 76 | killThread tid 77 | tryPutMVar w Nothing 78 | return () 79 | takeMVar w 80 | 81 | loadTest :: Assertion 82 | loadTest = 83 | withLoad "pathological.cfg" $ \cfg -> do 84 | aa <- lookup cfg "aa" 85 | assertEqual "int property" aa $ (Just 1 :: Maybe Int) 86 | 87 | ab <- lookup cfg "ab" 88 | assertEqual "string property" ab (Just "foo" :: Maybe Text) 89 | 90 | acx <- lookup cfg "ac.x" 91 | assertEqual "nested int" acx (Just 1 :: Maybe Int) 92 | 93 | acy <- lookup cfg "ac.y" 94 | assertEqual "nested bool" acy (Just True :: Maybe Bool) 95 | 96 | ad <- lookup cfg "ad" 97 | assertEqual "simple bool" ad (Just False :: Maybe Bool) 98 | 99 | ae <- lookup cfg "ae" 100 | assertEqual "simple int 2" ae (Just 1 :: Maybe Int) 101 | 102 | af <- lookup cfg "af" 103 | assertEqual "list property" af (Just (2,3) :: Maybe (Int,Int)) 104 | 105 | deep <- lookup cfg "ag.q-e.i_u9.a" 106 | assertEqual "deep bool" deep (Just False :: Maybe Bool) 107 | 108 | typesTest :: Assertion 109 | typesTest = 110 | withLoad "pathological.cfg" $ \cfg -> do 111 | asInt <- lookup cfg "aa" :: IO (Maybe Int) 112 | assertEqual "int" asInt (Just 1) 113 | 114 | asInteger <- lookup cfg "aa" :: IO (Maybe Integer) 115 | assertEqual "int" asInteger (Just 1) 116 | 117 | asWord <- lookup cfg "aa" :: IO (Maybe Word) 118 | assertEqual "int" asWord (Just 1) 119 | 120 | asInt8 <- lookup cfg "aa" :: IO (Maybe Int8) 121 | assertEqual "int8" asInt8 (Just 1) 122 | 123 | asInt16 <- lookup cfg "aa" :: IO (Maybe Int16) 124 | assertEqual "int16" asInt16 (Just 1) 125 | 126 | asInt32 <- lookup cfg "aa" :: IO (Maybe Int32) 127 | assertEqual "int32" asInt32 (Just 1) 128 | 129 | asInt64 <- lookup cfg "aa" :: IO (Maybe Int64) 130 | assertEqual "int64" asInt64 (Just 1) 131 | 132 | asWord8 <- lookup cfg "aa" :: IO (Maybe Word8) 133 | assertEqual "word8" asWord8 (Just 1) 134 | 135 | asWord16 <- lookup cfg "aa" :: IO (Maybe Word16) 136 | assertEqual "word16" asWord16 (Just 1) 137 | 138 | asWord32 <- lookup cfg "aa" :: IO (Maybe Word32) 139 | assertEqual "word32" asWord32 (Just 1) 140 | 141 | asWord64 <- lookup cfg "aa" :: IO (Maybe Word64) 142 | assertEqual "word64" asWord64 (Just 1) 143 | 144 | asTextBad <- lookup cfg "aa" :: IO (Maybe Text) 145 | assertEqual "bad text" asTextBad Nothing 146 | 147 | asTextGood <- lookup cfg "ab" :: IO (Maybe Text) 148 | assertEqual "good text" asTextGood (Just "foo") 149 | 150 | asStringGood <- lookup cfg "ab" :: IO (Maybe String) 151 | assertEqual "string" asStringGood (Just "foo") 152 | 153 | asInts <- lookup cfg "xs" :: IO (Maybe [Int]) 154 | assertEqual "ints" asInts (Just [1,2,3]) 155 | 156 | asChar <- lookup cfg "c" :: IO (Maybe Char) 157 | assertEqual "char" asChar (Just 'x') 158 | 159 | interpTest :: Assertion 160 | interpTest = 161 | withLoad "pathological.cfg" $ \cfg -> do 162 | home <- getEnv "HOME" 163 | cfgHome <- lookup cfg "ba" 164 | assertEqual "home interp" (Just home) cfgHome 165 | 166 | scopedInterpTest :: Assertion 167 | scopedInterpTest = withLoad "interp.cfg" $ \cfg -> do 168 | home <- getEnv "HOME" 169 | 170 | lookup cfg "myprogram.exec" 171 | >>= assertEqual "myprogram.exec" (Just $ home++"/services/myprogram/myprogram") 172 | 173 | lookup cfg "myprogram.stdout" 174 | >>= assertEqual "myprogram.stdout" (Just $ home++"/services/myprogram/stdout") 175 | 176 | lookup cfg "top.layer1.layer2.dir" 177 | >>= assertEqual "nested scope" (Just $ home++"/top/layer1/layer2") 178 | 179 | importTest :: Assertion 180 | importTest = 181 | withLoad "import.cfg" $ \cfg -> do 182 | aa <- lookup cfg "x.aa" :: IO (Maybe Int) 183 | assertEqual "simple" aa (Just 1) 184 | acx <- lookup cfg "x.ac.x" :: IO (Maybe Int) 185 | assertEqual "nested" acx (Just 1) 186 | 187 | reloadTest :: Assertion 188 | reloadTest = 189 | withReload "pathological.cfg" $ \[Just f] cfg -> do 190 | aa <- lookup cfg "aa" 191 | assertEqual "simple property 1" aa $ Just (1 :: Int) 192 | 193 | dongly <- newEmptyMVar 194 | wongly <- newEmptyMVar 195 | subscribe cfg "dongly" $ \ _ _ -> putMVar dongly () 196 | subscribe cfg "wongly" $ \ _ _ -> putMVar wongly () 197 | L.appendFile f "\ndongly = 1" 198 | r1 <- takeMVarTimeout 2000 dongly 199 | assertEqual "notify happened" r1 (Just ()) 200 | r2 <- takeMVarTimeout 2000 wongly 201 | assertEqual "notify not happened" r2 Nothing 202 | -------------------------------------------------------------------------------- /tests/resources/import.cfg: -------------------------------------------------------------------------------- 1 | x { 2 | import "pathological.cfg" 3 | } 4 | 5 | -------------------------------------------------------------------------------- /tests/resources/interp.cfg: -------------------------------------------------------------------------------- 1 | services = "$(HOME)/services" 2 | root = "can be overwritten by inner block." 3 | myprogram { 4 | name = "myprogram" 5 | root = "$(services)/$(name)" 6 | exec = "$(root)/$(name)" 7 | stdout = "$(root)/stdout" 8 | stderr = "$(root)/stderr" 9 | delay = 1 10 | } 11 | dir = "$(HOME)" 12 | top { 13 | dir = "$(dir)/top" 14 | layer1 { 15 | dir = "$(dir)/layer1" 16 | layer2 { 17 | dir = "$(dir)/layer2" 18 | } 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /tests/resources/pathological.cfg: -------------------------------------------------------------------------------- 1 | # Comment 2 | 3 | aa # Comment 4 | = # Comment 5 | 1 # Comment 6 | 7 | ab = 8 | "foo" 9 | 10 | 11 | ac { 12 | # fnord 13 | x=1 14 | 15 | y=true 16 | 17 | #blorg 18 | } 19 | 20 | ad = false 21 | ae = 1 22 | af 23 | = 24 | [ 25 | 2 26 | #foo 27 | , 28 | #bar 29 | 3 30 | #baz 31 | ]#quux 32 | 33 | ag { q-e { i_u9 { a=false}}} 34 | 35 | ba = "$(HOME)" 36 | 37 | xs = [1,2,3] 38 | 39 | c = "x" 40 | --------------------------------------------------------------------------------