Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Daemon.hs @ 82b948e4

History | View | Annotate | Download (16.2 kB)

1
{-| Implementation of the generic daemon functionality.
2

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2011, 2012 Google Inc.
8

    
9
This program is free software; you can redistribute it and/or modify
10
it under the terms of the GNU General Public License as published by
11
the Free Software Foundation; either version 2 of the License, or
12
(at your option) any later version.
13

    
14
This program is distributed in the hope that it will be useful, but
15
WITHOUT ANY WARRANTY; without even the implied warranty of
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17
General Public License for more details.
18

    
19
You should have received a copy of the GNU General Public License
20
along with this program; if not, write to the Free Software
21
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22
02110-1301, USA.
23

    
24
-}
25

    
26
module Ganeti.Daemon
27
  ( DaemonOptions(..)
28
  , OptType
29
  , CheckFn
30
  , PrepFn
31
  , MainFn
32
  , defaultOptions
33
  , oShowHelp
34
  , oShowVer
35
  , oNoDaemonize
36
  , oNoUserChecks
37
  , oDebug
38
  , oPort
39
  , oBindAddress
40
  , oSyslogUsage
41
  , parseArgs
42
  , parseAddress
43
  , cleanupSocket
44
  , describeError
45
  , genericMain
46
  ) where
47

    
48
import Control.Concurrent
49
import Control.Exception
50
import Control.Monad
51
import Data.Maybe (fromMaybe, listToMaybe)
52
import Data.Word
53
import GHC.IO.Handle (hDuplicateTo)
54
import Network.BSD (getHostName)
55
import qualified Network.Socket as Socket
56
import System.Console.GetOpt
57
import System.Directory
58
import System.Exit
59
import System.Environment
60
import System.IO
61
import System.IO.Error (isDoesNotExistError, modifyIOError, annotateIOError)
62
import System.Posix.Directory
63
import System.Posix.Files
64
import System.Posix.IO
65
import System.Posix.Process
66
import System.Posix.Types
67
import System.Posix.Signals
68

    
69
import Ganeti.Common as Common
70
import Ganeti.Logging
71
import Ganeti.Runtime
72
import Ganeti.BasicTypes
73
import Ganeti.Utils
74
import qualified Ganeti.Constants as C
75
import qualified Ganeti.Ssconf as Ssconf
76

    
77
-- * Constants
78

    
79
-- | \/dev\/null path.
80
devNull :: FilePath
81
devNull = "/dev/null"
82

    
83
-- | Error message prefix, used in two separate paths (when forking
84
-- and when not).
85
daemonStartupErr :: String -> String
86
daemonStartupErr = ("Error when starting the daemon process: " ++)
87

    
88
-- * Data types
89

    
90
-- | Command line options structure.
91
data DaemonOptions = DaemonOptions
92
  { optShowHelp     :: Bool           -- ^ Just show the help
93
  , optShowVer      :: Bool           -- ^ Just show the program version
94
  , optShowComp     :: Bool           -- ^ Just show the completion info
95
  , optDaemonize    :: Bool           -- ^ Whether to daemonize or not
96
  , optPort         :: Maybe Word16   -- ^ Override for the network port
97
  , optDebug        :: Bool           -- ^ Enable debug messages
98
  , optNoUserChecks :: Bool           -- ^ Ignore user checks
99
  , optBindAddress  :: Maybe String   -- ^ Override for the bind address
100
  , optSyslogUsage  :: Maybe SyslogUsage -- ^ Override for Syslog usage
101
  }
102

    
103
-- | Default values for the command line options.
104
defaultOptions :: DaemonOptions
105
defaultOptions  = DaemonOptions
106
  { optShowHelp     = False
107
  , optShowVer      = False
108
  , optShowComp     = False
109
  , optDaemonize    = True
110
  , optPort         = Nothing
111
  , optDebug        = False
112
  , optNoUserChecks = False
113
  , optBindAddress  = Nothing
114
  , optSyslogUsage  = Nothing
115
  }
