Daemon.hs 16.9 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
{-| Implementation of the generic daemon functionality.

-}

{-

Copyright (C) 2011, 2012 Google Inc.

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

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

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

-}

module Ganeti.Daemon
  ( DaemonOptions(..)
  , OptType
29 30 31
  , CheckFn
  , PrepFn
  , MainFn
32 33 34 35 36 37 38
  , defaultOptions
  , oShowHelp
  , oShowVer
  , oNoDaemonize
  , oNoUserChecks
  , oDebug
  , oPort
Iustin Pop's avatar
Iustin Pop committed
39
  , oBindAddress
40
  , oSyslogUsage
41
  , oForceNode
42 43
  , oNoVoting
  , oYesDoIt
44
  , parseArgs
Iustin Pop's avatar
Iustin Pop committed
45
  , parseAddress
46
  , cleanupSocket
47
  , describeError
48
  , genericMain
Klaus Aehlig's avatar
Klaus Aehlig committed
49
  , getFQDN
50 51
  ) where

52
import Control.Concurrent
53
import Control.Exception
54
import Control.Monad
55
import Data.Maybe (fromMaybe, listToMaybe)
56
import Text.Printf
57
import Data.Word
58
import GHC.IO.Handle (hDuplicateTo)
59
import Network.BSD (getHostName)
Iustin Pop's avatar
Iustin Pop committed
60
import qualified Network.Socket as Socket
61
import System.Console.GetOpt
62
import System.Directory
63 64 65
import System.Exit
import System.Environment
import System.IO
66
import System.IO.Error (isDoesNotExistError, modifyIOError, annotateIOError)
67 68 69 70 71
import System.Posix.Directory
import System.Posix.Files
import System.Posix.IO
import System.Posix.Process
import System.Posix.Types
72
import System.Posix.Signals
73

Iustin Pop's avatar
Iustin Pop committed
74
import Ganeti.Common as Common
75 76 77
import Ganeti.Logging
import Ganeti.Runtime
import Ganeti.BasicTypes
78
import Ganeti.Utils
79
import qualified Ganeti.Constants as C
Iustin Pop's avatar
Iustin Pop committed
80
import qualified Ganeti.Ssconf as Ssconf
81

82 83 84 85 86 87
-- * Constants

-- | \/dev\/null path.
devNull :: FilePath
devNull = "/dev/null"

88 89 90 91 92
-- | Error message prefix, used in two separate paths (when forking
-- and when not).
daemonStartupErr :: String -> String
daemonStartupErr = ("Error when starting the daemon process: " ++)

93 94 95 96 97 98
-- * Data types

-- | Command line options structure.
data DaemonOptions = DaemonOptions
  { optShowHelp     :: Bool           -- ^ Just show the help
  , optShowVer      :: Bool           -- ^ Just show the program version
99
  , optShowComp     :: Bool           -- ^ Just show the completion info
100 101 102 103
  , optDaemonize    :: Bool           -- ^ Whether to daemonize or not
  , optPort         :: Maybe Word16   -- ^ Override for the network port
  , optDebug        :: Bool           -- ^ Enable debug messages
  , optNoUserChecks :: Bool           -- ^ Ignore user checks
Iustin Pop's avatar
Iustin Pop committed
104
  , optBindAddress  :: Maybe String   -- ^ Override for the bind address
105
  , optSyslogUsage  :: Maybe SyslogUsage -- ^ Override for Syslog usage
106
  , optForceNode    :: Bool           -- ^ Ignore node checks
107 108
  , optNoVoting     :: Bool           -- ^ skip voting for master
  , optYesDoIt      :: Bool           -- ^ force dangerous options
109 110 111 112 113 114 115
  }

-- | Default values for the command line options.
defaultOptions :: DaemonOptions
defaultOptions  = DaemonOptions
  { optShowHelp     = False
  , optShowVer      = False
116
  , optShowComp     = False
117 118 119 120
  , optDaemonize    = True
  , optPort         = Nothing
  , optDebug        = False
  , optNoUserChecks = False
Iustin Pop's avatar
Iustin Pop committed
121
  , optBindAddress  = Nothing
122
  , optSyslogUsage  = Nothing
123
  , optForceNode    = False
124 125
  , optNoVoting     = False
  , optYesDoIt      = False
126 127
  }

