Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / Confd / Server.hs @ 46300ac2

History | View | Annotate | Download (19.7 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
  , 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
  logInfo "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 parseMessage 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)