Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Confd / Server.hs @ 4cd79ca8

History | View | Annotate | Download (18.8 kB)

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.BasicTypes
48
import Ganeti.Daemon
49
import Ganeti.JSON
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)