Iustin Pop's avatar
Iustin Pop committed
128 129 130
instance StandardOptions DaemonOptions where
  helpRequested = optShowHelp
  verRequested  = optShowVer
131
  compRequested = optShowComp
Iustin Pop's avatar
Iustin Pop committed
132 133
  requestHelp o = o { optShowHelp = True }
  requestVer  o = o { optShowVer  = True }
134
  requestComp o = o { optShowComp = True }
Iustin Pop's avatar
Iustin Pop committed
135

136
-- | Abrreviation for the option type.
Iustin Pop's avatar
Iustin Pop committed
137
type OptType = GenericOptType DaemonOptions
138

139 140 141 142 143 144 145 146 147
-- | Check function type.
type CheckFn a = DaemonOptions -> IO (Either ExitCode a)

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

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

148 149 150
-- * Command line options

oNoDaemonize :: OptType
151 152
oNoDaemonize =
  (Option "f" ["foreground"]
153
   (NoArg (\ opts -> Ok opts { optDaemonize = False }))
154 155
   "Don't detach from the current terminal",
   OptComplNone)
156 157

oDebug :: OptType
158 159 160 161 162
oDebug =
  (Option "d" ["debug"]
   (NoArg (\ opts -> Ok opts { optDebug = True }))
   "Enable debug messages",
   OptComplNone)
163 164

oNoUserChecks :: OptType
165 166 167 168 169
oNoUserChecks =
  (Option "" ["no-user-checks"]
   (NoArg (\ opts -> Ok opts { optNoUserChecks = True }))
   "Ignore user checks",
   OptComplNone)
170 171

oPort :: Int -> OptType
172 173 174 175 176
oPort def =
  (Option "p" ["port"]
   (reqWithConversion (tryRead "reading port")
    (\port opts -> Ok opts { optPort = Just port }) "PORT")
   ("Network port (default: " ++ show def ++ ")"),
177
   OptComplInteger)
178

Iustin Pop's avatar
Iustin Pop committed
179
oBindAddress :: OptType
180 181 182 183 184 185
oBindAddress =
  (Option "b" ["bind"]
   (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr })
    "ADDR")
   "Bind address (default depends on cluster configuration)",
   OptComplInetAddr)
Iustin Pop's avatar
Iustin Pop committed
186

187
oSyslogUsage :: OptType
188 189 190 191 192 193 194 195 196
oSyslogUsage =
  (Option "" ["syslog"]
   (reqWithConversion syslogUsageFromRaw
    (\su opts -> Ok opts { optSyslogUsage = Just su })
    "SYSLOG")
   ("Enable logging to syslog (except debug \
    \messages); one of 'no', 'yes' or 'only' [" ++ C.syslogUsage ++
    "]"),
   OptComplChoices ["yes", "no", "only"])
197

198 199 200 201 202 203 204
oForceNode :: OptType
oForceNode =
  (Option "" ["force-node"]
   (NoArg (\ opts -> Ok opts { optForceNode = True }))
   "Force the daemon to run on a different node than the master",
   OptComplNone)

205 206 207 208 209 210 211 212 213 214 215 216 217 218
oNoVoting :: OptType
oNoVoting =
  (Option "" ["no-voting"]
   (NoArg (\ opts -> Ok opts { optNoVoting = True }))
   "Skip node agreement check (dangerous)",
   OptComplNone)

oYesDoIt :: OptType
oYesDoIt =
  (Option "" ["yes-do-it"]
   (NoArg (\ opts -> Ok opts { optYesDoIt = True }))
   "Force a dangerous operation",
   OptComplNone)

219 220 221 222
-- | Generic options.
genericOpts :: [OptType]
genericOpts = [ oShowHelp
              , oShowVer
223
              , oShowComp
224 225
              ]

226 227 228 229 230 231
-- | Annotates and transforms IOErrors into a Result type. This can be
-- used in the error handler argument to 'catch', for example.
ioErrorToResult :: String -> IOError -> IO (Result a)
ioErrorToResult description exc =
  return . Bad $ description ++ ": " ++ show exc

232 233 234 235
-- | Small wrapper over getArgs and 'parseOpts'.
parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
parseArgs cmd options = do
  cmd_args <- getArgs
236
  parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) []
237 238

-- * Daemon-related functions
239

