Daemon.hs 16.3 KB
Newer Older
1 2 3 4 5 6 7
{-| Implementation of the generic daemon functionality.

-}

{-

Copyright (C) 2011, 2012 Google Inc.
Klaus Aehlig's avatar
Klaus Aehlig committed
8
All rights reserved.
9

Klaus Aehlig's avatar
Klaus Aehlig committed
10 11 12
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
13

Klaus Aehlig's avatar
Klaus Aehlig committed
14 15
1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
16

Klaus Aehlig's avatar
Klaus Aehlig committed
17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 33 34 35 36 37

-}

module Ganeti.Daemon
  ( DaemonOptions(..)
  , OptType
38 39 40
  , CheckFn
  , PrepFn
  , MainFn
41 42 43 44 45 46 47
  , defaultOptions
  , oShowHelp
  , oShowVer
  , oNoDaemonize
  , oNoUserChecks
  , oDebug
  , oPort
Iustin Pop's avatar
Iustin Pop committed
48
  , oBindAddress
49
  , oSyslogUsage
50
  , parseArgs
Iustin Pop's avatar
Iustin Pop committed
51
  , parseAddress
52
  , cleanupSocket
53
  , describeError
54 55 56
  , genericMain
  ) where

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

Iustin Pop's avatar
Iustin Pop committed
78
import Ganeti.Common as Common
79 80 81
import Ganeti.Logging
import Ganeti.Runtime
import Ganeti.BasicTypes
82
import Ganeti.Utils
83
import qualified Ganeti.Constants as C
Iustin Pop's avatar
Iustin Pop committed
84
import qualified Ganeti.Ssconf as Ssconf
85

86 87 88 89 90 91
-- * Constants

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

92 93 94 95 96
-- | Error message prefix, used in two separate paths (when forking
-- and when not).
daemonStartupErr :: String -> String
daemonStartupErr = ("Error when starting the daemon process: " ++)

97 98 99 100 101 102
-- * Data types

-- | Command line options structure.
data DaemonOptions = DaemonOptions
  { optShowHelp     :: Bool           -- ^ Just show the help
  , optShowVer      :: Bool           -- ^ Just show the program version
103
  , optShowComp     :: Bool           -- ^ Just show the completion info
104 105 106 107
  , 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
108
  , optBindAddress  :: Maybe String   -- ^ Override for the bind address
109
  , optSyslogUsage  :: Maybe SyslogUsage -- ^ Override for Syslog usage
110 111 112 113 114 115 116
  }

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

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

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

137 138 139 140 141 142 143 144 145
-- | 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 ()

146 147 148
-- * Command line options

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

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

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

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

Iustin Pop's avatar
Iustin Pop committed
177
oBindAddress :: OptType
178 179 180 181 182 183
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
184

185
oSyslogUsage :: OptType
186 187 188 189 190 191 192 193 194
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"])
195

196 197 198 199
-- | Generic options.
genericOpts :: [OptType]
genericOpts = [ oShowHelp
              , oShowVer
200
              , oShowComp
201 202
              ]

203 204 205 206 207 208
-- | 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

209 210 211 212
-- | Small wrapper over getArgs and 'parseOpts'.
parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
parseArgs cmd options = do
  cmd_args <- getArgs
213
  parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) []
214 215

-- * Daemon-related functions
216

217 218 219 220
-- | PID file mode.
pidFileMode :: FileMode
pidFileMode = unionFileModes ownerReadMode ownerWriteMode

221 222 223 224
-- | PID file open flags.
pidFileFlags :: OpenFileFlags
pidFileFlags = defaultFileFlags { noctty = True, trunc = False }

225
-- | Writes a PID file and locks it.
226 227
writePidFile :: FilePath -> IO Fd
writePidFile path = do
228
  fd <- openFd path ReadWrite (Just pidFileMode) pidFileFlags
229 230 231 232 233
  setLock fd (WriteLock, AbsoluteSeek, 0, 0)
  my_pid <- getProcessID
  _ <- fdWrite fd (show my_pid ++ "\n")
  return fd

234 235 236
-- | 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
237
cleanupSocket socketPath =
238 239 240
  catchJust (guard . isDoesNotExistError) (removeLink socketPath)
            (const $ return ())

241 242 243 244 245 246 247 248
-- | Sets up a daemon's environment.
setupDaemonEnv :: FilePath -> FileMode -> IO ()
setupDaemonEnv cwd umask = do
  changeWorkingDirectory cwd
  _ <- setFileCreationMask umask
  _ <- createSession
  return ()

249 250 251 252 253 254 255 256 257 258 259 260 261
-- | 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

262 263 264 265 266 267
-- | Signal handler for reopening log files.
handleSigHup :: FilePath -> IO ()
handleSigHup path = do
  setupDaemonFDs (Just path)
  logInfo "Reopening log files after receiving SIGHUP"

