PageRenderTime 3ms CodeModel.GetById 3ms app.highlight 4ms RepoModel.GetById 1ms app.codeStats 0ms

/Angel/Config.hs

http://github.com/jamwt/Angel
Haskell | 99 lines | 74 code | 18 blank | 7 comment | 6 complexity | bb3d46a73e1db97160fd41c67b7c3937 MD5 | raw file
 1module Angel.Config where
 2
 3import Control.Exception (try, SomeException)
 4import qualified Data.Map as M
 5import Control.Monad (when, mapM_)
 6import Control.Concurrent.STM
 7import Control.Concurrent.STM.TVar (readTVar, writeTVar)
 8import Data.Configurator (load, getMap, Worth(..))
 9import Data.Configurator.Types (Config, Value(..), Name)
10import qualified Data.HashMap.Lazy as HM
11import Data.String.Utils (split)
12import Data.List (foldl')
13import qualified Data.Text as T
14
15import Angel.Job (syncSupervisors)
16import Angel.Data
17import Angel.Log (logger)
18import Angel.Util (waitForWake)
19
20import Debug.Trace (trace)
21
22void :: Monad m => m a -> m ()
23void m = m >> return ()
24
25-- |produce a mapping of name -> program for every program
26buildConfigMap :: HM.HashMap Name Value -> IO SpecKey
27buildConfigMap cfg = 
28    return $! HM.foldlWithKey' addToMap M.empty $ cfg
29  where
30    addToMap :: SpecKey -> Name -> Value -> SpecKey
31    addToMap m 
32             (split "." . T.unpack -> [basekey, localkey])
33             value =
34        let !newprog = case M.lookup basekey m of
35                          Just prog -> modifyProg prog localkey value
36                          Nothing   -> modifyProg defaultProgram{name=basekey} localkey value
37            in
38        M.insert basekey newprog m
39    addToMap m _ _ = m
40
41checkConfigValues :: SpecKey -> IO SpecKey
42checkConfigValues progs = (mapM_ checkProgram $ M.elems progs) >> (return progs)
43  where
44    checkProgram p = void $ when (exec p == Nothing) $ error $ name p ++ " does not have an 'exec' specification"
45
46modifyProg :: Program -> String -> Value -> Program
47modifyProg prog "exec" (String s) = prog{exec = Just (T.unpack s)}
48modifyProg prog "exec" _ = error "wrong type for field 'exec'; string required"
49
50modifyProg prog "delay" (Number n) | n < 0     = error "delay value must be >= 0"
51                                   | otherwise = prog{delay = Just $ round n}
52modifyProg prog "delay" _ = error "wrong type for field 'delay'; integer"
53
54modifyProg prog "stdout" (String s) = prog{stdout = Just (T.unpack s)}
55modifyProg prog "stdout" _ = error "wrong type for field 'stdout'; string required"
56
57modifyProg prog "stderr" (String s) = prog{stderr = Just (T.unpack s)}
58modifyProg prog "stderr" _ = error "wrong type for field 'stderr'; string required"
59
60modifyProg prog "directory" (String s) = prog{workingDir = (Just $ T.unpack s)}
61modifyProg prog "directory" _ = error "wrong type for field 'directory'; string required"
62
63modifyProg prog n _ = prog
64
65
66-- |invoke the parser to process the file at configPath
67-- |produce a SpecKey
68processConfig :: String -> IO (Either String SpecKey)
69processConfig configPath = do 
70    mconf <- try $ load [Required configPath] >>= getMap >>= buildConfigMap >>= checkConfigValues
71
72    case mconf of
73        Right config -> return $ Right config
74        Left (e :: SomeException) -> return $ Left $ show e
75    
76
77-- |given a new SpecKey just parsed from the file, update the 
78-- |shared state TVar
79updateSpecConfig :: TVar GroupConfig -> SpecKey -> STM ()
80updateSpecConfig sharedGroupConfig spec = do 
81    cfg <- readTVar sharedGroupConfig
82    writeTVar sharedGroupConfig cfg{spec=spec}
83
84-- |read the config file, update shared state with current spec, 
85-- |re-sync running supervisors, wait for the HUP TVar, then repeat!
86monitorConfig :: String -> TVar GroupConfig -> TVar (Maybe Int) -> IO ()
87monitorConfig configPath sharedGroupConfig wakeSig = do 
88    let log = logger "config-monitor"
89    mspec <- processConfig configPath
90    case mspec of 
91        Left e     -> do 
92            log $ " <<<< Config Error >>>>\n" ++ e
93            log " <<<< Config Error: Skipping reload >>>>"
94        Right spec -> do 
95            print spec
96            atomically $ updateSpecConfig sharedGroupConfig spec
97            syncSupervisors sharedGroupConfig
98    waitForWake wakeSig
99    log "HUP caught, reloading config"