code.grnet.gr Git - ganeti-local/blob - src/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   , checkMain
  31   , prepMain
  32   ) where
  33
  34 import Control.Concurrent
  35 import Control.Exception
  36 import Control.Monad (forever, liftM, when)
  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 Ganeti.Utils
  63
  64 -- * Types and constants definitions
  65
  66 -- | What we store as configuration.
  67 type CRef = IORef (Result (ConfigData, LinkIpMap))
  68
  69 -- | File stat identifier.
  70 type FStat = (EpochTime, FileID, FileOffset)
  71
  72 -- | Null 'FStat' value.
  73 nullFStat :: FStat
  74 nullFStat = (-1, -1, -1)
  75
  76 -- | A small type alias for readability.
  77 type StatusAnswer = (ConfdReplyStatus, J.JSValue)
  78
  79 -- | Reload model data type.
  80 data ReloadModel = ReloadNotify      -- ^ We are using notifications
  81                  | ReloadPoll Int    -- ^ We are using polling
  82                    deriving (Eq, Show)
  83
  84 -- | Server state data type.
  85 data ServerState = ServerState
  86   { reloadModel  :: ReloadModel
  87   , reloadTime   :: Integer
  88   , reloadFStat  :: FStat
  89   }
  90
  91 -- | Maximum no-reload poll rounds before reverting to inotify.
  92 maxIdlePollRounds :: Int
  93 maxIdlePollRounds = 2
  94
  95 -- | Reload timeout in microseconds.
  96 configReloadTimeout :: Int
  97 configReloadTimeout = C.confdConfigReloadTimeout * 1000000
  98
  99 -- | Ratelimit timeout in microseconds.
 100 configReloadRatelimit :: Int
 101 configReloadRatelimit = C.confdConfigReloadRatelimit * 1000000
 102
 103 -- | Ratelimit timeout in seconds, as an 'Integer'.
 104 reloadRatelimitSec :: Integer
 105 reloadRatelimitSec = fromIntegral C.confdConfigReloadRatelimit
 106
 107 -- | Initial poll round.
 108 initialPoll :: ReloadModel
 109 initialPoll = ReloadPoll 0
 110
 111 -- | Initial server state.
 112 initialState :: ServerState
 113 initialState = ServerState initialPoll 0 nullFStat
 114
 115 -- | Reload status data type.
 116 data ConfigReload = ConfigToDate    -- ^ No need to reload
 117                   | ConfigReloaded  -- ^ Configuration reloaded
 118                   | ConfigIOError   -- ^ Error during configuration reload
 119
 120 -- | Unknown entry standard response.
 121 queryUnknownEntry :: StatusAnswer
 122 queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry)
 123
 124 {- not used yet
 125 -- | Internal error standard response.
 126 queryInternalError :: StatusAnswer
 127 queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
 128 -}
 129
 130 -- | Argument error standard response.
 131 queryArgumentError :: StatusAnswer
 132 queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument)
 133
 134 -- | Converter from specific error to a string format.
 135 gntErrorToResult :: ErrorResult a -> Result a
 136 gntErrorToResult (Bad err) = Bad (show err)
 137 gntErrorToResult (Ok x) = Ok x
 138
 139 -- * Confd base functionality
 140
 141 -- | Computes the node role.
 142 nodeRole :: ConfigData -> String -> Result ConfdNodeRole
 143 nodeRole cfg name =
 144   let cmaster = clusterMasterNode . configCluster $ cfg
 145       mnode = M.lookup name . fromContainer . configNodes $ cfg
 146   in case mnode of
 147        Nothing -> Bad "Node not found"
 148        Just node | cmaster == name -> Ok NodeRoleMaster
 149                  | nodeDrained node -> Ok NodeRoleDrained
 150                  | nodeOffline node -> Ok NodeRoleOffline
 151                  | nodeMasterCandidate node -> Ok NodeRoleCandidate
 152        _ -> Ok NodeRoleRegular
 153
 154 -- | Does an instance ip -> instance -> primary node -> primary ip
 155 -- transformation.
 156 getNodePipByInstanceIp :: ConfigData
 157                        -> LinkIpMap
 158                        -> String
 159                        -> String
 160                        -> StatusAnswer
 161 getNodePipByInstanceIp cfg linkipmap link instip =
 162   case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
 163     Nothing -> queryUnknownEntry
 164     Just instname ->
 165       case getInstPrimaryNode cfg instname of
 166         Bad _ -> queryUnknownEntry -- either instance or node not found
 167         Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node))
 168
 169 -- | Builds the response to a given query.
 170 buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer
 171 buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) =
 172   return (ReplyStatusOk, J.showJSON (configVersion cfg))
 173
 174 buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
 175   case confdRqQuery req of
 176     EmptyQuery -> return (ReplyStatusOk, J.showJSON master_name)
 177     PlainQuery _ -> return queryArgumentError
 178     DictQuery reqq -> do
 179       mnode <- gntErrorToResult $ getNode cfg master_name
 180       let fvals = map (\field -> case field of
 181                                    ReqFieldName -> master_name
 182                                    ReqFieldIp -> clusterMasterIp cluster
 183                                    ReqFieldMNodePip -> nodePrimaryIp mnode
 184                       ) (confdReqQFields reqq)
 185       return (ReplyStatusOk, J.showJSON fvals)
 186     where master_name = clusterMasterNode cluster
 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 -- | Creates a ConfdReply from a given answer.
 249 serializeResponse :: Result StatusAnswer -> ConfdReply
 250 serializeResponse r =
 251     let (status, result) = case r of
 252                     Bad err -> (ReplyStatusError, J.showJSON err)
 253                     Ok (code, val) -> (code, val)
 254     in ConfdReply { confdReplyProtocol = 1
 255                   , confdReplyStatus   = status
 256                   , confdReplyAnswer   = result
 257                   , confdReplySerial   = 0 }
 258
 259 -- * Configuration handling
 260
 261 -- ** Helper functions
 262
 263 -- | Helper function for logging transition into polling mode.
 264 moveToPolling :: String -> INotify -> FilePath -> CRef -> MVar ServerState
 265               -> IO ReloadModel
 266 moveToPolling msg inotify path cref mstate = do
 267   logInfo $ "Moving to polling mode: " ++ msg
 268   let inotiaction = addNotifier inotify path cref mstate
 269   _ <- forkIO $ onReloadTimer inotiaction path cref mstate
 270   return initialPoll
 271
 272 -- | Helper function for logging transition into inotify mode.
 273 moveToNotify :: IO ReloadModel
 274 moveToNotify = do
 275   logInfo "Moving to inotify mode"
 276   return ReloadNotify
 277
 278 -- ** Configuration loading
 279
 280 -- | (Re)loads the configuration.
 281 updateConfig :: FilePath -> CRef -> IO ()
 282 updateConfig path r = do
 283   newcfg <- loadConfig path
 284   let !newdata = case newcfg of
 285                    Ok !cfg -> Ok (cfg, buildLinkIpInstnameMap cfg)
 286                    Bad _ -> Bad "Cannot load configuration"
 287   writeIORef r newdata
 288   case newcfg of
 289     Ok cfg -> logInfo ("Loaded new config, serial " ++
 290                        show (configSerial cfg))
 291     Bad msg -> logError $ "Failed to load config: " ++ msg
 292   return ()
 293
 294 -- | Wrapper over 'updateConfig' that handles IO errors.
 295 safeUpdateConfig :: FilePath -> FStat -> CRef -> IO (FStat, ConfigReload)
 296 safeUpdateConfig path oldfstat cref =
 297   Control.Exception.catch
 298         (do
 299           nt <- needsReload oldfstat path
 300           case nt of
 301             Nothing -> return (oldfstat, ConfigToDate)
 302             Just nt' -> do
 303                     updateConfig path cref
 304                     return (nt', ConfigReloaded)
 305         ) (\e -> do
 306              let msg = "Failure during configuration update: " ++
 307                        show (e::IOError)
 308              writeIORef cref (Bad msg)
 309              return (nullFStat, ConfigIOError)
 310           )
 311
 312 -- | Computes the file cache data from a FileStatus structure.
 313 buildFileStatus :: FileStatus -> FStat
 314 buildFileStatus ofs =
 315     let modt = modificationTime ofs
 316         inum = fileID ofs
 317         fsize = fileSize ofs
 318     in (modt, inum, fsize)
 319
 320 -- | Wrapper over 'buildFileStatus'. This reads the data from the
 321 -- filesystem and then builds our cache structure.
 322 getFStat :: FilePath -> IO FStat
 323 getFStat p = liftM buildFileStatus (getFileStatus p)
 324
 325 -- | Check if the file needs reloading
 326 needsReload :: FStat -> FilePath -> IO (Maybe FStat)
 327 needsReload oldstat path = do
 328   newstat <- getFStat path
 329   return $ if newstat /= oldstat
 330              then Just newstat
 331              else Nothing
 332
 333 -- ** Watcher threads
 334
 335 -- $watcher
 336 -- We have three threads/functions that can mutate the server state:
 337 --
 338 -- 1. the long-interval watcher ('onTimeoutTimer')
 339 --
 340 -- 2. the polling watcher ('onReloadTimer')
 341 --
 342 -- 3. the inotify event handler ('onInotify')
 343 --
 344 -- All of these will mutate the server state under 'modifyMVar' or
 345 -- 'modifyMVar_', so that server transitions are more or less
 346 -- atomic. The inotify handler remains active during polling mode, but
 347 -- checks for polling mode and doesn't do anything in this case (this
 348 -- check is needed even if we would unregister the event handler due
 349 -- to how events are serialised).
 350
 351 -- | Long-interval reload watcher.
 352 --
 353 -- This is on top of the inotify-based triggered reload.
 354 onTimeoutTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
 355 onTimeoutTimer inotiaction path cref state = do
 356   threadDelay configReloadTimeout
 357   modifyMVar_ state (onTimeoutInner path cref)
 358   _ <- inotiaction
 359   onTimeoutTimer inotiaction path cref state
 360
 361 -- | Inner onTimeout handler.
 362 --
 363 -- This mutates the server state under a modifyMVar_ call. It never
 364 -- changes the reload model, just does a safety reload and tried to
 365 -- re-establish the inotify watcher.
 366 onTimeoutInner :: FilePath -> CRef -> ServerState -> IO ServerState
 367 onTimeoutInner path cref state  = do
 368   (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
 369   return state { reloadFStat = newfstat }
 370
 371 -- | Short-interval (polling) reload watcher.
 372 --
 373 -- This is only active when we're in polling mode; it will
 374 -- automatically exit when it detects that the state has changed to
 375 -- notification.
 376 onReloadTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
 377 onReloadTimer inotiaction path cref state = do
 378   continue <- modifyMVar state (onReloadInner inotiaction path cref)
 379   when continue $
 380     do threadDelay configReloadRatelimit
 381        onReloadTimer inotiaction path cref state
 382   -- the inotify watch has been re-established, we can exit
 383
 384 -- | Inner onReload handler.
 385 --
 386 -- This again mutates the state under a modifyMVar call, and also
 387 -- returns whether the thread should continue or not.
 388 onReloadInner :: IO Bool -> FilePath -> CRef -> ServerState
 389               -> IO (ServerState, Bool)
 390 onReloadInner _ _ _ state@(ServerState { reloadModel = ReloadNotify } ) =
 391   return (state, False)
 392 onReloadInner inotiaction path cref
 393               state@(ServerState { reloadModel = ReloadPoll pround } ) = do
 394   (newfstat, reload) <- safeUpdateConfig path (reloadFStat state) cref
 395   let state' = state { reloadFStat = newfstat }
 396   -- compute new poll model based on reload data; however, failure to
 397   -- re-establish the inotifier means we stay on polling
 398   newmode <- case reload of
 399                ConfigToDate ->
 400                  if pround >= maxIdlePollRounds
 401                    then do -- try to switch to notify
 402                      result <- inotiaction
 403                      if result
 404                        then moveToNotify
 405                        else return initialPoll
 406                    else return (ReloadPoll (pround + 1))
 407                _ -> return initialPoll
 408   let continue = case newmode of
 409                    ReloadNotify -> False
 410                    _            -> True
 411   return (state' { reloadModel = newmode }, continue)
 412
 413 -- the following hint is because hlint doesn't understand our const
 414 -- (return False) is so that we can give a signature to 'e'
 415 {-# ANN addNotifier "HLint: ignore Evaluate" #-}
 416 -- | Setup inotify watcher.
 417 --
 418 -- This tries to setup the watch descriptor; in case of any IO errors,
 419 -- it will return False.
 420 addNotifier :: INotify -> FilePath -> CRef -> MVar ServerState -> IO Bool
 421 addNotifier inotify path cref mstate =
 422   Control.Exception.catch
 423         (addWatch inotify [CloseWrite] path
 424                     (onInotify inotify path cref mstate) >> return True)
 425         (\e -> const (return False) (e::IOError))
 426
 427 -- | Inotify event handler.
 428 onInotify :: INotify -> String -> CRef -> MVar ServerState -> Event -> IO ()
 429 onInotify inotify path cref mstate Ignored = do
 430   logDebug "File lost, trying to re-establish notifier"
 431   modifyMVar_ mstate $ \state -> do
 432     result <- addNotifier inotify path cref mstate
 433     (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
 434     let state' = state { reloadFStat = newfstat }
 435     if result
 436       then return state' -- keep notify
 437       else do
 438         mode <- moveToPolling "cannot re-establish inotify watch" inotify
 439                   path cref mstate
 440         return state' { reloadModel = mode }
 441
 442 onInotify inotify path cref mstate _ =
 443   modifyMVar_ mstate $ \state ->
 444     if reloadModel state == ReloadNotify
 445        then do
 446          ctime <- getCurrentTime
 447          (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
 448          let state' = state { reloadFStat = newfstat, reloadTime = ctime }
 449          if abs (reloadTime state - ctime) < reloadRatelimitSec
 450            then do
 451              mode <- moveToPolling "too many reloads" inotify path cref mstate
 452              return state' { reloadModel = mode }
 453            else return state'
 454       else return state
 455
 456 -- ** Client input/output handlers
 457
 458 -- | Main loop for a given client.
 459 responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO ()
 460 responder cfgref socket hmac msg peer = do
 461   ctime <- getCurrentTime
 462   case parseRequest hmac msg ctime of
 463     Ok (origmsg, rq) -> do
 464               logDebug $ "Processing request: " ++ rStripSpace origmsg
 465               mcfg <- readIORef cfgref
 466               let response = respondInner mcfg hmac rq
 467               _ <- S.sendTo socket response peer
 468               return ()
 469     Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
 470   return ()
 471
 472 -- | Inner helper function for a given client. This generates the
 473 -- final encoded message (as a string), ready to be sent out to the
 474 -- client.
 475 respondInner :: Result (ConfigData, LinkIpMap) -> HashKey
 476              -> ConfdRequest -> String
 477 respondInner cfg hmac rq =
 478   let rsalt = confdRqRsalt rq
 479       innermsg = serializeResponse (cfg >>= flip buildResponse rq)
 480       innerserialised = J.encodeStrict innermsg
 481       outermsg = signMessage hmac rsalt innerserialised
 482       outerserialised = confdMagicFourcc ++ J.encodeStrict outermsg
 483   in outerserialised
 484
 485 -- | Main listener loop.
 486 listener :: S.Socket -> HashKey
 487          -> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
 488          -> IO ()
 489 listener s hmac resp = do
 490   (msg, _, peer) <- S.recvFrom s 4096
 491   if confdMagicFourcc `isPrefixOf` msg
 492     then forkIO (resp s hmac (drop 4 msg) peer) >> return ()
 493     else logDebug "Invalid magic code!" >> return ()
 494   return ()
 495
 496 -- | Extract the configuration from our IORef.
 497 configReader :: CRef -> IO (Result ConfigData)
 498 configReader cref = do
 499   cdata <- readIORef cref
 500   return $ liftM fst cdata
 501
 502 -- | Type alias for prepMain results
 503 type PrepResult = (S.Socket, (FilePath, S.Socket),
 504                    IORef (Result (ConfigData, LinkIpMap)))
 505
 506 -- | Check function for confd.
 507 checkMain :: CheckFn (S.Family, S.SockAddr)
 508 checkMain opts = do
 509   parseresult <- parseAddress opts C.defaultConfdPort
 510   case parseresult of
 511     Bad msg -> do
 512       hPutStrLn stderr $ "parsing bind address: " ++ msg
 513       return . Left $ ExitFailure 1
 514     Ok v -> return $ Right v
 515
 516 -- | Prepare function for confd.
 517 prepMain :: PrepFn (S.Family, S.SockAddr) PrepResult
 518 prepMain _ (af_family, bindaddr) = do
 519   s <- S.socket af_family S.Datagram S.defaultProtocol
 520   S.bindSocket s bindaddr
 521   -- prepare the queryd listener
 522   query_data <- prepQueryD Nothing
 523   cref <- newIORef (Bad "Configuration not yet loaded")
 524   return (s, query_data, cref)
 525
 526 -- | Main function.
 527 main :: MainFn (S.Family, S.SockAddr) PrepResult
 528 main _ _ (s, query_data, cref) = do
 529   statemvar <- newMVar initialState
 530   hmac <- getClusterHmac
 531   -- Inotify setup
 532   inotify <- initINotify
 533   conf_file <- Path.clusterConfFile
 534   let inotiaction = addNotifier inotify conf_file cref statemvar
 535   -- fork the timeout timer
 536   _ <- forkIO $ onTimeoutTimer inotiaction conf_file cref statemvar
 537   -- fork the polling timer
 538   _ <- forkIO $ onReloadTimer inotiaction conf_file cref statemvar
 539   -- launch the queryd listener
 540   _ <- forkIO $ runQueryD query_data (configReader cref)
 541   -- and finally enter the responder loop
 542   forever $ listener s hmac (responder cref)