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