116

    
117
instance StandardOptions DaemonOptions where
118
  helpRequested = optShowHelp
119
  verRequested  = optShowVer
120
  compRequested = optShowComp
121
  requestHelp o = o { optShowHelp = True }
122
  requestVer  o = o { optShowVer  = True }
123
  requestComp o = o { optShowComp = True }
124

    
125
-- | Abrreviation for the option type.
126
type OptType = GenericOptType DaemonOptions
127

    
128
-- | Check function type.
129
type CheckFn a = DaemonOptions -> IO (Either ExitCode a)
130

    
131
-- | Prepare function type.
132
type PrepFn a b = DaemonOptions -> a -> IO b
133

    
134
-- | Main execution function type.
135
type MainFn a b = DaemonOptions -> a -> b -> IO ()
136

    
137
-- * Command line options
138

    
139
oNoDaemonize :: OptType
140
oNoDaemonize =
141
  (Option "f" ["foreground"]
142
   (NoArg (\ opts -> Ok opts { optDaemonize = False}))
143
   "Don't detach from the current terminal",
144
   OptComplNone)
145

    
146
oDebug :: OptType
147
oDebug =
148
  (Option "d" ["debug"]
149
   (NoArg (\ opts -> Ok opts { optDebug = True }))
150
   "Enable debug messages",
151
   OptComplNone)
152

    
153
oNoUserChecks :: OptType
154
oNoUserChecks =
155
  (Option "" ["no-user-checks"]
156
   (NoArg (\ opts -> Ok opts { optNoUserChecks = True }))
157
   "Ignore user checks",
158
   OptComplNone)
159

    
160
oPort :: Int -> OptType
161
oPort def =
162
  (Option "p" ["port"]
163
   (reqWithConversion (tryRead "reading port")
164
    (\port opts -> Ok opts { optPort = Just port }) "PORT")
165
   ("Network port (default: " ++ show def ++ ")"),
166
   OptComplInteger)
167

    
168
oBindAddress :: OptType
169
oBindAddress =
170
  (Option "b" ["bind"]
171
   (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr })
172
    "ADDR")
173
   "Bind address (default depends on cluster configuration)",
174
   OptComplInetAddr)
175

    
176
oSyslogUsage :: OptType
177
oSyslogUsage =
178
  (Option "" ["syslog"]
179
   (reqWithConversion syslogUsageFromRaw
180
    (\su opts -> Ok opts { optSyslogUsage = Just su })
181
    "SYSLOG")
182
   ("Enable logging to syslog (except debug \
183
    \messages); one of 'no', 'yes' or 'only' [" ++ C.syslogUsage ++
184
    "]"),
185
   OptComplChoices ["yes", "no", "only"])
186

    
187
-- | Generic options.
188
genericOpts :: [OptType]
189
genericOpts = [ oShowHelp
190
              , oShowVer
191
              , oShowComp
192
              ]
193

    
194
-- | Annotates and transforms IOErrors into a Result type. This can be
195
-- used in the error handler argument to 'catch', for example.
196
ioErrorToResult :: String -> IOError -> IO (Result a)
197
ioErrorToResult description exc =
198
  return . Bad $ description ++ ": " ++ show exc
199

    
200
-- | Small wrapper over getArgs and 'parseOpts'.
201
parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
202
parseArgs cmd options = do
203
  cmd_args <- getArgs
204
  parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) []
205

    
206
-- * Daemon-related functions
207

    
208
-- | PID file mode.
209
pidFileMode :: FileMode
210
pidFileMode = unionFileModes ownerReadMode ownerWriteMode
211

    
212
-- | PID file open flags.
213
pidFileFlags :: OpenFileFlags
214
pidFileFlags = defaultFileFlags { noctty = True, trunc = False }
215

    
216
-- | Writes a PID file and locks it.
217
writePidFile :: FilePath -> IO Fd
218
writePidFile path = do
219
  fd <- openFd path ReadWrite (Just pidFileMode) pidFileFlags
220
  setLock fd (WriteLock, AbsoluteSeek, 0, 0)
221
  my_pid <- getProcessID
