Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Confd / Server.hs @ 3190ad64

History | View | Annotate | Download (19.8 kB)

1
{-# LANGUAGE BangPatterns #-}
2

    
3
{-| Implementation of the Ganeti confd server functionality.
4

    
5
-}
6

    
7
{-
8

    
9
Copyright (C) 2011, 2012, 2013 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
-- | Reload status data type.
112
data ConfigReload = ConfigToDate    -- ^ No need to reload
113
                  | ConfigReloaded  -- ^ Configuration reloaded
114
                  | ConfigIOError   -- ^ Error during configuration reload
115

    
116
-- | Unknown entry standard response.
117
queryUnknownEntry :: StatusAnswer
118
queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry)
119

    
120
{- not used yet
121
-- | Internal error standard response.
122
queryInternalError :: StatusAnswer
123
queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
124
-}
125

    
126
-- | Argument error standard response.
127
queryArgumentError :: StatusAnswer
128
queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument)
129

    
130
-- | Converter from specific error to a string format.
131
gntErrorToResult :: ErrorResult a -> Result a
132
gntErrorToResult (Bad err) = Bad (show err)
133
gntErrorToResult (Ok x) = Ok x
134

    
135
-- * Confd base functionality
136

    
137
-- | Computes the node role.
138
nodeRole :: ConfigData -> String -> Result ConfdNodeRole
139
nodeRole cfg name =
140
  let cmaster = clusterMasterNode . configCluster $ cfg
141
      mnode = M.lookup name . fromContainer . configNodes $ cfg
142
  in case mnode of
143
       Nothing -> Bad "Node not found"
144
       Just node | cmaster == name -> Ok NodeRoleMaster
145
                 | nodeDrained node -> Ok NodeRoleDrained
146
                 | nodeOffline node -> Ok NodeRoleOffline
147
                 | nodeMasterCandidate node -> Ok NodeRoleCandidate
148
       _ -> Ok NodeRoleRegular
149

    
150
-- | Does an instance ip -> instance -> primary node -> primary ip
151
-- transformation.
152
getNodePipByInstanceIp :: ConfigData
153
                       -> LinkIpMap
154
                       -> String
155
                       -> String
156
                       -> StatusAnswer
157
getNodePipByInstanceIp cfg linkipmap link instip =
158
  case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
159
    Nothing -> queryUnknownEntry
160
    Just instname ->
161
      case getInstPrimaryNode cfg instname of
162
        Bad _ -> queryUnknownEntry -- either instance or node not found
163
        Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node))
164

    
165
-- | Builds the response to a given query.
166
buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer
167
buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) =
168
  return (ReplyStatusOk, J.showJSON (configVersion cfg))
169

    
170
buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
171
  case confdRqQuery req of
172
    EmptyQuery -> return (ReplyStatusOk, J.showJSON master_name)
173
    PlainQuery _ -> return queryArgumentError
174
    DictQuery reqq -> do
175
      mnode <- gntErrorToResult $ getNode cfg master_name
176
      let fvals = map (\field -> case field of
177
                                   ReqFieldName -> master_name
178
                                   ReqFieldIp -> clusterMasterIp cluster
179
                                   ReqFieldMNodePip -> nodePrimaryIp mnode
180
                      ) (confdReqQFields reqq)
181
      return (ReplyStatusOk, J.showJSON fvals)
182
    where master_name = clusterMasterNode cluster
183
          cluster = configCluster cfg
184
          cfg = fst cdata
185

    
186
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do
187
  node_name <- case confdRqQuery req of
188
                 PlainQuery str -> return str
189
                 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
190
  role <- nodeRole (fst cdata) node_name
191
  return (ReplyStatusOk, J.showJSON role)
192

    
193
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) =
194
  -- note: we use foldlWithKey because that's present accross more
195
  -- versions of the library
196
  return (ReplyStatusOk, J.showJSON $
197
          M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) []
198
          (fromContainer . configNodes . fst $ cdata))
199

    
200
buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
201
  -- note: we use foldlWithKey because that's present accross more
202
  -- versions of the library
203
  return (ReplyStatusOk, J.showJSON $
204
          M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n
205
                                         then nodePrimaryIp n:accu
206
                                         else accu) []
207
          (fromContainer . configNodes . fst $ cdata))
208

    
209
buildResponse (cfg, linkipmap)
210
              req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do
211
  link <- case confdRqQuery req of
212
            PlainQuery str -> return str
213
            EmptyQuery -> return (getDefaultNicLink cfg)
214
            _ -> fail "Invalid query type"
215
  return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link)
216

    
217
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip
218
                                  , confdRqQuery = DictQuery query}) =
219
  let (cfg, linkipmap) = cdata
