1 {-# LANGUAGE BangPatterns #-}
3 {-| Implementation of the Ganeti confd server functionality.
9 Copyright (C) 2011, 2012 Google Inc.
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.
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.
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
28 module Ganeti.Confd.Server
32 import Control.Concurrent
33 import Control.Exception
34 import Control.Monad (forever, liftM, when)
37 import qualified Data.Map as M
38 import Data.Maybe (fromMaybe)
39 import qualified Network.Socket as S
40 import Prelude hiding (catch)
41 import System.Posix.Files
42 import System.Posix.Types
44 import qualified Text.JSON as J
49 import Ganeti.HTools.Types
50 import Ganeti.HTools.Utils
53 import Ganeti.Confd.Utils
57 import qualified Ganeti.Constants as C
58 import qualified Ganeti.Path as Path
59 import Ganeti.Query.Server (runQueryD)
61 -- * Types and constants definitions
63 -- | What we store as configuration.
64 type CRef = IORef (Result (ConfigData, LinkIpMap))
66 -- | File stat identifier.
67 type FStat = (EpochTime, FileID, FileOffset)
69 -- | Null 'FStat' value.
71 nullFStat = (-1, -1, -1)
73 -- | A small type alias for readability.
74 type StatusAnswer = (ConfdReplyStatus, J.JSValue)
76 -- | Reload model data type.
77 data ReloadModel = ReloadNotify -- ^ We are using notifications
78 | ReloadPoll Int -- ^ We are using polling
81 -- | Server state data type.
82 data ServerState = ServerState
83 { reloadModel :: ReloadModel
84 , reloadTime :: Integer
85 , reloadFStat :: FStat
88 -- | Maximum no-reload poll rounds before reverting to inotify.
89 maxIdlePollRounds :: Int
92 -- | Reload timeout in microseconds.
93 configReloadTimeout :: Int
94 configReloadTimeout = C.confdConfigReloadTimeout * 1000000
96 -- | Ratelimit timeout in microseconds.
97 configReloadRatelimit :: Int
98 configReloadRatelimit = C.confdConfigReloadRatelimit * 1000000
100 -- | Initial poll round.
101 initialPoll :: ReloadModel
102 initialPoll = ReloadPoll 0
104 -- | Initial server state.
105 initialState :: ServerState
106 initialState = ServerState initialPoll 0 nullFStat
108 -- | Reload status data type.
109 data ConfigReload = ConfigToDate -- ^ No need to reload
110 | ConfigReloaded -- ^ Configuration reloaded
111 | ConfigIOError -- ^ Error during configuration reload
113 -- | Unknown entry standard response.
114 queryUnknownEntry :: StatusAnswer
115 queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry)
118 -- | Internal error standard response.
119 queryInternalError :: StatusAnswer
120 queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
123 -- | Argument error standard response.
124 queryArgumentError :: StatusAnswer
125 queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument)
127 -- | Returns the current time.
128 getCurrentTime :: IO Integer
130 TOD ctime _ <- getClockTime
133 -- * Confd base functionality
135 -- | Computes the node role.
136 nodeRole :: ConfigData -> String -> Result ConfdNodeRole
138 let cmaster = clusterMasterNode . configCluster $ cfg
139 mnode = M.lookup name . fromContainer . configNodes $ cfg
141 Nothing -> Bad "Node not found"
142 Just node | cmaster == name -> Ok NodeRoleMaster
143 | nodeDrained node -> Ok NodeRoleDrained
144 | nodeOffline node -> Ok NodeRoleOffline
145 | nodeMasterCandidate node -> Ok NodeRoleCandidate
146 _ -> Ok NodeRoleRegular
148 -- | Does an instance ip -> instance -> primary node -> primary ip
150 getNodePipByInstanceIp :: ConfigData
155 getNodePipByInstanceIp cfg linkipmap link instip =
156 case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
157 Nothing -> queryUnknownEntry
159 case getInstPrimaryNode cfg instname of
160 Bad _ -> queryUnknownEntry -- either instance or node not found
161 Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node))
163 -- | Builds the response to a given query.
164 buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer
165 buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) =
166 return (ReplyStatusOk, J.showJSON (configVersion cfg))
168 buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
169 case confdRqQuery req of
170 EmptyQuery -> return (ReplyStatusOk, J.showJSON master_name)
171 PlainQuery _ -> return queryArgumentError
173 mnode <- getNode cfg master_name
174 let fvals =map (\field -> case field of
175 ReqFieldName -> master_name
176 ReqFieldIp -> clusterMasterIp cluster
177 ReqFieldMNodePip -> nodePrimaryIp mnode
178 ) (confdReqQFields reqq)
179 return (ReplyStatusOk, J.showJSON fvals)
180 where master_name = clusterMasterNode cluster
181 cluster = configCluster cfg
184 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do
185 node_name <- case confdRqQuery req of
186 PlainQuery str -> return str
187 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
188 role <- nodeRole (fst cdata) node_name
189 return (ReplyStatusOk, J.showJSON role)
191 buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) =
192 -- note: we use foldlWithKey because that's present accross more
193 -- versions of the library
194 return (ReplyStatusOk, J.showJSON $
195 M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) []
196 (fromContainer . configNodes . fst $ cdata))
198 buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
199 -- note: we use foldlWithKey because that's present accross more
200 -- versions of the library
201 return (ReplyStatusOk, J.showJSON $
202 M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n
203 then nodePrimaryIp n:accu
205 (fromContainer . configNodes . fst $ cdata))
207 buildResponse (cfg, linkipmap)
208 req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do
209 link <- case confdRqQuery req of
210 PlainQuery str -> return str
211 EmptyQuery -> return (getDefaultNicLink cfg)
212 _ -> fail "Invalid query type"
213 return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link)
215 buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip
216 , confdRqQuery = DictQuery query}) =
217 let (cfg, linkipmap) = cdata
218 link = fromMaybe (getDefaultNicLink cfg) (confdReqQLink query)
219 in case confdReqQIp query of
220 Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip
221 Nothing -> return (ReplyStatusOk,
223 map (getNodePipByInstanceIp cfg linkipmap link)
224 (confdReqQIpList query))
226 buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) =
227 return queryArgumentError
229 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do
231 node_name <- case confdRqQuery req of
232 PlainQuery str -> return str
233 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
234 node <- getNode cfg node_name
235 let minors = concatMap (getInstMinorsForNode (nodeName node)) .
236 M.elems . fromContainer . configInstances $ cfg
237 encoded = [J.JSArray [J.showJSON a, J.showJSON b, J.showJSON c,
238 J.showJSON d, J.showJSON e, J.showJSON f] |
239 (a, b, c, d, e, f) <- minors]
240 return (ReplyStatusOk, J.showJSON encoded)
242 -- | Creates a ConfdReply from a given answer.
243 serializeResponse :: Result StatusAnswer -> ConfdReply
244 serializeResponse r =
245 let (status, result) = case r of
246 Bad err -> (ReplyStatusError, J.showJSON err)
247 Ok (code, val) -> (code, val)
248 in ConfdReply { confdReplyProtocol = 1
249 , confdReplyStatus = status
250 , confdReplyAnswer = result
251 , confdReplySerial = 0 }
253 -- * Configuration handling
255 -- ** Helper functions
257 -- | Helper function for logging transition into polling mode.
258 moveToPolling :: String -> INotify -> FilePath -> CRef -> MVar ServerState
260 moveToPolling msg inotify path cref mstate = do
261 logInfo $ "Moving to polling mode: " ++ msg
262 let inotiaction = addNotifier inotify path cref mstate
263 _ <- forkIO $ onReloadTimer inotiaction path cref mstate
266 -- | Helper function for logging transition into inotify mode.
267 moveToNotify :: IO ReloadModel
269 logInfo "Moving to inotify mode"
272 -- ** Configuration loading
274 -- | (Re)loads the configuration.
275 updateConfig :: FilePath -> CRef -> IO ()
276 updateConfig path r = do
277 newcfg <- loadConfig path
278 let !newdata = case newcfg of
279 Ok !cfg -> Ok (cfg, buildLinkIpInstnameMap cfg)
280 Bad _ -> Bad "Cannot load configuration"
283 Ok cfg -> logInfo ("Loaded new config, serial " ++
284 show (configSerial cfg))
285 Bad msg -> logError $ "Failed to load config: " ++ msg
288 -- | Wrapper over 'updateConfig' that handles IO errors.
289 safeUpdateConfig :: FilePath -> FStat -> CRef -> IO (FStat, ConfigReload)
290 safeUpdateConfig path oldfstat cref =
292 nt <- needsReload oldfstat path
294 Nothing -> return (oldfstat, ConfigToDate)
296 updateConfig path cref
297 return (nt', ConfigReloaded)
299 let msg = "Failure during configuration update: " ++
301 writeIORef cref (Bad msg)
302 return (nullFStat, ConfigIOError)
305 -- | Computes the file cache data from a FileStatus structure.
306 buildFileStatus :: FileStatus -> FStat
307 buildFileStatus ofs =
308 let modt = modificationTime ofs
311 in (modt, inum, fsize)
313 -- | Wrapper over 'buildFileStatus'. This reads the data from the
314 -- filesystem and then builds our cache structure.
315 getFStat :: FilePath -> IO FStat
316 getFStat p = liftM buildFileStatus (getFileStatus p)
318 -- | Check if the file needs reloading
319 needsReload :: FStat -> FilePath -> IO (Maybe FStat)
320 needsReload oldstat path = do
321 newstat <- getFStat path
322 return $ if newstat /= oldstat
326 -- ** Watcher threads
329 -- We have three threads/functions that can mutate the server state:
331 -- 1. the long-interval watcher ('onTimeoutTimer')
333 -- 2. the polling watcher ('onReloadTimer')
335 -- 3. the inotify event handler ('onInotify')
337 -- All of these will mutate the server state under 'modifyMVar' or
338 -- 'modifyMVar_', so that server transitions are more or less
339 -- atomic. The inotify handler remains active during polling mode, but
340 -- checks for polling mode and doesn't do anything in this case (this
341 -- check is needed even if we would unregister the event handler due
342 -- to how events are serialised).
344 -- | Long-interval reload watcher.
346 -- This is on top of the inotify-based triggered reload.
347 onTimeoutTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
348 onTimeoutTimer inotiaction path cref state = do
349 threadDelay configReloadTimeout
350 modifyMVar_ state (onTimeoutInner path cref)
352 onTimeoutTimer inotiaction path cref state
354 -- | Inner onTimeout handler.
356 -- This mutates the server state under a modifyMVar_ call. It never
357 -- changes the reload model, just does a safety reload and tried to
358 -- re-establish the inotify watcher.
359 onTimeoutInner :: FilePath -> CRef -> ServerState -> IO ServerState
360 onTimeoutInner path cref state = do
361 (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
362 return state { reloadFStat = newfstat }
364 -- | Short-interval (polling) reload watcher.
366 -- This is only active when we're in polling mode; it will
367 -- automatically exit when it detects that the state has changed to
369 onReloadTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
370 onReloadTimer inotiaction path cref state = do
371 continue <- modifyMVar state (onReloadInner inotiaction path cref)
373 do threadDelay configReloadRatelimit
374 onReloadTimer inotiaction path cref state
375 -- the inotify watch has been re-established, we can exit
377 -- | Inner onReload handler.
379 -- This again mutates the state under a modifyMVar call, and also
380 -- returns whether the thread should continue or not.
381 onReloadInner :: IO Bool -> FilePath -> CRef -> ServerState
382 -> IO (ServerState, Bool)
383 onReloadInner _ _ _ state@(ServerState { reloadModel = ReloadNotify } ) =
384 return (state, False)
385 onReloadInner inotiaction path cref
386 state@(ServerState { reloadModel = ReloadPoll pround } ) = do
387 (newfstat, reload) <- safeUpdateConfig path (reloadFStat state) cref
388 let state' = state { reloadFStat = newfstat }
389 -- compute new poll model based on reload data; however, failure to
390 -- re-establish the inotifier means we stay on polling
391 newmode <- case reload of
393 if pround >= maxIdlePollRounds
394 then do -- try to switch to notify
395 result <- inotiaction
398 else return initialPoll
399 else return (ReloadPoll (pround + 1))
400 _ -> return initialPoll
401 let continue = case newmode of
402 ReloadNotify -> False
404 return (state' { reloadModel = newmode }, continue)
406 -- the following hint is because hlint doesn't understand our const
407 -- (return False) is so that we can give a signature to 'e'
408 {-# ANN addNotifier "HLint: ignore Evaluate" #-}
409 -- | Setup inotify watcher.
411 -- This tries to setup the watch descriptor; in case of any IO errors,
412 -- it will return False.
413 addNotifier :: INotify -> FilePath -> CRef -> MVar ServerState -> IO Bool
414 addNotifier inotify path cref mstate =
415 catch (addWatch inotify [CloseWrite] path
416 (onInotify inotify path cref mstate) >> return True)
417 (\e -> const (return False) (e::IOError))
419 -- | Inotify event handler.
420 onInotify :: INotify -> String -> CRef -> MVar ServerState -> Event -> IO ()
421 onInotify inotify path cref mstate Ignored = do
422 logInfo "File lost, trying to re-establish notifier"
423 modifyMVar_ mstate $ \state -> do
424 result <- addNotifier inotify path cref mstate
425 (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
426 let state' = state { reloadFStat = newfstat }
428 then return state' -- keep notify
430 mode <- moveToPolling "cannot re-establish inotify watch" inotify
432 return state' { reloadModel = mode }
434 onInotify inotify path cref mstate _ =
435 modifyMVar_ mstate $ \state ->
436 if reloadModel state == ReloadNotify
438 ctime <- getCurrentTime
439 (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
440 let state' = state { reloadFStat = newfstat, reloadTime = ctime }
441 if abs (reloadTime state - ctime) <
442 fromIntegral C.confdConfigReloadRatelimit
444 mode <- moveToPolling "too many reloads" inotify path cref mstate
445 return state' { reloadModel = mode }
449 -- ** Client input/output handlers
451 -- | Main loop for a given client.
452 responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO ()
453 responder cfgref socket hmac msg peer = do
454 ctime <- getCurrentTime
455 case parseMessage hmac msg ctime of
456 Ok (origmsg, rq) -> do
457 logDebug $ "Processing request: " ++ origmsg
458 mcfg <- readIORef cfgref
459 let response = respondInner mcfg hmac rq
460 _ <- S.sendTo socket response peer
462 Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
465 -- | Inner helper function for a given client. This generates the
466 -- final encoded message (as a string), ready to be sent out to the
468 respondInner :: Result (ConfigData, LinkIpMap) -> HashKey
469 -> ConfdRequest -> String
470 respondInner cfg hmac rq =
471 let rsalt = confdRqRsalt rq
472 innermsg = serializeResponse (cfg >>= flip buildResponse rq)
473 innerserialised = J.encodeStrict innermsg
474 outermsg = signMessage hmac rsalt innerserialised
475 outerserialised = confdMagicFourcc ++ J.encodeStrict outermsg
478 -- | Main listener loop.
479 listener :: S.Socket -> HashKey
480 -> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
482 listener s hmac resp = do
483 (msg, _, peer) <- S.recvFrom s 4096
484 if confdMagicFourcc `isPrefixOf` msg
485 then forkIO (resp s hmac (drop 4 msg) peer) >> return ()
486 else logDebug "Invalid magic code!" >> return ()
489 -- | Extract the configuration from our IORef.
490 configReader :: CRef -> IO (Result ConfigData)
491 configReader cref = do
492 cdata <- readIORef cref
493 return $ liftM fst cdata
496 main :: DaemonOptions -> IO ()
498 parseresult <- parseAddress opts C.defaultConfdPort
499 (af_family, bindaddr) <- exitIfBad "parsing bind address" parseresult
500 s <- S.socket af_family S.Datagram S.defaultProtocol
501 S.bindSocket s bindaddr
502 cref <- newIORef (Bad "Configuration not yet loaded")
503 statemvar <- newMVar initialState
504 hmac <- getClusterHmac
506 inotify <- initINotify
507 let inotiaction = addNotifier inotify Path.clusterConfFile cref statemvar
508 -- fork the timeout timer
509 _ <- forkIO $ onTimeoutTimer inotiaction Path.clusterConfFile cref statemvar
510 -- fork the polling timer
511 _ <- forkIO $ onReloadTimer inotiaction Path.clusterConfFile cref statemvar
512 -- launch the queryd listener
513 _ <- forkIO $ runQueryD Nothing (configReader cref)
514 -- and finally enter the responder loop
515 forever $ listener s hmac (responder cref)