222
  _ <- fdWrite fd (show my_pid ++ "\n")
223
  return fd
224

    
225
-- | Helper function to ensure a socket doesn't exist. Should only be
226
-- called once we have locked the pid file successfully.
227
cleanupSocket :: FilePath -> IO ()
228
cleanupSocket socketPath =
229
  catchJust (guard . isDoesNotExistError) (removeLink socketPath)
230
            (const $ return ())
231

    
232
-- | Sets up a daemon's environment.
233
setupDaemonEnv :: FilePath -> FileMode -> IO ()
234
setupDaemonEnv cwd umask = do
235
  changeWorkingDirectory cwd
236
  _ <- setFileCreationMask umask
237
  _ <- createSession
238
  return ()
239

    
240
-- | Cleanup function, performing all the operations that need to be done prior
241
-- to shutting down a daemon.
242
finalCleanup :: FilePath -> IO ()
243
finalCleanup = removeFile
244

    
245
-- | Signal handler for the termination signal.
246
handleSigTerm :: ThreadId -> IO ()
247
handleSigTerm mainTID =
248
  -- Throw termination exception to the main thread, so that the daemon is
249
  -- actually stopped in the proper way, executing all the functions waiting on
250
  -- "finally" statement.
251
  Control.Exception.throwTo mainTID ExitSuccess
252

    
253
-- | Signal handler for reopening log files.
254
handleSigHup :: FilePath -> IO ()
255
handleSigHup path = do
256
  setupDaemonFDs (Just path)
257
  logInfo "Reopening log files after receiving SIGHUP"
258

    
259
-- | Sets up a daemon's standard file descriptors.
260
setupDaemonFDs :: Maybe FilePath -> IO ()
261
setupDaemonFDs logfile = do
262
  null_in_handle <- openFile devNull ReadMode
263
  null_out_handle <- openFile (fromMaybe devNull logfile) AppendMode
264
  hDuplicateTo null_in_handle stdin
265
  hDuplicateTo null_out_handle stdout
266
  hDuplicateTo null_out_handle stderr
267
  hClose null_in_handle
268
  hClose null_out_handle
269

    
270
-- | Computes the default bind address for a given family.
271
defaultBindAddr :: Int                  -- ^ The port we want
272
                -> Socket.Family        -- ^ The cluster IP family
273
                -> Result (Socket.Family, Socket.SockAddr)
