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