240 241 242 243
-- | PID file mode.
pidFileMode :: FileMode
pidFileMode = unionFileModes ownerReadMode ownerWriteMode

244 245 246 247
-- | PID file open flags.
pidFileFlags :: OpenFileFlags
pidFileFlags = defaultFileFlags { noctty = True, trunc = False }

248
-- | Writes a PID file and locks it.
249 250
writePidFile :: FilePath -> IO Fd
writePidFile path = do
251
  fd <- openFd path ReadWrite (Just pidFileMode) pidFileFlags
252 253 254 255 256
  setLock fd (WriteLock, AbsoluteSeek, 0, 0)
  my_pid <- getProcessID
  _ <- fdWrite fd (show my_pid ++ "\n")
  return fd

257 258 259
-- | Helper function to ensure a socket doesn't exist. Should only be
-- called once we have locked the pid file successfully.
cleanupSocket :: FilePath -> IO ()
Iustin Pop's avatar
Iustin Pop committed
260
cleanupSocket socketPath =
261 262 263
  catchJust (guard . isDoesNotExistError) (removeLink socketPath)
            (const $ return ())

264 265 266 267 268 269 270 271
-- | Sets up a daemon's environment.
setupDaemonEnv :: FilePath -> FileMode -> IO ()
setupDaemonEnv cwd umask = do
  changeWorkingDirectory cwd
  _ <- setFileCreationMask umask
  _ <- createSession
  return ()

272 273 274 275 276 277 278 279 280 281 282 283 284
-- | Cleanup function, performing all the operations that need to be done prior
-- to shutting down a daemon.
finalCleanup :: FilePath -> IO ()
finalCleanup = removeFile

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

285 286 287 288 289 290
-- | Signal handler for reopening log files.
handleSigHup :: FilePath -> IO ()
handleSigHup path = do
  setupDaemonFDs (Just path)
  logInfo "Reopening log files after receiving SIGHUP"

291 292 293 294 295 296 297 298 299 300 301
-- | Sets up a daemon's standard file descriptors.
setupDaemonFDs :: Maybe FilePath -> IO ()
setupDaemonFDs logfile = do
  null_in_handle <- openFile devNull ReadMode
  null_out_handle <- openFile (fromMaybe devNull logfile) AppendMode
  hDuplicateTo null_in_handle stdin
  hDuplicateTo null_out_handle stdout
  hDuplicateTo null_out_handle stderr
  hClose null_in_handle
  hClose null_out_handle

Iustin Pop's avatar
Iustin Pop committed
302 303 304 305 306
-- | Computes the default bind address for a given family.
defaultBindAddr :: Int                  -- ^ The port we want
                -> Socket.Family        -- ^ The cluster IP family
                -> Result (Socket.Family, Socket.SockAddr)