274
defaultBindAddr port Socket.AF_INET =
275
  Ok (Socket.AF_INET,
276
      Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
277
defaultBindAddr port Socket.AF_INET6 =
278
  Ok (Socket.AF_INET6,
279
      Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
280
defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam
281

    
282
-- | Default hints for the resolver
283
resolveAddrHints :: Maybe Socket.AddrInfo
284
resolveAddrHints =
285
  Just Socket.defaultHints { Socket.addrFlags = [Socket.AI_NUMERICHOST,
286
                                                 Socket.AI_NUMERICSERV] }
287

    
288
-- | Resolves a numeric address.
289
resolveAddr :: Int -> String -> IO (Result (Socket.Family, Socket.SockAddr))
290
resolveAddr port str = do
291
  resolved <- Socket.getAddrInfo resolveAddrHints (Just str) (Just (show port))
292
  return $ case resolved of
293
             [] -> Bad "Invalid results from lookup?"
294
             best:_ -> Ok (Socket.addrFamily best, Socket.addrAddress best)
295

    
296
-- | Based on the options, compute the socket address to use for the
297
-- daemon.
298
parseAddress :: DaemonOptions      -- ^ Command line options
299
             -> Int                -- ^ Default port for this daemon
300
             -> IO (Result (Socket.Family, Socket.SockAddr))
301
parseAddress opts defport = do
302
  let port = maybe defport fromIntegral $ optPort opts
303
  def_family <- Ssconf.getPrimaryIPFamily Nothing
304
  case optBindAddress opts of
305
    Nothing -> return (def_family >>= defaultBindAddr port)
306
    Just saddr -> Control.Exception.catch
307
                    (resolveAddr port saddr)
308
                    (ioErrorToResult $ "Invalid address " ++ saddr)
309

    
310
-- | Environment variable to override the assumed host name of the
311
-- current node.
312
vClusterHostNameEnvVar :: String
313
vClusterHostNameEnvVar = "GANETI_HOSTNAME"
314

    
315
getFQDN :: IO String
316
getFQDN = do
317
  hostname <- getHostName
318
  addrInfos <- Socket.getAddrInfo Nothing (Just hostname) Nothing
319
  let address = listToMaybe addrInfos >>= (Just . Socket.addrAddress)
320
  case address of
321
    Just a -> do
322
      fqdn <- liftM fst $ Socket.getNameInfo [] True False a
323
      return (fromMaybe hostname fqdn)
324
    Nothing -> return hostname
325

    
326
-- | Returns if the current node is the master node.
327
isMaster :: IO Bool
328
isMaster = do
329
  let ioErrorToNothing :: IOError -> IO (Maybe String)
330
      ioErrorToNothing _ = return Nothing
331
  vcluster_node <- Control.Exception.catch
332
                     (liftM Just (getEnv vClusterHostNameEnvVar))
333
                     ioErrorToNothing
334
  curNode <- case vcluster_node of
335
    Just node_name -> return node_name
336
    Nothing -> getFQDN
337
  masterNode <- Ssconf.getMasterNode Nothing
338
  case masterNode of
339
    Ok n -> return (curNode == n)
340
    Bad _ -> return False
341

    
342
-- | Ensures that the daemon runs on the right node (and exits
343
-- gracefully if it doesnt)
344
ensureNode :: GanetiDaemon -> IO ()
345
ensureNode daemon = do
346
  is_master <- isMaster
347
  when (daemonOnlyOnMaster daemon && not is_master) $ do
348
    putStrLn "Not master, exiting."
349
    exitWith (ExitFailure C.exitNotmaster)
350

    
351
-- | Run an I\/O action that might throw an I\/O error, under a
352
-- handler that will simply annotate and re-throw the exception.
353
describeError :: String -> Maybe Handle -> Maybe FilePath -> IO a -> IO a
354
describeError descr hndl fpath =
355
  modifyIOError (\e -> annotateIOError e descr hndl fpath)
356

    
357
-- | Run an I\/O action as a daemon.
358
--
359
-- WARNING: this only works in single-threaded mode (either using the
360
-- single-threaded runtime, or using the multi-threaded one but with
361
-- only one OS thread, i.e. -N1).
362
daemonize :: FilePath -> (Maybe Fd -> IO ()) -> IO ()
363
daemonize logfile action = do
364
  (rpipe, wpipe) <- createPipe
365
  -- first fork
366
  _ <- forkProcess $ do
367
    -- in the child
368
    closeFd rpipe
369
    let wpipe' = Just wpipe
370
    setupDaemonEnv "/" (unionFileModes groupModes otherModes)
371
    setupDaemonFDs (Just logfile) `Control.Exception.catch`
372
      handlePrepErr False wpipe'
373
    _ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing
374
    -- second fork, launches the actual child code; standard
375
    -- double-fork technique
376
    _ <- forkProcess (action wpipe')
377
    exitImmediately ExitSuccess
378
  closeFd wpipe
379
  hndl <- fdToHandle rpipe
380
  errors <- hGetContents hndl
381
  ecode <- if null errors
382
             then return ExitSuccess
383
             else do
384
               hPutStrLn stderr $ daemonStartupErr errors
385
               return $ ExitFailure C.exitFailure
386
  exitImmediately ecode
387

    
388
-- | Generic daemon startup.
389
genericMain :: GanetiDaemon -- ^ The daemon we're running
390
            -> [OptType]    -- ^ The available options
391
            -> CheckFn a    -- ^ Check function
392
            -> PrepFn  a b  -- ^ Prepare function
393
            -> MainFn  a b  -- ^ Execution function
394
            -> IO ()
395
genericMain daemon options check_fn prep_fn exec_fn = do
396
  let progname = daemonName daemon
397

    
398
  (opts, args) <- parseArgs progname options
399

    
400
  ensureNode daemon
401

    
402
  exitUnless (null args) "This program doesn't take any arguments"
403

    
404
  unless (optNoUserChecks opts) $ do
405
    runtimeEnts <- getEnts
406
    ents <- exitIfBad "Can't find required user/groups" runtimeEnts
407
    verifyDaemonUser daemon ents
408

    
409
  syslog <- case optSyslogUsage opts of
410
              Nothing -> exitIfBad "Invalid cluster syslog setting" $
411
                         syslogUsageFromRaw C.syslogUsage
412
              Just v -> return v
413

    
414
  log_file <- daemonLogFile daemon
415
  -- run the check function and optionally exit if it returns an exit code
416
  check_result <- check_fn opts
417
  check_result' <- case check_result of
418
                     Left code -> exitWith code
419
                     Right v -> return v
420

    
421
  let processFn = if optDaemonize opts
422
                    then daemonize log_file
423
                    else \action -> action Nothing
424
  processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn
425

    
426
-- | Full prepare function.
427
--
428
-- This is executed after daemonization, and sets up both the log
429
-- files (a generic functionality) and the custom prepare function of
430
-- the daemon.
431
fullPrep :: GanetiDaemon  -- ^ The daemon we're running
432
         -> DaemonOptions -- ^ The options structure, filled from the cmdline
433
         -> SyslogUsage   -- ^ Syslog mode
434
         -> a             -- ^ Check results
435
         -> PrepFn a b    -- ^ Prepare function
436
         -> IO (FilePath, b)
437
fullPrep daemon opts syslog check_result prep_fn = do
438
  logfile <- if optDaemonize opts
439
               then return Nothing
440
               else liftM Just $ daemonLogFile daemon
441
  pidfile <- daemonPidFile daemon
442
  let dname = daemonName daemon
443
  setupLogging logfile dname (optDebug opts) True False syslog
444
  _ <- describeError "writing PID file; already locked?"
445
         Nothing (Just pidfile) $ writePidFile pidfile
446
  logNotice $ dname ++ " daemon startup"
447
  prep_res <- prep_fn opts check_result
448
  tid <- myThreadId
449
  _ <- installHandler sigTERM (Catch $ handleSigTerm tid) Nothing
450
  return (pidfile, prep_res)
451

    
452
-- | Inner daemon function.
453
--
454
-- This is executed after daemonization.
455
innerMain :: GanetiDaemon  -- ^ The daemon we're running
456
          -> DaemonOptions -- ^ The options structure, filled from the cmdline
457
          -> SyslogUsage   -- ^ Syslog mode
458
          -> a             -- ^ Check results
459
          -> PrepFn a b    -- ^ Prepare function
460
          -> MainFn a b    -- ^ Execution function
461
          -> Maybe Fd      -- ^ Error reporting function
462
          -> IO ()
463
innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
464
  (pidFile, prep_result) <- fullPrep daemon opts syslog check_result prep_fn
465
                 `Control.Exception.catch` handlePrepErr True fd
466
  -- no error reported, we should now close the fd
467
  maybeCloseFd fd
468
  finally (exec_fn opts check_result prep_result) (finalCleanup pidFile)
469

    
470
-- | Daemon prepare error handling function.
471
handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
472
handlePrepErr logging_setup fd err = do
473
  let msg = show err
474
  case fd of
475
    -- explicitly writing to the fd directly, since when forking it's
476
    -- better (safer) than trying to convert this into a full handle
477
    Just fd' -> fdWrite fd' msg >> return ()
478
    Nothing  -> hPutStrLn stderr (daemonStartupErr msg)
479
  when logging_setup $ logError msg
480
  exitWith $ ExitFailure 1
481

    
482
-- | Close a file descriptor.
483
maybeCloseFd :: Maybe Fd -> IO ()
484
maybeCloseFd Nothing   = return ()
485
maybeCloseFd (Just fd) = closeFd fd