220
      link = fromMaybe (getDefaultNicLink cfg) (confdReqQLink query)
221
  in case confdReqQIp query of
222
       Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip
223
       Nothing -> return (ReplyStatusOk,
224
                          J.showJSON $
225
                           map (getNodePipByInstanceIp cfg linkipmap link)
226
                           (confdReqQIpList query))
227

    
228
buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) =
229
  return queryArgumentError
230

    
231
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do
232
  let cfg = fst cdata
233
  node_name <- case confdRqQuery req of
234
                 PlainQuery str -> return str
235
                 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
236
  node <- gntErrorToResult $ getNode cfg node_name
237
  let minors = concatMap (getInstMinorsForNode (nodeName node)) .
238
               M.elems . fromContainer . configInstances $ cfg
239
      encoded = [J.JSArray [J.showJSON a, J.showJSON b, J.showJSON c,
240
                             J.showJSON d, J.showJSON e, J.showJSON f] |
241
                 (a, b, c, d, e, f) <- minors]
242
  return (ReplyStatusOk, J.showJSON encoded)
243

    
244
-- | Creates a ConfdReply from a given answer.
245
serializeResponse :: Result StatusAnswer -> ConfdReply
246
serializeResponse r =
247
    let (status, result) = case r of
248
                    Bad err -> (ReplyStatusError, J.showJSON err)
249
                    Ok (code, val) -> (code, val)
250
    in ConfdReply { confdReplyProtocol = 1
251
                  , confdReplyStatus   = status
252
                  , confdReplyAnswer   = result
253
                  , confdReplySerial   = 0 }
254

    
255
-- * Configuration handling
256

    
257
-- ** Helper functions
258

    
259
-- | Helper function for logging transition into polling mode.
260
moveToPolling :: String -> INotify -> FilePath -> CRef -> MVar ServerState
261
              -> IO ReloadModel
262
moveToPolling msg inotify path cref mstate = do
263
  logInfo $ "Moving to polling mode: " ++ msg
264
  let inotiaction = addNotifier inotify path cref mstate
265
  _ <- forkIO $ onReloadTimer inotiaction path cref mstate
266
  return initialPoll
267

    
268
-- | Helper function for logging transition into inotify mode.
269
moveToNotify :: IO ReloadModel
270
moveToNotify = do
271
  logInfo "Moving to inotify mode"
272
  return ReloadNotify
273

    
274
-- ** Configuration loading
275

    
276
-- | (Re)loads the configuration.
277
updateConfig :: FilePath -> CRef -> IO ()
278
updateConfig path r = do
279
  newcfg <- loadConfig path
280
  let !newdata = case newcfg of
281
                   Ok !cfg -> Ok (cfg, buildLinkIpInstnameMap cfg)
282
                   Bad _ -> Bad "Cannot load configuration"
283
  writeIORef r newdata
284
  case newcfg of
285
    Ok cfg -> logInfo ("Loaded new config, serial " ++
286
                       show (configSerial cfg))
287
    Bad msg -> logError $ "Failed to load config: " ++ msg
288
  return ()
289

    
290
-- | Wrapper over 'updateConfig' that handles IO errors.
291
safeUpdateConfig :: FilePath -> FStat -> CRef -> IO (FStat, ConfigReload)
292
safeUpdateConfig path oldfstat cref =
293
  Control.Exception.catch
294
        (do
295
          nt <- needsReload oldfstat path
296
          case nt of
297
            Nothing -> return (oldfstat, ConfigToDate)
298
            Just nt' -> do
299
                    updateConfig path cref
300
                    return (nt', ConfigReloaded)
301
        ) (\e -> do
302
             let msg = "Failure during configuration update: " ++
303
                       show (e::IOError)
304
             writeIORef cref (Bad msg)
305
             return (nullFStat, ConfigIOError)
306
          )
307

    
308
-- | Computes the file cache data from a FileStatus structure.
309
buildFileStatus :: FileStatus -> FStat
310
buildFileStatus ofs =
311
    let modt = modificationTime ofs
312
        inum = fileID ofs
313
        fsize = fileSize ofs
314
    in (modt, inum, fsize)
315

    
316
-- | Wrapper over 'buildFileStatus'. This reads the data from the
317
-- filesystem and then builds our cache structure.
318
getFStat :: FilePath -> IO FStat
319
getFStat p = liftM buildFileStatus (getFileStatus p)
320

    
321
-- | Check if the file needs reloading
322
needsReload :: FStat -> FilePath -> IO (Maybe FStat)
323
needsReload oldstat path = do
324
  newstat <- getFStat path
325
  return $ if newstat /= oldstat
326
             then Just newstat
327
             else Nothing
328

    
329
-- ** Watcher threads
330

    
331
-- $watcher
332
-- We have three threads/functions that can mutate the server state:
333
--
334
-- 1. the long-interval watcher ('onTimeoutTimer')
335
--
336
-- 2. the polling watcher ('onReloadTimer')
337
--
338
-- 3. the inotify event handler ('onInotify')
339
--
340
-- All of these will mutate the server state under 'modifyMVar' or
341
-- 'modifyMVar_', so that server transitions are more or less
342
-- atomic. The inotify handler remains active during polling mode, but
343
-- checks for polling mode and doesn't do anything in this case (this
344
-- check is needed even if we would unregister the event handler due
345
-- to how events are serialised).
346

    
347
-- | Long-interval reload watcher.
348
--
349
-- This is on top of the inotify-based triggered reload.
350
onTimeoutTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
351
onTimeoutTimer inotiaction path cref state = do
352
  threadDelay configReloadTimeout
