root / src / Ganeti / Confd / Server.hs @ a8cbe1d7
History | View | Annotate | Download (20.7 kB)
1 |
{-# LANGUAGE BangPatterns #-} |
---|---|
2 |
|
3 |
{-| Implementation of the Ganeti confd server functionality. |
4 |
|
5 |
-} |
6 |
|
7 |
{- |
8 |
|
9 |
Copyright (C) 2011, 2012, 2013 Google Inc. |
10 |
|
11 |
This program is free software; you can redistribute it and/or modify |
12 |
it under the terms of the GNU General Public License as published by |
13 |
the Free Software Foundation; either version 2 of the License, or |
14 |
(at your option) any later version. |
15 |
|
16 |
This program is distributed in the hope that it will be useful, but |
17 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
18 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
19 |
General Public License for more details. |
20 |
|
21 |
You should have received a copy of the GNU General Public License |
22 |
along with this program; if not, write to the Free Software |
23 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
24 |
02110-1301, USA. |
25 |
|
26 |
-} |
27 |
|
28 |
module Ganeti.Confd.Server |
29 |
( main |
30 |
, checkMain |
31 |
, prepMain |
32 |
) where |
33 |
|
34 |
import Control.Concurrent |
35 |
import Control.Exception |
36 |
import Control.Monad (forever, liftM, unless) |
37 |
import Data.IORef |
38 |
import Data.List |
39 |
import qualified Data.Map as M |
40 |
import Data.Maybe (fromMaybe) |
41 |
import qualified Network.Socket as S |
42 |
import System.Exit |
43 |
import System.IO |
44 |
import System.Posix.Files |
45 |
import System.Posix.Types |
46 |
import qualified Text.JSON as J |
47 |
import System.INotify |
48 |
|
49 |
import Ganeti.BasicTypes |
50 |
import Ganeti.Errors |
51 |
import Ganeti.Daemon |
52 |
import Ganeti.JSON |
53 |
import Ganeti.Objects |
54 |
import Ganeti.Confd.Types |
55 |
import Ganeti.Confd.Utils |
56 |
import Ganeti.Config |
57 |
import Ganeti.Hash |
58 |
import Ganeti.Logging |
59 |
import qualified Ganeti.Constants as C |
60 |
import qualified Ganeti.Path as Path |
61 |
import Ganeti.Query.Server (prepQueryD, runQueryD) |
62 |
import qualified Ganeti.Query.Cluster as QCluster |
63 |
import Ganeti.Utils |
64 |
|
65 |
-- * Types and constants definitions |
66 |
|
67 |
-- | What we store as configuration. |
68 |
type CRef = IORef (Result (ConfigData, LinkIpMap)) |
69 |
|
70 |
-- | File stat identifier. |
71 |
type FStat = (EpochTime, FileID, FileOffset) |
72 |
|
73 |
-- | Null 'FStat' value. |
74 |
nullFStat :: FStat |
75 |
nullFStat = (-1, -1, -1) |
76 |
|
77 |
-- | A small type alias for readability. |
78 |
type StatusAnswer = (ConfdReplyStatus, J.JSValue) |
79 |
|
80 |
-- | Reload model data type. |
81 |
data ReloadModel = ReloadNotify -- ^ We are using notifications |
82 |
| ReloadPoll Int -- ^ We are using polling |
83 |
deriving (Eq, Show) |
84 |
|
85 |
-- | Server state data type. |
86 |
data ServerState = ServerState |
87 |
{ reloadModel :: ReloadModel |
88 |
, reloadTime :: Integer -- ^ Reload time (epoch) in microseconds |
89 |
, reloadFStat :: FStat |
90 |
} |
91 |
|
92 |
-- | Maximum no-reload poll rounds before reverting to inotify. |
93 |
maxIdlePollRounds :: Int |
94 |
maxIdlePollRounds = 3 |
95 |
|
96 |
-- | Reload timeout in microseconds. |
97 |
watchInterval :: Int |
98 |
watchInterval = C.confdConfigReloadTimeout * 1000000 |
99 |
|
100 |
-- | Ratelimit timeout in microseconds. |
101 |
pollInterval :: Int |
102 |
pollInterval = C.confdConfigReloadRatelimit |
103 |
|
104 |
-- | Ratelimit timeout in microseconds, as an 'Integer'. |
105 |
reloadRatelimit :: Integer |
106 |
reloadRatelimit = fromIntegral C.confdConfigReloadRatelimit |
107 |
|
108 |
-- | Initial poll round. |
109 |
initialPoll :: ReloadModel |
110 |
initialPoll = ReloadPoll 0 |
111 |
|
112 |
-- | Reload status data type. |
113 |
data ConfigReload = ConfigToDate -- ^ No need to reload |
114 |
| ConfigReloaded -- ^ Configuration reloaded |
115 |
| ConfigIOError -- ^ Error during configuration reload |
116 |
deriving (Eq) |
117 |
|
118 |
-- | Unknown entry standard response. |
119 |
queryUnknownEntry :: StatusAnswer |
120 |
queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry) |
121 |
|
122 |
{- not used yet |
123 |
-- | Internal error standard response. |
124 |
queryInternalError :: StatusAnswer |
125 |
queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal) |
126 |
-} |
127 |
|
128 |
-- | Argument error standard response. |
129 |
queryArgumentError :: StatusAnswer |
130 |
queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument) |
131 |
|
132 |
-- | Converter from specific error to a string format. |
133 |
gntErrorToResult :: ErrorResult a -> Result a |
134 |
gntErrorToResult (Bad err) = Bad (show err) |
135 |
gntErrorToResult (Ok x) = Ok x |
136 |
|
137 |
-- * Confd base functionality |
138 |
|
139 |
-- | Computes the node role. |
140 |
nodeRole :: ConfigData -> String -> Result ConfdNodeRole |
141 |
nodeRole cfg name = do |
142 |
cmaster <- errToResult $ QCluster.clusterMasterNodeName cfg |
143 |
mnode <- errToResult $ getNode cfg name |
144 |
let role = case mnode of |
145 |
node | cmaster == name -> NodeRoleMaster |
146 |
| nodeDrained node -> NodeRoleDrained |
147 |
| nodeOffline node -> NodeRoleOffline |
148 |
| nodeMasterCandidate node -> NodeRoleCandidate |
149 |
_ -> NodeRoleRegular |
150 |
return role |
151 |
|
152 |
-- | Does an instance ip -> instance -> primary node -> primary ip |
153 |
-- transformation. |
154 |
getNodePipByInstanceIp :: ConfigData |
155 |
-> LinkIpMap |
156 |
-> String |
157 |
-> String |
158 |
-> StatusAnswer |
159 |
getNodePipByInstanceIp cfg linkipmap link instip = |
160 |
case M.lookup instip (M.findWithDefault M.empty link linkipmap) of |
161 |
Nothing -> queryUnknownEntry |
162 |
Just instname -> |
163 |
case getInstPrimaryNode cfg instname of |
164 |
Bad _ -> queryUnknownEntry -- either instance or node not found |
165 |
Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node)) |
166 |
|
167 |
-- | Builds the response to a given query. |
168 |
buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer |
169 |
buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) = |
170 |
return (ReplyStatusOk, J.showJSON (configVersion cfg)) |
171 |
|
172 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) = |
173 |
case confdRqQuery req of |
174 |
EmptyQuery -> liftM ((,) ReplyStatusOk . J.showJSON) master_name |
175 |
PlainQuery _ -> return queryArgumentError |
176 |
DictQuery reqq -> do |
177 |
mnode <- gntErrorToResult $ getNode cfg master_uuid |
178 |
mname <- master_name |
179 |
let fvals = map (\field -> case field of |
180 |
ReqFieldName -> mname |
181 |
ReqFieldIp -> clusterMasterIp cluster |
182 |
ReqFieldMNodePip -> nodePrimaryIp mnode |
183 |
) (confdReqQFields reqq) |
184 |
return (ReplyStatusOk, J.showJSON fvals) |
185 |
where master_uuid = clusterMasterNode cluster |
186 |
master_name = errToResult $ QCluster.clusterMasterNodeName cfg |
187 |
cluster = configCluster cfg |
188 |
cfg = fst cdata |
189 |
|
190 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do |
191 |
node_name <- case confdRqQuery req of |
192 |
PlainQuery str -> return str |
193 |
_ -> fail $ "Invalid query type " ++ show (confdRqQuery req) |
194 |
role <- nodeRole (fst cdata) node_name |
195 |
return (ReplyStatusOk, J.showJSON role) |
196 |
|
197 |
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) = |
198 |
-- note: we use foldlWithKey because that's present accross more |
199 |
-- versions of the library |
200 |
return (ReplyStatusOk, J.showJSON $ |
201 |
M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) [] |
202 |
(fromContainer . configNodes . fst $ cdata)) |
203 |
|
204 |
buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) = |
205 |
-- note: we use foldlWithKey because that's present accross more |
206 |
-- versions of the library |
207 |
return (ReplyStatusOk, J.showJSON $ |
208 |
M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n |
209 |
then nodePrimaryIp n:accu |
210 |
else accu) [] |
211 |
(fromContainer . configNodes . fst $ cdata)) |
212 |
|
213 |
buildResponse (cfg, linkipmap) |
214 |
req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do |
215 |
link <- case confdRqQuery req of |
216 |
PlainQuery str -> return str |
217 |
EmptyQuery -> return (getDefaultNicLink cfg) |
218 |
_ -> fail "Invalid query type" |
219 |
return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link) |
220 |
|
221 |
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip |
222 |
, confdRqQuery = DictQuery query}) = |
223 |
let (cfg, linkipmap) = cdata |
224 |
link = fromMaybe (getDefaultNicLink cfg) (confdReqQLink query) |
225 |
in case confdReqQIp query of |
226 |
Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip |
227 |
Nothing -> return (ReplyStatusOk, |
228 |
J.showJSON $ |
229 |
map (getNodePipByInstanceIp cfg linkipmap link) |
230 |
(confdReqQIpList query)) |
231 |
|
232 |
buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) = |
233 |
return queryArgumentError |
234 |
|
235 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do |
236 |
let cfg = fst cdata |
237 |
node_name <- case confdRqQuery req of |
238 |
PlainQuery str -> return str |
239 |
_ -> fail $ "Invalid query type " ++ show (confdRqQuery req) |
240 |
node <- gntErrorToResult $ getNode cfg node_name |
241 |
let minors = concatMap (getInstMinorsForNode (nodeName node)) . |
242 |
M.elems . fromContainer . configInstances $ cfg |
243 |
encoded = [J.JSArray [J.showJSON a, J.showJSON b, J.showJSON c, |
244 |
J.showJSON d, J.showJSON e, J.showJSON f] | |
245 |
(a, b, c, d, e, f) <- minors] |
246 |
return (ReplyStatusOk, J.showJSON encoded) |
247 |
|
248 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeInstances }) = do |
249 |
let cfg = fst cdata |
250 |
node_name <- case confdRqQuery req of |
251 |
PlainQuery str -> return str |
252 |
_ -> fail $ "Invalid query type " ++ show (confdRqQuery req) |
253 |
let instances = getNodeInstances cfg node_name |
254 |
return (ReplyStatusOk, J.showJSON instances) |
255 |
|
256 |
-- | Creates a ConfdReply from a given answer. |
257 |
serializeResponse :: Result StatusAnswer -> ConfdReply |
258 |
serializeResponse r = |
259 |
let (status, result) = case r of |
260 |
Bad err -> (ReplyStatusError, J.showJSON err) |
261 |
Ok (code, val) -> (code, val) |
262 |
in ConfdReply { confdReplyProtocol = 1 |
263 |
, confdReplyStatus = status |
264 |
, confdReplyAnswer = result |
265 |
, confdReplySerial = 0 } |
266 |
|
267 |
-- * Configuration handling |
268 |
|
269 |
-- ** Helper functions |
270 |
|
271 |
-- | Helper function for logging transition into polling mode. |
272 |
moveToPolling :: String -> INotify -> FilePath -> CRef -> MVar ServerState |
273 |
-> IO ReloadModel |
274 |
moveToPolling msg inotify path cref mstate = do |
275 |
logInfo $ "Moving to polling mode: " ++ msg |
276 |
let inotiaction = addNotifier inotify path cref mstate |
277 |
_ <- forkIO $ onPollTimer inotiaction path cref mstate |
278 |
return initialPoll |
279 |
|
280 |
-- | Helper function for logging transition into inotify mode. |
281 |
moveToNotify :: IO ReloadModel |
282 |
moveToNotify = do |
283 |
logInfo "Moving to inotify mode" |
284 |
return ReloadNotify |
285 |
|
286 |
-- ** Configuration loading |
287 |
|
288 |
-- | (Re)loads the configuration. |
289 |
updateConfig :: FilePath -> CRef -> IO () |
290 |
updateConfig path r = do |
291 |
newcfg <- loadConfig path |
292 |
let !newdata = case newcfg of |
293 |
Ok !cfg -> Ok (cfg, buildLinkIpInstnameMap cfg) |
294 |
Bad _ -> Bad "Cannot load configuration" |
295 |
writeIORef r newdata |
296 |
case newcfg of |
297 |
Ok cfg -> logInfo ("Loaded new config, serial " ++ |
298 |
show (configSerial cfg)) |
299 |
Bad msg -> logError $ "Failed to load config: " ++ msg |
300 |
return () |
301 |
|
302 |
-- | Wrapper over 'updateConfig' that handles IO errors. |
303 |
safeUpdateConfig :: FilePath -> FStat -> CRef -> IO (FStat, ConfigReload) |
304 |
safeUpdateConfig path oldfstat cref = |
305 |
Control.Exception.catch |
306 |
(do |
307 |
nt <- needsReload oldfstat path |
308 |
case nt of |
309 |
Nothing -> return (oldfstat, ConfigToDate) |
310 |
Just nt' -> do |
311 |
updateConfig path cref |
312 |
return (nt', ConfigReloaded) |
313 |
) (\e -> do |
314 |
let msg = "Failure during configuration update: " ++ |
315 |
show (e::IOError) |
316 |
writeIORef cref (Bad msg) |
317 |
return (nullFStat, ConfigIOError) |
318 |
) |
319 |
|
320 |
-- | Computes the file cache data from a FileStatus structure. |
321 |
buildFileStatus :: FileStatus -> FStat |
322 |
buildFileStatus ofs = |
323 |
let modt = modificationTime ofs |
324 |
inum = fileID ofs |
325 |
fsize = fileSize ofs |
326 |
in (modt, inum, fsize) |
327 |
|
328 |
-- | Wrapper over 'buildFileStatus'. This reads the data from the |
329 |
-- filesystem and then builds our cache structure. |
330 |
getFStat :: FilePath -> IO FStat |
331 |
getFStat p = liftM buildFileStatus (getFileStatus p) |
332 |
|
333 |
-- | Check if the file needs reloading |
334 |
needsReload :: FStat -> FilePath -> IO (Maybe FStat) |
335 |
needsReload oldstat path = do |
336 |
newstat <- getFStat path |
337 |
return $ if newstat /= oldstat |
338 |
then Just newstat |
339 |
else Nothing |
340 |
|
341 |
-- ** Watcher threads |
342 |
|
343 |
-- $watcher |
344 |
-- We have three threads/functions that can mutate the server state: |
345 |
-- |
346 |
-- 1. the long-interval watcher ('onWatcherTimer') |
347 |
-- |
348 |
-- 2. the polling watcher ('onPollTimer') |
349 |
-- |
350 |
-- 3. the inotify event handler ('onInotify') |
351 |
-- |
352 |
-- All of these will mutate the server state under 'modifyMVar' or |
353 |
-- 'modifyMVar_', so that server transitions are more or less |
354 |
-- atomic. The inotify handler remains active during polling mode, but |
355 |
-- checks for polling mode and doesn't do anything in this case (this |
356 |
-- check is needed even if we would unregister the event handler due |
357 |
-- to how events are serialised). |
358 |
|
359 |
-- | Long-interval reload watcher. |
360 |
-- |
361 |
-- This is on top of the inotify-based triggered reload. |
362 |
onWatcherTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO () |
363 |
onWatcherTimer inotiaction path cref state = do |
364 |
threadDelay watchInterval |
365 |
logDebug "Watcher timer fired" |
366 |
modifyMVar_ state (onWatcherInner path cref) |
367 |
_ <- inotiaction |
368 |
onWatcherTimer inotiaction path cref state |
369 |
|
370 |
-- | Inner onWatcher handler. |
371 |
-- |
372 |
-- This mutates the server state under a modifyMVar_ call. It never |
373 |
-- changes the reload model, just does a safety reload and tried to |
374 |
-- re-establish the inotify watcher. |
375 |
onWatcherInner :: FilePath -> CRef -> ServerState -> IO ServerState |
376 |
onWatcherInner path cref state = do |
377 |
(newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref |
378 |
return state { reloadFStat = newfstat } |
379 |
|
380 |
-- | Short-interval (polling) reload watcher. |
381 |
-- |
382 |
-- This is only active when we're in polling mode; it will |
383 |
-- automatically exit when it detects that the state has changed to |
384 |
-- notification. |
385 |
onPollTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO () |
386 |
onPollTimer inotiaction path cref state = do |
387 |
threadDelay pollInterval |
388 |
logDebug "Poll timer fired" |
389 |
continue <- modifyMVar state (onPollInner inotiaction path cref) |
390 |
if continue |
391 |
then onPollTimer inotiaction path cref state |
392 |
else logDebug "Inotify watch active, polling thread exiting" |
393 |
|
394 |
-- | Inner onPoll handler. |
395 |
-- |
396 |
-- This again mutates the state under a modifyMVar call, and also |
397 |
-- returns whether the thread should continue or not. |
398 |
onPollInner :: IO Bool -> FilePath -> CRef -> ServerState |
399 |
-> IO (ServerState, Bool) |
400 |
onPollInner _ _ _ state@(ServerState { reloadModel = ReloadNotify } ) = |
401 |
return (state, False) |
402 |
onPollInner inotiaction path cref |
403 |
state@(ServerState { reloadModel = ReloadPoll pround } ) = do |
404 |
(newfstat, reload) <- safeUpdateConfig path (reloadFStat state) cref |
405 |
let state' = state { reloadFStat = newfstat } |
406 |
-- compute new poll model based on reload data; however, failure to |
407 |
-- re-establish the inotifier means we stay on polling |
408 |
newmode <- case reload of |
409 |
ConfigToDate -> |
410 |
if pround >= maxIdlePollRounds |
411 |
then do -- try to switch to notify |
412 |
result <- inotiaction |
413 |
if result |
414 |
then moveToNotify |
415 |
else return initialPoll |
416 |
else return (ReloadPoll (pround + 1)) |
417 |
_ -> return initialPoll |
418 |
let continue = case newmode of |
419 |
ReloadNotify -> False |
420 |
_ -> True |
421 |
return (state' { reloadModel = newmode }, continue) |
422 |
|
423 |
-- the following hint is because hlint doesn't understand our const |
424 |
-- (return False) is so that we can give a signature to 'e' |
425 |
{-# ANN addNotifier "HLint: ignore Evaluate" #-} |
426 |
-- | Setup inotify watcher. |
427 |
-- |
428 |
-- This tries to setup the watch descriptor; in case of any IO errors, |
429 |
-- it will return False. |
430 |
addNotifier :: INotify -> FilePath -> CRef -> MVar ServerState -> IO Bool |
431 |
addNotifier inotify path cref mstate = |
432 |
Control.Exception.catch |
433 |
(addWatch inotify [CloseWrite] path |
434 |
(onInotify inotify path cref mstate) >> return True) |
435 |
(\e -> const (return False) (e::IOError)) |
436 |
|
437 |
-- | Inotify event handler. |
438 |
onInotify :: INotify -> String -> CRef -> MVar ServerState -> Event -> IO () |
439 |
onInotify inotify path cref mstate Ignored = do |
440 |
logDebug "File lost, trying to re-establish notifier" |
441 |
modifyMVar_ mstate $ \state -> do |
442 |
result <- addNotifier inotify path cref mstate |
443 |
(newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref |
444 |
let state' = state { reloadFStat = newfstat } |
445 |
if result |
446 |
then return state' -- keep notify |
447 |
else do |
448 |
mode <- moveToPolling "cannot re-establish inotify watch" inotify |
449 |
path cref mstate |
450 |
return state' { reloadModel = mode } |
451 |
|
452 |
onInotify inotify path cref mstate _ = |
453 |
modifyMVar_ mstate $ \state -> |
454 |
if reloadModel state == ReloadNotify |
455 |
then do |
456 |
ctime <- getCurrentTimeUSec |
457 |
(newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref |
458 |
let state' = state { reloadFStat = newfstat, reloadTime = ctime } |
459 |
if abs (reloadTime state - ctime) < reloadRatelimit |
460 |
then do |
461 |
mode <- moveToPolling "too many reloads" inotify path cref mstate |
462 |
return state' { reloadModel = mode } |
463 |
else return state' |
464 |
else return state |
465 |
|
466 |
-- ** Client input/output handlers |
467 |
|
468 |
-- | Main loop for a given client. |
469 |
responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO () |
470 |
responder cfgref socket hmac msg peer = do |
471 |
ctime <- getCurrentTime |
472 |
case parseRequest hmac msg ctime of |
473 |
Ok (origmsg, rq) -> do |
474 |
logDebug $ "Processing request: " ++ rStripSpace origmsg |
475 |
mcfg <- readIORef cfgref |
476 |
let response = respondInner mcfg hmac rq |
477 |
_ <- S.sendTo socket response peer |
478 |
return () |
479 |
Bad err -> logInfo $ "Failed to parse incoming message: " ++ err |
480 |
return () |
481 |
|
482 |
-- | Inner helper function for a given client. This generates the |
483 |
-- final encoded message (as a string), ready to be sent out to the |
484 |
-- client. |
485 |
respondInner :: Result (ConfigData, LinkIpMap) -> HashKey |
486 |
-> ConfdRequest -> String |
487 |
respondInner cfg hmac rq = |
488 |
let rsalt = confdRqRsalt rq |
489 |
innermsg = serializeResponse (cfg >>= flip buildResponse rq) |
490 |
innerserialised = J.encodeStrict innermsg |
491 |
outermsg = signMessage hmac rsalt innerserialised |
492 |
outerserialised = confdMagicFourcc ++ J.encodeStrict outermsg |
493 |
in outerserialised |
494 |
|
495 |
-- | Main listener loop. |
496 |
listener :: S.Socket -> HashKey |
497 |
-> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ()) |
498 |
-> IO () |
499 |
listener s hmac resp = do |
500 |
(msg, _, peer) <- S.recvFrom s 4096 |
501 |
if confdMagicFourcc `isPrefixOf` msg |
502 |
then forkIO (resp s hmac (drop 4 msg) peer) >> return () |
503 |
else logDebug "Invalid magic code!" >> return () |
504 |
return () |
505 |
|
506 |
-- | Extract the configuration from our IORef. |
507 |
configReader :: CRef -> IO (Result ConfigData) |
508 |
configReader cref = do |
509 |
cdata <- readIORef cref |
510 |
return $ liftM fst cdata |
511 |
|
512 |
-- | Type alias for prepMain results |
513 |
type PrepResult = (S.Socket, (FilePath, S.Socket), |
514 |
IORef (Result (ConfigData, LinkIpMap))) |
515 |
|
516 |
-- | Check function for confd. |
517 |
checkMain :: CheckFn (S.Family, S.SockAddr) |
518 |
checkMain opts = do |
519 |
parseresult <- parseAddress opts C.defaultConfdPort |
520 |
case parseresult of |
521 |
Bad msg -> do |
522 |
hPutStrLn stderr $ "parsing bind address: " ++ msg |
523 |
return . Left $ ExitFailure 1 |
524 |
Ok v -> return $ Right v |
525 |
|
526 |
-- | Prepare function for confd. |
527 |
prepMain :: PrepFn (S.Family, S.SockAddr) PrepResult |
528 |
prepMain _ (af_family, bindaddr) = do |
529 |
s <- S.socket af_family S.Datagram S.defaultProtocol |
530 |
S.bindSocket s bindaddr |
531 |
-- prepare the queryd listener |
532 |
query_data <- prepQueryD Nothing |
533 |
cref <- newIORef (Bad "Configuration not yet loaded") |
534 |
return (s, query_data, cref) |
535 |
|
536 |
-- | Main function. |
537 |
main :: MainFn (S.Family, S.SockAddr) PrepResult |
538 |
main _ _ (s, query_data, cref) = do |
539 |
-- Inotify setup |
540 |
inotify <- initINotify |
541 |
-- try to load the configuration, if possible |
542 |
conf_file <- Path.clusterConfFile |
543 |
(fstat, reloaded) <- safeUpdateConfig conf_file nullFStat cref |
544 |
ctime <- getCurrentTime |
545 |
statemvar <- newMVar $ ServerState ReloadNotify ctime fstat |
546 |
let inotiaction = addNotifier inotify conf_file cref statemvar |
547 |
has_inotify <- if reloaded == ConfigReloaded |
548 |
then inotiaction |
549 |
else return False |
550 |
if has_inotify |
551 |
then logInfo "Starting up in inotify mode" |
552 |
else do |
553 |
-- inotify was not enabled, we need to update the reload model |
554 |
logInfo "Starting up in polling mode" |
555 |
modifyMVar_ statemvar |
556 |
(\state -> return state { reloadModel = initialPoll }) |
557 |
hmac <- getClusterHmac |
558 |
-- fork the timeout timer |
559 |
_ <- forkIO $ onWatcherTimer inotiaction conf_file cref statemvar |
560 |
-- fork the polling timer |
561 |
unless has_inotify $ do |
562 |
_ <- forkIO $ onPollTimer inotiaction conf_file cref statemvar |
563 |
return () |
564 |
-- launch the queryd listener |
565 |
_ <- forkIO $ runQueryD query_data (configReader cref) |
566 |
-- and finally enter the responder loop |
567 |
forever $ listener s hmac (responder cref) |