defaultBindAddr port Socket.AF_INET =
Iustin Pop's avatar
Iustin Pop committed
307 308
  Ok (Socket.AF_INET,
      Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
Iustin Pop's avatar
Iustin Pop committed
309
defaultBindAddr port Socket.AF_INET6 =
Iustin Pop's avatar
Iustin Pop committed
310 311
  Ok (Socket.AF_INET6,
      Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
Iustin Pop's avatar
Iustin Pop committed
312 313 314 315 316 317 318 319 320 321
defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam

-- | Based on the options, compute the socket address to use for the
-- daemon.
parseAddress :: DaemonOptions      -- ^ Command line options
             -> Int                -- ^ Default port for this daemon
             -> IO (Result (Socket.Family, Socket.SockAddr))
parseAddress opts defport = do
  let port = maybe defport fromIntegral $ optPort opts
  def_family <- Ssconf.getPrimaryIPFamily Nothing
Iustin Pop's avatar
Iustin Pop committed
322 323
  case optBindAddress opts of
    Nothing -> return (def_family >>= defaultBindAddr port)
324 325
    Just saddr -> Control.Exception.catch
                    (resolveAddr port saddr)
326
                    (ioErrorToResult $ "Invalid address " ++ saddr)
Iustin Pop's avatar
Iustin Pop committed
327

328 329 330 331 332
-- | Environment variable to override the assumed host name of the
-- current node.
vClusterHostNameEnvVar :: String
vClusterHostNameEnvVar = "GANETI_HOSTNAME"

Klaus Aehlig's avatar
Klaus Aehlig committed
333 334 335
-- | Get the real full qualified host name.
getFQDN' :: IO String
getFQDN' = do
336 337 338 339 340 341 342 343 344
  hostname <- getHostName
  addrInfos <- Socket.getAddrInfo Nothing (Just hostname) Nothing
  let address = listToMaybe addrInfos >>= (Just . Socket.addrAddress)
  case address of
    Just a -> do
      fqdn <- liftM fst $ Socket.getNameInfo [] True False a
      return (fromMaybe hostname fqdn)
    Nothing -> return hostname

Klaus Aehlig's avatar
Klaus Aehlig committed
345 346 347
-- | Return the full qualified host name, honoring the vcluster setup.
getFQDN :: IO String
getFQDN = do
348 349 350 351 352
  let ioErrorToNothing :: IOError -> IO (Maybe String)
      ioErrorToNothing _ = return Nothing
  vcluster_node <- Control.Exception.catch
                     (liftM Just (getEnv vClusterHostNameEnvVar))
                     ioErrorToNothing
Klaus Aehlig's avatar
Klaus Aehlig committed
353
  case vcluster_node of
354
    Just node_name -> return node_name
Klaus Aehlig's avatar
Klaus Aehlig committed
355 356 357 358 359 360
    Nothing -> getFQDN'

-- | Returns if the current node is the master node.
isMaster :: IO Bool
isMaster = do
  curNode <- getFQDN
361 362 363 364 365 366 367
  masterNode <- Ssconf.getMasterNode Nothing
  case masterNode of
    Ok n -> return (curNode == n)
    Bad _ -> return False

-- | Ensures that the daemon runs on the right node (and exits
-- gracefully if it doesnt)
368 369
ensureNode :: GanetiDaemon -> DaemonOptions -> IO ()
ensureNode daemon opts = do
370
  is_master <- isMaster
371 372 373
  when (daemonOnlyOnMaster daemon
        && not is_master
        && not (optForceNode opts)) $ do
374 375 376
    putStrLn "Not master, exiting."
    exitWith (ExitFailure C.exitNotmaster)

377 378 379 380 381 382 383
-- | Run an I\/O action that might throw an I\/O error, under a
-- handler that will simply annotate and re-throw the exception.
describeError :: String -> Maybe Handle -> Maybe FilePath -> IO a -> IO a
describeError descr hndl fpath =
  modifyIOError (\e -> annotateIOError e descr hndl fpath)

-- | Run an I\/O action as a daemon.
384 385 386 387
--
-- WARNING: this only works in single-threaded mode (either using the
-- single-threaded runtime, or using the multi-threaded one but with
-- only one OS thread, i.e. -N1).
388
daemonize :: FilePath -> (Maybe Fd -> IO ()) -> IO ()
389
daemonize logfile action = do
390
  (rpipe, wpipe) <- createPipe
391 392 393
  -- first fork
  _ <- forkProcess $ do
    -- in the child
394
    closeFd rpipe
395
    let wpipe' = Just wpipe
396
    setupDaemonEnv "/" (unionFileModes groupModes otherModes)
397 398
    setupDaemonFDs (Just logfile) `Control.Exception.catch`
      handlePrepErr False wpipe'
399
    _ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing
400 401
    -- second fork, launches the actual child code; standard
    -- double-fork technique
402
    _ <- forkProcess (action wpipe')
403
    exitImmediately ExitSuccess
404 405 406 407 408 409 410 411 412
  closeFd wpipe
  hndl <- fdToHandle rpipe
  errors <- hGetContents hndl
  ecode <- if null errors
             then return ExitSuccess
             else do
               hPutStrLn stderr $ daemonStartupErr errors
               return $ ExitFailure C.exitFailure
  exitImmediately ecode
413 414

-- | Generic daemon startup.
415 416 417 418 419 420 421
genericMain :: GanetiDaemon -- ^ The daemon we're running
            -> [OptType]    -- ^ The available options
            -> CheckFn a    -- ^ Check function
            -> PrepFn  a b  -- ^ Prepare function
            -> MainFn  a b  -- ^ Execution function
            -> IO ()
genericMain daemon options check_fn prep_fn exec_fn = do
422
  let progname = daemonName daemon
423

424 425
  (opts, args) <- parseArgs progname options

426 427 428 429 430
  -- Modify handleClient in Ganeti.UDSServer to remove this logging from luxid.
  when (optDebug opts && daemon == GanetiLuxid) .
    hPutStrLn stderr $
      printf C.debugModeConfidentialityWarning (daemonName daemon)

431
  ensureNode daemon opts
432

Iustin Pop's avatar
Iustin Pop committed
433
  exitUnless (null args) "This program doesn't take any arguments"
434 435

  unless (optNoUserChecks opts) $ do
436
    runtimeEnts <- runResultT getEnts
Iustin Pop's avatar
Iustin Pop committed
437 438
    ents <- exitIfBad "Can't find required user/groups" runtimeEnts
    verifyDaemonUser daemon ents
439

440
  syslog <- case optSyslogUsage opts of
Iustin Pop's avatar
Iustin Pop committed
441
              Nothing -> exitIfBad "Invalid cluster syslog setting" $
442 443
                         syslogUsageFromRaw C.syslogUsage
              Just v -> return v
444

Iustin Pop's avatar
Iustin Pop committed
445
  log_file <- daemonLogFile daemon
446 447 448 449 450 451
  -- run the check function and optionally exit if it returns an exit code
  check_result <- check_fn opts
  check_result' <- case check_result of
                     Left code -> exitWith code
                     Right v -> return v

452
  let processFn = if optDaemonize opts
Iustin Pop's avatar
Iustin Pop committed
453
                    then daemonize log_file
454
                    else \action -> action Nothing
455
  processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn
456

457 458 459 460 461 462 463 464 465 466
-- | Full prepare function.
--
-- This is executed after daemonization, and sets up both the log
-- files (a generic functionality) and the custom prepare function of
-- the daemon.
fullPrep :: GanetiDaemon  -- ^ The daemon we're running
         -> DaemonOptions -- ^ The options structure, filled from the cmdline
         -> SyslogUsage   -- ^ Syslog mode
         -> a             -- ^ Check results
         -> PrepFn a b    -- ^ Prepare function
467
         -> IO (FilePath, b)
468
fullPrep daemon opts syslog check_result prep_fn = do
Iustin Pop's avatar
Iustin Pop committed
469 470 471 472 473
  logfile <- if optDaemonize opts
               then return Nothing
               else liftM Just $ daemonLogFile daemon
  pidfile <- daemonPidFile daemon
  let dname = daemonName daemon
Iustin Pop's avatar
Iustin Pop committed
474
  setupLogging logfile dname (optDebug opts) True False syslog
475 476
  _ <- describeError "writing PID file; already locked?"
         Nothing (Just pidfile) $ writePidFile pidfile
Iustin Pop's avatar
Iustin Pop committed
477
  logNotice $ dname ++ " daemon startup"
478 479 480 481
  prep_res <- prep_fn opts check_result
  tid <- myThreadId
  _ <- installHandler sigTERM (Catch $ handleSigTerm tid) Nothing
  return (pidfile, prep_res)
482

483 484 485
-- | Inner daemon function.
--
-- This is executed after daemonization.
486 487 488 489 490 491
innerMain :: GanetiDaemon  -- ^ The daemon we're running
          -> DaemonOptions -- ^ The options structure, filled from the cmdline
          -> SyslogUsage   -- ^ Syslog mode
          -> a             -- ^ Check results
          -> PrepFn a b    -- ^ Prepare function
          -> MainFn a b    -- ^ Execution function
492
          -> Maybe Fd      -- ^ Error reporting function
493
          -> IO ()
494
innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
495
  (pidFile, prep_result) <- fullPrep daemon opts syslog check_result prep_fn
496
                 `Control.Exception.catch` handlePrepErr True fd
497 498
  -- no error reported, we should now close the fd
  maybeCloseFd fd
499
  finally (exec_fn opts check_result prep_result) (finalCleanup pidFile)
500 501

-- | Daemon prepare error handling function.
502 503
handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
handlePrepErr logging_setup fd err = do
504 505 506 507 508 509
  let msg = show err
  case fd of
    -- explicitly writing to the fd directly, since when forking it's
    -- better (safer) than trying to convert this into a full handle
    Just fd' -> fdWrite fd' msg >> return ()
    Nothing  -> hPutStrLn stderr (daemonStartupErr msg)
510
  when logging_setup $ logError msg
511 512 513 514 515 516
  exitWith $ ExitFailure 1

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