353
  modifyMVar_ state (onTimeoutInner path cref)
354
  _ <- inotiaction
355
  onTimeoutTimer inotiaction path cref state
356

    
357
-- | Inner onTimeout handler.
358
--
359
-- This mutates the server state under a modifyMVar_ call. It never
360
-- changes the reload model, just does a safety reload and tried to
361
-- re-establish the inotify watcher.
362
onTimeoutInner :: FilePath -> CRef -> ServerState -> IO ServerState
363
onTimeoutInner path cref state  = do
364
  (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
365
  return state { reloadFStat = newfstat }
366

    
367
-- | Short-interval (polling) reload watcher.
368
--
369
-- This is only active when we're in polling mode; it will
370
-- automatically exit when it detects that the state has changed to
371
-- notification.
372
onReloadTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
373
onReloadTimer inotiaction path cref state = do
374
  continue <- modifyMVar state (onReloadInner inotiaction path cref)
375
  when continue $
376
    do threadDelay configReloadRatelimit
377
       onReloadTimer inotiaction path cref state
378
  -- the inotify watch has been re-established, we can exit
379

    
380
-- | Inner onReload handler.
381
--
382
-- This again mutates the state under a modifyMVar call, and also
383
-- returns whether the thread should continue or not.
384
onReloadInner :: IO Bool -> FilePath -> CRef -> ServerState
385
              -> IO (ServerState, Bool)
386
onReloadInner _ _ _ state@(ServerState { reloadModel = ReloadNotify } ) =
387
  return (state, False)
388
onReloadInner inotiaction path cref
389
              state@(ServerState { reloadModel = ReloadPoll pround } ) = do
390
  (newfstat, reload) <- safeUpdateConfig path (reloadFStat state) cref
391
  let state' = state { reloadFStat = newfstat }
392
  -- compute new poll model based on reload data; however, failure to
393
  -- re-establish the inotifier means we stay on polling
394
  newmode <- case reload of
395
               ConfigToDate ->
396
                 if pround >= maxIdlePollRounds
397
                   then do -- try to switch to notify
398
                     result <- inotiaction
399
                     if result
400
                       then moveToNotify
401
                       else return initialPoll
402
                   else return (ReloadPoll (pround + 1))
403
               _ -> return initialPoll
404
  let continue = case newmode of
405
                   ReloadNotify -> False
406
                   _            -> True
407
  return (state' { reloadModel = newmode }, continue)
408

    
409
-- the following hint is because hlint doesn't understand our const
410
-- (return False) is so that we can give a signature to 'e'
411
{-# ANN addNotifier "HLint: ignore Evaluate" #-}
412
-- | Setup inotify watcher.
413
--
414
-- This tries to setup the watch descriptor; in case of any IO errors,
415
-- it will return False.
416
addNotifier :: INotify -> FilePath -> CRef -> MVar ServerState -> IO Bool
417
addNotifier inotify path cref mstate =
418
  Control.Exception.catch
419
        (addWatch inotify [CloseWrite] path
420
                    (onInotify inotify path cref mstate) >> return True)
421
        (\e -> const (return False) (e::IOError))
422

    
423
-- | Inotify event handler.
424
onInotify :: INotify -> String -> CRef -> MVar ServerState -> Event -> IO ()
425
onInotify inotify path cref mstate Ignored = do
426
  logDebug "File lost, trying to re-establish notifier"
427
  modifyMVar_ mstate $ \state -> do
428
    result <- addNotifier inotify path cref mstate
429
    (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
430
    let state' = state { reloadFStat = newfstat }
431
    if result
432
      then return state' -- keep notify
433
      else do
434
        mode <- moveToPolling "cannot re-establish inotify watch" inotify
435
                  path cref mstate
436
        return state' { reloadModel = mode }
437

    
438
onInotify inotify path cref mstate _ =
439
  modifyMVar_ mstate $ \state ->
440
    if reloadModel state == ReloadNotify
441
       then do
442
         ctime <- getCurrentTime
443
         (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
444
         let state' = state { reloadFStat = newfstat, reloadTime = ctime }
445
         if abs (reloadTime state - ctime) < reloadRatelimitSec
446
           then do
447
             mode <- moveToPolling "too many reloads" inotify path cref mstate
448
             return state' { reloadModel = mode }
449
           else return state'
450
      else return state
451

    
452
-- ** Client input/output handlers
453

    
454
-- | Main loop for a given client.
455
responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO ()
456
responder cfgref socket hmac msg peer = do
457
  ctime <- getCurrentTime
458
  case parseRequest hmac msg ctime of
459
    Ok (origmsg, rq) -> do
460
              logDebug $ "Processing request: " ++ rStripSpace origmsg
461
              mcfg <- readIORef cfgref
462
              let response = respondInner mcfg hmac rq
463
              _ <- S.sendTo socket response peer
464
              return ()
465
    Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
466
  return ()
467

    
468
-- | Inner helper function for a given client. This generates the
469
-- final encoded message (as a string), ready to be sent out to the
470
-- client.
471
respondInner :: Result (ConfigData, LinkIpMap) -> HashKey
472
             -> ConfdRequest -> String
473
respondInner cfg hmac rq =
474
  let rsalt = confdRqRsalt rq
475
      innermsg = serializeResponse (cfg >>= flip buildResponse rq)
476
      innerserialised = J.encodeStrict innermsg
477
      outermsg = signMessage hmac rsalt innerserialised
478
      outerserialised = confdMagicFourcc ++ J.encodeStrict outermsg
479
  in outerserialised
480

    
481
-- | Main listener loop.
482
listener :: S.Socket -> HashKey
483
         -> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
484
         -> IO ()
485
listener s hmac resp = do
486
  (msg, _, peer) <- S.recvFrom s 4096
487
  if confdMagicFourcc `isPrefixOf` msg
488
    then forkIO (resp s hmac (drop 4 msg) peer) >> return ()
489
    else logDebug "Invalid magic code!" >> return ()
490
  return ()
491

    
492
-- | Extract the configuration from our IORef.
493
configReader :: CRef -> IO (Result ConfigData)
494
configReader cref = do
495
  cdata <- readIORef cref
496
  return $ liftM fst cdata
497

    
498
-- | Type alias for prepMain results
499
type PrepResult = (S.Socket, (FilePath, S.Socket),
500
                   IORef (Result (ConfigData, LinkIpMap)))
501

    
502
-- | Check function for confd.
503
checkMain :: CheckFn (S.Family, S.SockAddr)
504
checkMain opts = do
505
  parseresult <- parseAddress opts C.defaultConfdPort
506
  case parseresult of
507
    Bad msg -> do
508
      hPutStrLn stderr $ "parsing bind address: " ++ msg
509
      return . Left $ ExitFailure 1
510
    Ok v -> return $ Right v
511

    
512
-- | Prepare function for confd.
513
prepMain :: PrepFn (S.Family, S.SockAddr) PrepResult
514
prepMain _ (af_family, bindaddr) = do
515
  s <- S.socket af_family S.Datagram S.defaultProtocol
516
  S.bindSocket s bindaddr
517
  -- prepare the queryd listener
518
  query_data <- prepQueryD Nothing
519
  cref <- newIORef (Bad "Configuration not yet loaded")
520
  return (s, query_data, cref)
521

    
522
-- | Main function.
523
main :: MainFn (S.Family, S.SockAddr) PrepResult
524
main _ _ (s, query_data, cref) = do
525
  -- try to load the configuration, if possible
526
  conf_file <- Path.clusterConfFile
527
  (fstat, _) <- safeUpdateConfig conf_file nullFStat cref
528
  ctime <- getCurrentTime
529
  statemvar <- newMVar $ ServerState initialPoll ctime fstat
530
  hmac <- getClusterHmac
531
  -- Inotify setup
532
  inotify <- initINotify
533
  let inotiaction = addNotifier inotify conf_file cref statemvar
534
  -- fork the timeout timer
535
  _ <- forkIO $ onTimeoutTimer inotiaction conf_file cref statemvar
536
  -- fork the polling timer
537
  _ <- forkIO $ onReloadTimer inotiaction conf_file cref statemvar
538
  -- launch the queryd listener
539
  _ <- forkIO $ runQueryD query_data (configReader cref)
540
  -- and finally enter the responder loop
541
  forever $ listener s hmac (responder cref)