268 269 270 271 272 273 274 275 276 277 278
-- | 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
279 280 281 282 283
-- | 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
284 285
  Ok (Socket.AF_INET,
      Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
Iustin Pop's avatar
Iustin Pop committed
286
defaultBindAddr port Socket.AF_INET6 =
Iustin Pop's avatar
Iustin Pop committed
287 288
  Ok (Socket.AF_INET6,
      Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
Iustin Pop's avatar
Iustin Pop committed
289 290 291 292 293 294 295 296 297 298
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
299 300
  case optBindAddress opts of
    Nothing -> return (def_family >>= defaultBindAddr port)
301 302
    Just saddr -> Control.Exception.catch
                    (resolveAddr port saddr)
303
                    (ioErrorToResult $ "Invalid address " ++ saddr)
Iustin Pop's avatar
Iustin Pop committed
304

305 306 307 308 309
-- | Environment variable to override the assumed host name of the
-- current node.
vClusterHostNameEnvVar :: String
vClusterHostNameEnvVar = "GANETI_HOSTNAME"

Klaus Aehlig's avatar
Klaus Aehlig committed
310 311 312
-- | Get the real full qualified host name.
getFQDN' :: IO String
getFQDN' = do
313 314 315 316 317 318 319 320 321
  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
322 323 324
-- | Return the full qualified host name, honoring the vcluster setup.
getFQDN :: IO String
getFQDN = do
325 326 327 328 329
  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
330
  case vcluster_node of
331
    Just node_name -> return node_name
Klaus Aehlig's avatar
Klaus Aehlig committed
332 333 334 335 336 337
    Nothing -> getFQDN'

-- | Returns if the current node is the master node.
isMaster :: IO Bool
isMaster = do
  curNode <- getFQDN
338 339 340 341 342 343 344 345 346 347 348 349 350 351
  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)
ensureNode :: GanetiDaemon -> IO ()
ensureNode daemon = do
  is_master <- isMaster
  when (daemonOnlyOnMaster daemon && not is_master) $ do
    putStrLn "Not master, exiting."
    exitWith (ExitFailure C.exitNotmaster)

352 353 354 355 356 357 358
-- | 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.
359 360 361 362
--
-- 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).
363
daemonize :: FilePath -> (Maybe Fd -> IO ()) -> IO ()
364
daemonize logfile action = do
365
  (rpipe, wpipe) <- createPipe
366 367 368
  -- first fork
  _ <- forkProcess $ do
    -- in the child
369
    closeFd rpipe
370
    let wpipe' = Just wpipe
371
    setupDaemonEnv "/" (unionFileModes groupModes otherModes)
372 373
    setupDaemonFDs (Just logfile) `Control.Exception.catch`
      handlePrepErr False wpipe'
374 375
    -- second fork, launches the actual child code; standard
    -- double-fork technique
376
    _ <- forkProcess (action wpipe')
377
    exitImmediately ExitSuccess
378 379 380 381 382 383 384 385 386
  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
387 388

-- | Generic daemon startup.
389 390 391 392 393 394 395
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
396
  let progname = daemonName daemon
397

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

400 401
  ensureNode daemon

Iustin Pop's avatar
Iustin Pop committed
402
  exitUnless (null args) "This program doesn't take any arguments"
403 404 405

  unless (optNoUserChecks opts) $ do
    runtimeEnts <- getEnts
Iustin Pop's avatar
Iustin Pop committed
406 407
    ents <- exitIfBad "Can't find required user/groups" runtimeEnts
    verifyDaemonUser daemon ents
408

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

Iustin Pop's avatar
Iustin Pop committed
414
  log_file <- daemonLogFile daemon
415 416 417 418 419 420
  -- 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

421
  let processFn = if optDaemonize opts
Iustin Pop's avatar
Iustin Pop committed
422
                    then daemonize log_file
423
                    else \action -> action Nothing
424
  _ <- installHandler lostConnection (Catch (handleSigHup log_file)) Nothing
425
  processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn
426

427 428 429 430 431 432 433 434 435 436
-- | 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
437
         -> IO (FilePath, b)
438
fullPrep daemon opts syslog check_result prep_fn = do
Iustin Pop's avatar
Iustin Pop committed
439 440 441 442 443
  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
444
  setupLogging logfile dname (optDebug opts) True False syslog
445 446
  _ <- describeError "writing PID file; already locked?"
         Nothing (Just pidfile) $ writePidFile pidfile
Iustin Pop's avatar
Iustin Pop committed
447
  logNotice $ dname ++ " daemon startup"
448 449 450 451
  prep_res <- prep_fn opts check_result
  tid <- myThreadId
  _ <- installHandler sigTERM (Catch $ handleSigTerm tid) Nothing
  return (pidfile, prep_res)
452

453 454 455
-- | Inner daemon function.
--
-- This is executed after daemonization.
456 457 458 459 460 461
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
462
          -> Maybe Fd      -- ^ Error reporting function
463
          -> IO ()
464
innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
465
  (pidFile, prep_result) <- fullPrep daemon opts syslog check_result prep_fn
466
                 `Control.Exception.catch` handlePrepErr True fd
467 468
  -- no error reported, we should now close the fd
  maybeCloseFd fd
469
  finally (exec_fn opts check_result prep_result) (finalCleanup pidFile)
470 471

-- | Daemon prepare error handling function.
472 473
handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
handlePrepErr logging_setup fd err = do
474 475 476 477 478 479
  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)
480
  when logging_setup $ logError msg
481 482 483 484 485 486
  exitWith $ ExitFailure 1

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