code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/Confd/Server.hs

   1 {-# LANGUAGE BangPatterns #-}
   2
   3 {-| Implementation of the Ganeti confd server functionality.
   4
   5 -}
   6
   7 {-
   8
   9 Copyright (C) 2011, 2012 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   ) where
  31
  32 import Control.Concurrent
  33 import Control.Exception
  34 import Control.Monad (forever, liftM, when)
  35 import Data.IORef
  36 import Data.List
  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
  43 import System.Time
  44 import qualified Text.JSON as J
  45 import System.INotify
  46
  47 import Ganeti.Daemon
  48 import Ganeti.JSON
  49 import Ganeti.HTools.Types
  50 import Ganeti.Objects
  51 import Ganeti.Confd
  52 import Ganeti.Confd.Utils
  53 import Ganeti.Config
  54 import Ganeti.Hash
  55 import Ganeti.Logging
  56 import Ganeti.Utils
  57 import qualified Ganeti.Constants as C
  58 import qualified Ganeti.Path as Path
  59 import Ganeti.Query.Server (runQueryD)
  60
  61 -- * Types and constants definitions
  62
  63 -- | What we store as configuration.
  64 type CRef = IORef (Result (ConfigData, LinkIpMap))
  65
  66 -- | File stat identifier.
  67 type FStat = (EpochTime, FileID, FileOffset)
  68
  69 -- | Null 'FStat' value.
  70 nullFStat :: FStat
  71 nullFStat = (-1, -1, -1)
  72
  73 -- | A small type alias for readability.
  74 type StatusAnswer = (ConfdReplyStatus, J.JSValue)
  75
  76 -- | Reload model data type.
  77 data ReloadModel = ReloadNotify      -- ^ We are using notifications
  78                  | ReloadPoll Int    -- ^ We are using polling
  79                    deriving (Eq, Show)
  80
  81 -- | Server state data type.
  82 data ServerState = ServerState
  83   { reloadModel  :: ReloadModel
  84   , reloadTime   :: Integer
  85   , reloadFStat  :: FStat
  86   }
  87
  88 -- | Maximum no-reload poll rounds before reverting to inotify.
  89 maxIdlePollRounds :: Int
  90 maxIdlePollRounds = 2
  91
  92 -- | Reload timeout in microseconds.
  93 configReloadTimeout :: Int
  94 configReloadTimeout = C.confdConfigReloadTimeout * 1000000
  95
  96 -- | Ratelimit timeout in microseconds.
  97 configReloadRatelimit :: Int
  98 configReloadRatelimit = C.confdConfigReloadRatelimit * 1000000
  99
 100 -- | Initial poll round.
 101 initialPoll :: ReloadModel
 102 initialPoll = ReloadPoll 0
 103
 104 -- | Initial server state.
 105 initialState :: ServerState
 106 initialState = ServerState initialPoll 0 nullFStat
 107
 108 -- | Reload status data type.
 109 data ConfigReload = ConfigToDate    -- ^ No need to reload
 110                   | ConfigReloaded  -- ^ Configuration reloaded
 111                   | ConfigIOError   -- ^ Error during configuration reload
 112
 113 -- | Unknown entry standard response.
 114 queryUnknownEntry :: StatusAnswer
 115 queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry)
 116
 117 {- not used yet
 118 -- | Internal error standard response.
 119 queryInternalError :: StatusAnswer
 120 queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
 121 -}
 122
 123 -- | Argument error standard response.
 124 queryArgumentError :: StatusAnswer
 125 queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument)
 126
 127 -- | Returns the current time.
 128 getCurrentTime :: IO Integer
 129 getCurrentTime = do
 130   TOD ctime _ <- getClockTime
 131   return ctime
 132
 133 -- * Confd base functionality
 134
 135 -- | Computes the node role.
 136 nodeRole :: ConfigData -> String -> Result ConfdNodeRole
 137 nodeRole cfg name =
 138   let cmaster = clusterMasterNode . configCluster $ cfg
 139       mnode = M.lookup name . fromContainer . configNodes $ cfg
 140   in case mnode of
 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
 147
 148 -- | Does an instance ip -> instance -> primary node -> primary ip
 149 -- transformation.
 150 getNodePipByInstanceIp :: ConfigData
 151                        -> LinkIpMap
 152                        -> String
 153                        -> String
 154                        -> StatusAnswer
 155 getNodePipByInstanceIp cfg linkipmap link instip =
 156   case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
 157     Nothing -> queryUnknownEntry
 158     Just instname ->
 159       case getInstPrimaryNode cfg instname of
 160         Bad _ -> queryUnknownEntry -- either instance or node not found
 161         Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node))
 162
 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))
 167
 168 buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
 169   case confdRqQuery req of
 170     EmptyQuery -> return (ReplyStatusOk, J.showJSON master_name)
 171     PlainQuery _ -> return queryArgumentError
 172     DictQuery reqq -> do
 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
 182           cfg = fst cdata
 183
 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)
 190
 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))
 197
 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
 204                                          else accu) []
 205           (fromContainer . configNodes . fst $ cdata))
 206
 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)
 214
 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,
 222                           J.showJSON $
 223                            map (getNodePipByInstanceIp cfg linkipmap link)
 224                            (confdReqQIpList query))
 225
 226 buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) =
 227   return queryArgumentError
 228
 229 buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do
 230   let cfg = fst cdata
 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)
 241
 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 }
 252
 253 -- * Configuration handling
 254
 255 -- ** Helper functions
 256
 257 -- | Helper function for logging transition into polling mode.
 258 moveToPolling :: String -> INotify -> FilePath -> CRef -> MVar ServerState
 259               -> IO ReloadModel
 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
 264   return initialPoll
 265
 266 -- | Helper function for logging transition into inotify mode.
 267 moveToNotify :: IO ReloadModel
 268 moveToNotify = do
 269   logInfo "Moving to inotify mode"
 270   return ReloadNotify
 271
 272 -- ** Configuration loading
 273
 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"
 281   writeIORef r newdata
 282   case newcfg of
 283     Ok cfg -> logInfo ("Loaded new config, serial " ++
 284                        show (configSerial cfg))
 285     Bad msg -> logError $ "Failed to load config: " ++ msg
 286   return ()
 287
 288 -- | Wrapper over 'updateConfig' that handles IO errors.
 289 safeUpdateConfig :: FilePath -> FStat -> CRef -> IO (FStat, ConfigReload)
 290 safeUpdateConfig path oldfstat cref =
 291   catch (do
 292           nt <- needsReload oldfstat path
 293           case nt of
 294             Nothing -> return (oldfstat, ConfigToDate)
 295             Just nt' -> do
 296                     updateConfig path cref
 297                     return (nt', ConfigReloaded)
 298         ) (\e -> do
 299              let msg = "Failure during configuration update: " ++
 300                        show (e::IOError)
 301              writeIORef cref (Bad msg)
 302              return (nullFStat, ConfigIOError)
 303           )
 304
 305 -- | Computes the file cache data from a FileStatus structure.
 306 buildFileStatus :: FileStatus -> FStat
 307 buildFileStatus ofs =
 308     let modt = modificationTime ofs
 309         inum = fileID ofs
 310         fsize = fileSize ofs
 311     in (modt, inum, fsize)
 312
 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)
 317
 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
 323              then Just newstat
 324              else Nothing
 325
 326 -- ** Watcher threads
 327
 328 -- $watcher
 329 -- We have three threads/functions that can mutate the server state:
 330 --
 331 -- 1. the long-interval watcher ('onTimeoutTimer')
 332 --
 333 -- 2. the polling watcher ('onReloadTimer')
 334 --
 335 -- 3. the inotify event handler ('onInotify')
 336 --
 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).
 343
 344 -- | Long-interval reload watcher.
 345 --
 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)
 351   _ <- inotiaction
 352   onTimeoutTimer inotiaction path cref state
 353
 354 -- | Inner onTimeout handler.
 355 --
 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 }
 363
 364 -- | Short-interval (polling) reload watcher.
 365 --
 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
 368 -- notification.
 369 onReloadTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
 370 onReloadTimer inotiaction path cref state = do
 371   continue <- modifyMVar state (onReloadInner inotiaction path cref)
 372   when continue $
 373     do threadDelay configReloadRatelimit
 374        onReloadTimer inotiaction path cref state
 375   -- the inotify watch has been re-established, we can exit
 376
 377 -- | Inner onReload handler.
 378 --
 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
 392                ConfigToDate ->
 393                  if pround >= maxIdlePollRounds
 394                    then do -- try to switch to notify
 395                      result <- inotiaction
 396                      if result
 397                        then moveToNotify
 398                        else return initialPoll
 399                    else return (ReloadPoll (pround + 1))
 400                _ -> return initialPoll
 401   let continue = case newmode of
 402                    ReloadNotify -> False
 403                    _            -> True
 404   return (state' { reloadModel = newmode }, continue)
 405
 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.
 410 --
 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))
 418
 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 }
 427     if result
 428       then return state' -- keep notify
 429       else do
 430         mode <- moveToPolling "cannot re-establish inotify watch" inotify
 431                   path cref mstate
 432         return state' { reloadModel = mode }
 433
 434 onInotify inotify path cref mstate _ =
 435   modifyMVar_ mstate $ \state ->
 436     if reloadModel state == ReloadNotify
 437        then do
 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
 443            then do
 444              mode <- moveToPolling "too many reloads" inotify path cref mstate
 445              return state' { reloadModel = mode }
 446            else return state'
 447       else return state
 448
 449 -- ** Client input/output handlers
 450
 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
 461               return ()
 462     Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
 463   return ()
 464
 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
 467 -- client.
 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
 476   in outerserialised
 477
 478 -- | Main listener loop.
 479 listener :: S.Socket -> HashKey
 480          -> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
 481          -> 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 ()
 487   return ()
 488
 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
 494
 495 -- | Main function.
 496 main :: DaemonOptions -> IO ()
 497 main opts = do
 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
 505   -- Inotify setup
 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)