code.grnet.gr Git - ganeti-local/blob - src/Ganeti/Daemon.hs

   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.Exception
  49 import Control.Monad
  50 import Data.Maybe (fromMaybe)
  51 import Data.Word
  52 import GHC.IO.Handle (hDuplicateTo)
  53 import Network.BSD (getHostName)
  54 import qualified Network.Socket as Socket
  55 import System.Console.GetOpt
  56 import System.Exit
  57 import System.Environment
  58 import System.IO
  59 import System.IO.Error (isDoesNotExistError, modifyIOError, annotateIOError)
  60 import System.Posix.Directory
  61 import System.Posix.Files
  62 import System.Posix.IO
  63 import System.Posix.Process
  64 import System.Posix.Types
  65 import System.Posix.Signals
  66
  67 import Ganeti.Common as Common
  68 import Ganeti.Logging
  69 import Ganeti.Runtime
  70 import Ganeti.BasicTypes
  71 import Ganeti.Utils
  72 import qualified Ganeti.Constants as C
  73 import qualified Ganeti.Ssconf as Ssconf
  74
  75 -- * Constants
  76
  77 -- | \/dev\/null path.
  78 devNull :: FilePath
  79 devNull = "/dev/null"
  80
  81 -- | Error message prefix, used in two separate paths (when forking
  82 -- and when not).
  83 daemonStartupErr :: String -> String
  84 daemonStartupErr = ("Error when starting the daemon process: " ++)
  85
  86 -- * Data types
  87
  88 -- | Command line options structure.
  89 data DaemonOptions = DaemonOptions
  90   { optShowHelp     :: Bool           -- ^ Just show the help
  91   , optShowVer      :: Bool           -- ^ Just show the program version
  92   , optShowComp     :: Bool           -- ^ Just show the completion info
  93   , optDaemonize    :: Bool           -- ^ Whether to daemonize or not
  94   , optPort         :: Maybe Word16   -- ^ Override for the network port
  95   , optDebug        :: Bool           -- ^ Enable debug messages
  96   , optNoUserChecks :: Bool           -- ^ Ignore user checks
  97   , optBindAddress  :: Maybe String   -- ^ Override for the bind address
  98   , optSyslogUsage  :: Maybe SyslogUsage -- ^ Override for Syslog usage
  99   }
 100
 101 -- | Default values for the command line options.
 102 defaultOptions :: DaemonOptions
 103 defaultOptions  = DaemonOptions
 104   { optShowHelp     = False
 105   , optShowVer      = False
 106   , optShowComp     = False
 107   , optDaemonize    = True
 108   , optPort         = Nothing
 109   , optDebug        = False
 110   , optNoUserChecks = False
 111   , optBindAddress  = Nothing
 112   , optSyslogUsage  = Nothing
 113   }
 114
 115 instance StandardOptions DaemonOptions where
 116   helpRequested = optShowHelp
 117   verRequested  = optShowVer
 118   compRequested = optShowComp
 119   requestHelp o = o { optShowHelp = True }
 120   requestVer  o = o { optShowVer  = True }
 121   requestComp o = o { optShowComp = True }
 122
 123 -- | Abrreviation for the option type.
 124 type OptType = GenericOptType DaemonOptions
 125
 126 -- | Check function type.
 127 type CheckFn a = DaemonOptions -> IO (Either ExitCode a)
 128
 129 -- | Prepare function type.
 130 type PrepFn a b = DaemonOptions -> a -> IO b
 131
 132 -- | Main execution function type.
 133 type MainFn a b = DaemonOptions -> a -> b -> IO ()
 134
 135 -- * Command line options
 136
 137 oNoDaemonize :: OptType
 138 oNoDaemonize =
 139   (Option "f" ["foreground"]
 140    (NoArg (\ opts -> Ok opts { optDaemonize = False}))
 141    "Don't detach from the current terminal",
 142    OptComplNone)
 143
 144 oDebug :: OptType
 145 oDebug =
 146   (Option "d" ["debug"]
 147    (NoArg (\ opts -> Ok opts { optDebug = True }))
 148    "Enable debug messages",
 149    OptComplNone)
 150
 151 oNoUserChecks :: OptType
 152 oNoUserChecks =
 153   (Option "" ["no-user-checks"]
 154    (NoArg (\ opts -> Ok opts { optNoUserChecks = True }))
 155    "Ignore user checks",
 156    OptComplNone)
 157
 158 oPort :: Int -> OptType
 159 oPort def =
 160   (Option "p" ["port"]
 161    (reqWithConversion (tryRead "reading port")
 162     (\port opts -> Ok opts { optPort = Just port }) "PORT")
 163    ("Network port (default: " ++ show def ++ ")"),
 164    OptComplInteger)
 165
 166 oBindAddress :: OptType
 167 oBindAddress =
 168   (Option "b" ["bind"]
 169    (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr })
 170     "ADDR")
 171    "Bind address (default depends on cluster configuration)",
 172    OptComplInetAddr)
 173
 174 oSyslogUsage :: OptType
 175 oSyslogUsage =
 176   (Option "" ["syslog"]
 177    (reqWithConversion syslogUsageFromRaw
 178     (\su opts -> Ok opts { optSyslogUsage = Just su })
 179     "SYSLOG")
 180    ("Enable logging to syslog (except debug \
 181     \messages); one of 'no', 'yes' or 'only' [" ++ C.syslogUsage ++
 182     "]"),
 183    OptComplChoices ["yes", "no", "only"])
 184
 185 -- | Generic options.
 186 genericOpts :: [OptType]
 187 genericOpts = [ oShowHelp
 188               , oShowVer
 189               , oShowComp
 190               ]
 191
 192 -- | Annotates and transforms IOErrors into a Result type. This can be
 193 -- used in the error handler argument to 'catch', for example.
 194 ioErrorToResult :: String -> IOError -> IO (Result a)
 195 ioErrorToResult description exc =
 196   return . Bad $ description ++ ": " ++ show exc
 197
 198 -- | Small wrapper over getArgs and 'parseOpts'.
 199 parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
 200 parseArgs cmd options = do
 201   cmd_args <- getArgs
 202   parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) []
 203
 204 -- * Daemon-related functions
 205
 206 -- | PID file mode.
 207 pidFileMode :: FileMode
 208 pidFileMode = unionFileModes ownerReadMode ownerWriteMode
 209
 210 -- | PID file open flags.
 211 pidFileFlags :: OpenFileFlags
 212 pidFileFlags = defaultFileFlags { noctty = True, trunc = False }
 213
 214 -- | Writes a PID file and locks it.
 215 writePidFile :: FilePath -> IO Fd
 216 writePidFile path = do
 217   fd <- openFd path ReadWrite (Just pidFileMode) pidFileFlags
 218   setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 219   my_pid <- getProcessID
 220   _ <- fdWrite fd (show my_pid ++ "\n")
 221   return fd
 222
 223 -- | Helper function to ensure a socket doesn't exist. Should only be
 224 -- called once we have locked the pid file successfully.
 225 cleanupSocket :: FilePath -> IO ()
 226 cleanupSocket socketPath =
 227   catchJust (guard . isDoesNotExistError) (removeLink socketPath)
 228             (const $ return ())
 229
 230 -- | Sets up a daemon's environment.
 231 setupDaemonEnv :: FilePath -> FileMode -> IO ()
 232 setupDaemonEnv cwd umask = do
 233   changeWorkingDirectory cwd
 234   _ <- setFileCreationMask umask
 235   _ <- createSession
 236   return ()
 237
 238 -- | Signal handler for reopening log files.
 239 handleSigHup :: FilePath -> IO ()
 240 handleSigHup path = do
 241   setupDaemonFDs (Just path)
 242   logInfo "Reopening log files after receiving SIGHUP"
 243
 244 -- | Sets up a daemon's standard file descriptors.
 245 setupDaemonFDs :: Maybe FilePath -> IO ()
 246 setupDaemonFDs logfile = do
 247   null_in_handle <- openFile devNull ReadMode
 248   null_out_handle <- openFile (fromMaybe devNull logfile) AppendMode
 249   hDuplicateTo null_in_handle stdin
 250   hDuplicateTo null_out_handle stdout
 251   hDuplicateTo null_out_handle stderr
 252   hClose null_in_handle
 253   hClose null_out_handle
 254
 255 -- | Computes the default bind address for a given family.
 256 defaultBindAddr :: Int                  -- ^ The port we want
 257                 -> Socket.Family        -- ^ The cluster IP family
 258                 -> Result (Socket.Family, Socket.SockAddr)
 259 defaultBindAddr port Socket.AF_INET =
 260   Ok (Socket.AF_INET,
 261       Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
 262 defaultBindAddr port Socket.AF_INET6 =
 263   Ok (Socket.AF_INET6,
 264       Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
 265 defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam
 266
 267 -- | Based on the options, compute the socket address to use for the
 268 -- daemon.
 269 parseAddress :: DaemonOptions      -- ^ Command line options
 270              -> Int                -- ^ Default port for this daemon
 271              -> IO (Result (Socket.Family, Socket.SockAddr))
 272 parseAddress opts defport = do
 273   let port = maybe defport fromIntegral $ optPort opts
 274   def_family <- Ssconf.getPrimaryIPFamily Nothing
 275   case optBindAddress opts of
 276     Nothing -> return (def_family >>= defaultBindAddr port)
 277     Just saddr -> Control.Exception.catch
 278                     (resolveAddr port saddr)
 279                     (ioErrorToResult $ "Invalid address " ++ saddr)
 280
 281 -- | Environment variable to override the assumed host name of the
 282 -- current node.
 283 vClusterHostNameEnvVar :: String
 284 vClusterHostNameEnvVar = "GANETI_HOSTNAME"
 285
 286 -- | Returns if the current node is the master node.
 287 isMaster :: IO Bool
 288 isMaster = do
 289   let ioErrorToNothing :: IOError -> IO (Maybe String)
 290       ioErrorToNothing _ = return Nothing
 291   vcluster_node <- Control.Exception.catch
 292                      (liftM Just (getEnv vClusterHostNameEnvVar))
 293                      ioErrorToNothing
 294   curNode <- case vcluster_node of
 295     Just node_name -> return node_name
 296     Nothing -> getHostName
 297   masterNode <- Ssconf.getMasterNode Nothing
 298   case masterNode of
 299     Ok n -> return (curNode == n)
 300     Bad _ -> return False
 301
 302 -- | Ensures that the daemon runs on the right node (and exits
 303 -- gracefully if it doesnt)
 304 ensureNode :: GanetiDaemon -> IO ()
 305 ensureNode daemon = do
 306   is_master <- isMaster
 307   when (daemonOnlyOnMaster daemon && not is_master) $ do
 308     putStrLn "Not master, exiting."
 309     exitWith (ExitFailure C.exitNotmaster)
 310
 311 -- | Run an I\/O action that might throw an I\/O error, under a
 312 -- handler that will simply annotate and re-throw the exception.
 313 describeError :: String -> Maybe Handle -> Maybe FilePath -> IO a -> IO a
 314 describeError descr hndl fpath =
 315   modifyIOError (\e -> annotateIOError e descr hndl fpath)
 316
 317 -- | Run an I\/O action as a daemon.
 318 --
 319 -- WARNING: this only works in single-threaded mode (either using the
 320 -- single-threaded runtime, or using the multi-threaded one but with
 321 -- only one OS thread, i.e. -N1).
 322 daemonize :: FilePath -> (Maybe Fd -> IO ()) -> IO ()
 323 daemonize logfile action = do
 324   (rpipe, wpipe) <- createPipe
 325   -- first fork
 326   _ <- forkProcess $ do
 327     -- in the child
 328     closeFd rpipe
 329     let wpipe' = Just wpipe
 330     setupDaemonEnv "/" (unionFileModes groupModes otherModes)
 331     setupDaemonFDs (Just logfile) `Control.Exception.catch`
 332       handlePrepErr False wpipe'
 333     _ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing
 334     -- second fork, launches the actual child code; standard
 335     -- double-fork technique
 336     _ <- forkProcess (action wpipe')
 337     exitImmediately ExitSuccess
 338   closeFd wpipe
 339   hndl <- fdToHandle rpipe
 340   errors <- hGetContents hndl
 341   ecode <- if null errors
 342              then return ExitSuccess
 343              else do
 344                hPutStrLn stderr $ daemonStartupErr errors
 345                return $ ExitFailure C.exitFailure
 346   exitImmediately ecode
 347
 348 -- | Generic daemon startup.
 349 genericMain :: GanetiDaemon -- ^ The daemon we're running
 350             -> [OptType]    -- ^ The available options
 351             -> CheckFn a    -- ^ Check function
 352             -> PrepFn  a b  -- ^ Prepare function
 353             -> MainFn  a b  -- ^ Execution function
 354             -> IO ()
 355 genericMain daemon options check_fn prep_fn exec_fn = do
 356   let progname = daemonName daemon
 357
 358   (opts, args) <- parseArgs progname options
 359
 360   ensureNode daemon
 361
 362   exitUnless (null args) "This program doesn't take any arguments"
 363
 364   unless (optNoUserChecks opts) $ do
 365     runtimeEnts <- getEnts
 366     ents <- exitIfBad "Can't find required user/groups" runtimeEnts
 367     verifyDaemonUser daemon ents
 368
 369   syslog <- case optSyslogUsage opts of
 370               Nothing -> exitIfBad "Invalid cluster syslog setting" $
 371                          syslogUsageFromRaw C.syslogUsage
 372               Just v -> return v
 373
 374   log_file <- daemonLogFile daemon
 375   -- run the check function and optionally exit if it returns an exit code
 376   check_result <- check_fn opts
 377   check_result' <- case check_result of
 378                      Left code -> exitWith code
 379                      Right v -> return v
 380
 381   let processFn = if optDaemonize opts
 382                     then daemonize log_file
 383                     else \action -> action Nothing
 384   processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn
 385
 386 -- | Full prepare function.
 387 --
 388 -- This is executed after daemonization, and sets up both the log
 389 -- files (a generic functionality) and the custom prepare function of
 390 -- the daemon.
 391 fullPrep :: GanetiDaemon  -- ^ The daemon we're running
 392          -> DaemonOptions -- ^ The options structure, filled from the cmdline
 393          -> SyslogUsage   -- ^ Syslog mode
 394          -> a             -- ^ Check results
 395          -> PrepFn a b    -- ^ Prepare function
 396          -> IO b
 397 fullPrep daemon opts syslog check_result prep_fn = do
 398   logfile <- if optDaemonize opts
 399                then return Nothing
 400                else liftM Just $ daemonLogFile daemon
 401   pidfile <- daemonPidFile daemon
 402   let dname = daemonName daemon
 403   setupLogging logfile dname (optDebug opts) True False syslog
 404   _ <- describeError "writing PID file; already locked?"
 405          Nothing (Just pidfile) $ writePidFile pidfile
 406   logNotice $ dname ++ " daemon startup"
 407   prep_fn opts check_result
 408
 409 -- | Inner daemon function.
 410 --
 411 -- This is executed after daemonization.
 412 innerMain :: GanetiDaemon  -- ^ The daemon we're running
 413           -> DaemonOptions -- ^ The options structure, filled from the cmdline
 414           -> SyslogUsage   -- ^ Syslog mode
 415           -> a             -- ^ Check results
 416           -> PrepFn a b    -- ^ Prepare function
 417           -> MainFn a b    -- ^ Execution function
 418           -> Maybe Fd      -- ^ Error reporting function
 419           -> IO ()
 420 innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
 421   prep_result <- fullPrep daemon opts syslog check_result prep_fn
 422                  `Control.Exception.catch` handlePrepErr True fd
 423   -- no error reported, we should now close the fd
 424   maybeCloseFd fd
 425   exec_fn opts check_result prep_result
 426
 427 -- | Daemon prepare error handling function.
 428 handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
 429 handlePrepErr logging_setup fd err = do
 430   let msg = show err
 431   case fd of
 432     -- explicitly writing to the fd directly, since when forking it's
 433     -- better (safer) than trying to convert this into a full handle
 434     Just fd' -> fdWrite fd' msg >> return ()
 435     Nothing  -> hPutStrLn stderr (daemonStartupErr msg)
 436   when logging_setup $ logError msg
 437   exitWith $ ExitFailure 1
 438
 439 -- | Close a file descriptor.
 440 maybeCloseFd :: Maybe Fd -> IO ()
 441 maybeCloseFd Nothing   = return ()
 442 maybeCloseFd (Just fd) = closeFd fd