diff --git a/Angel/Config.hs b/Angel/Config.hs --- a/Angel/Config.hs +++ b/Angel/Config.hs @@ -1,37 +1,71 @@ module Angel.Config where +import Control.Exception (try, SomeException) import qualified Data.Map as M +import Control.Monad (when, mapM_, void) import Control.Concurrent.STM import Control.Concurrent.STM.TVar (readTVar, writeTVar) -import Text.ParserCombinators.Parsec.Error (ParseError) +import Data.Configurator (load, getMap, Worth(..)) +import Data.Configurator.Types (Config, Value(..), Name) +import qualified Data.HashMap.Lazy as HM +import Data.String.Utils (split) +import Data.List (foldl') +import qualified Data.Text as T -import Angel.Parse (parseConfig) import Angel.Job (syncSupervisors) import Angel.Data import Angel.Log (logger) import Angel.Util (waitForWake) +import Debug.Trace (trace) + -- |produce a mapping of name -> program for every program -buildConfigMap :: Spec -> SpecKey -buildConfigMap cfg = M.fromList [(name p, p) | p <- cfg] +buildConfigMap :: HM.HashMap Name Value -> IO SpecKey +buildConfigMap cfg = + return $! HM.foldlWithKey' addToMap M.empty $ cfg + where + addToMap :: SpecKey -> Name -> Value -> SpecKey + addToMap m key value = + let !newprog = case M.lookup basekey m of + Just prog -> modifyProg prog localkey value + Nothing -> modifyProg defaultProgram{name=basekey} localkey value + in + M.insert basekey newprog m + where + (basekey:localkey:[]) = split "." (T.unpack key) +checkConfigValues :: SpecKey -> IO SpecKey +checkConfigValues progs = (mapM_ checkProgram $ M.elems progs) >> (return progs) + where + checkProgram p = void $ when (exec p == "") $ error $ name p ++ " does not have an 'exec' specification" + +modifyProg :: Program -> String -> Value -> Program +modifyProg prog "exec" (String s) = prog{exec = (T.unpack s)} +modifyProg prog "exec" _ = error "wrong type for field 'exec'; string required" + +modifyProg prog "delay" (Number n) | n < 0 = error "delay value must be >= 0" + | otherwise = prog{delay = (fromIntegral n)} +modifyProg prog "delay" _ = error "wrong type for field 'delay'; integer" + +modifyProg prog "stdout" (String s) = prog{stdout = (T.unpack s)} +modifyProg prog "stdout" _ = error "wrong type for field 'stdout'; string required" + +modifyProg prog "stderr" (String s) = prog{stderr = (T.unpack s)} +modifyProg prog "stderr" _ = error "wrong type for field 'stderr'; string required" + +modifyProg prog n _ = error $ "unrecognized field: " ++ n + + -- |invoke the parser to process the file at configPath -- |produce a SpecKey processConfig :: String -> IO (Either String SpecKey) processConfig configPath = do - mc <- catch ( do - c <- readFile configPath - return $ Just c - ) (\e-> return Nothing) + mconf <- try $ load [Required configPath] >>= getMap >>= buildConfigMap >>= checkConfigValues - res <- case mc of - Just c -> do - let cfg = parseConfig c - case cfg of - Left e -> return $ Left $ show e - Right cfg -> do return $ Right $ buildConfigMap cfg - Nothing -> return $ Left ("could not read config file at " ++ configPath) - return res + case mconf of + Right config -> return $ Right config + Left (e :: SomeException) -> return $ Left $ show e + -- |given a new SpecKey just parsed from the file, update the -- |shared state TVar @@ -51,6 +85,7 @@ log $ " <<<< Config Error >>>>\n" ++ e log " <<<< Config Error: Skipping reload >>>>" Right spec -> do + print spec atomically $ updateSpecConfig sharedGroupConfig spec syncSupervisors sharedGroupConfig waitForWake wakeSig diff --git a/Angel/Parse.hs b/Angel/Parse.hs deleted file mode 100644 --- a/Angel/Parse.hs +++ /dev/null @@ -1,74 +0,0 @@ --- |Parse Angel configuration files--a parsec parser -module Angel.Parse where - -import Data.String.Utils (strip) -import Text.ParserCombinators.Parsec -import Data.Maybe (isJust) -import Data.Either (Either(..)) -import Control.Monad (foldM) - -import Angel.Data - -type Kw = Maybe (String, String) - -reqInt = manyTill (oneOf ['0'..'9']) (char '\n') "integer" -configString = manyTill anyChar $ char '\n' - -configLine :: GenParser Char st Kw -configLine = do - name <- manyTill (noneOf "[") (char ' ') - val <- case name of - "exec" -> configString - "delay" -> reqInt - "stdout" -> configString - "stderr" -> configString - "directory" -> configString - otherwise -> fail $ "unknown config verb '" ++ name ++ "'" - return $ Just (strip name, strip val) - -commentLine :: GenParser Char st Kw -commentLine = do - manyTill (oneOf " \t") $ char '#' - manyTill anyChar $ char '\n' - return Nothing - -emptyLine :: GenParser Char st Kw -emptyLine = manyTill (oneOf " \t\r") (char '\n') >> return Nothing - -header = do - char '[' "start program id" - name <- manyTill anyChar $ char ']' - manyTill (oneOf " \t\r") $ char '\n' - return name - -program = do - given_id <- header - kw <- many $ (emptyLine <|> commentLine <|> configLine) - let real_kw = filter isJust kw - let prg = defaultProgram{name=given_id} - prg <- foldM setAttr prg real_kw - mapM_ (check_set prg) [("exec", exec), ("name", name)] - return prg - - where - - setAttr prg (Just (n, v)) = case n of - "exec" -> return prg{exec=v} - "delay" -> return prg{delay=(read v)::Int} - "stdout" -> return prg{stdout=v} - "stderr" -> return prg{stderr=v} - "directory" -> return prg { workingDir = Just v } - otherwise -> fail $ "unknown config keyword " ++ n - setAttr _ _ = fail "non-just in setAttr argument??" - - check_set prg (name, f) = if f prg == f defaultProgram - then fail $ name ++ " must be set for all programs" - else return () - -configFile :: GenParser Char st Spec -configFile = do - many $ (emptyLine <|> commentLine) - return =<< manyTill program eof - -parseConfig :: String -> Either ParseError Spec -parseConfig input = parse configFile "(config)" input diff --git a/angel.cabal b/angel.cabal --- a/angel.cabal +++ b/angel.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.2.1 +Version: 0.3 -- A short (one-line) description of the package. -- Synopsis: @@ -70,12 +70,14 @@ Build-depends: process >= 1.0 Build-depends: mtl Build-depends: MissingH - Build-depends: parsec + Build-depends: configurator >= 0.1 Build-depends: stm >= 2.0 Build-depends: containers >= 0.3 + Build-depends: unordered-containers >= 0.1.4 Build-depends: unix >= 2.4 Build-depends: old-time Build-depends: old-locale + Build-depends: text>=0.11 -- Modules not exported by this package. @@ -85,10 +87,11 @@ Angel.Files, Angel.Job, Angel.Log, - Angel.Parse, Angel.Util -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: + + Extensions: OverloadedStrings,ScopedTypeVariables Ghc-Options: -threaded