X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/6ec7a50e66085b18824aef753551ae91b3fcb74a..638e0a6fe04e5973e0bb8ffbe444944d712dcf9b:/htools/Ganeti/Daemon.hs diff --git a/htools/Ganeti/Daemon.hs b/htools/Ganeti/Daemon.hs index a88ffe8..73bdb16 100644 --- a/htools/Ganeti/Daemon.hs +++ b/htools/Ganeti/Daemon.hs @@ -26,6 +26,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA module Ganeti.Daemon ( DaemonOptions(..) , OptType + , CheckFn + , PrepFn + , MainFn , defaultOptions , oShowHelp , oShowVer @@ -33,32 +36,51 @@ module Ganeti.Daemon , oNoUserChecks , oDebug , oPort + , oBindAddress + , oSyslogUsage , parseArgs - , writePidFile + , parseAddress + , cleanupSocket + , describeError , genericMain ) where +import Control.Exception import Control.Monad -import qualified Data.Version +import Data.Maybe (fromMaybe) import Data.Word +import GHC.IO.Handle (hDuplicateTo) +import qualified Network.Socket as Socket import System.Console.GetOpt import System.Exit import System.Environment -import System.Info import System.IO +import System.IO.Error (isDoesNotExistError, modifyIOError, annotateIOError) import System.Posix.Directory import System.Posix.Files import System.Posix.IO import System.Posix.Process import System.Posix.Types -import Text.Printf +import System.Posix.Signals +import Ganeti.Common as Common import Ganeti.Logging import Ganeti.Runtime import Ganeti.BasicTypes -import Ganeti.HTools.Utils -import qualified Ganeti.HTools.Version as Version(version) +import Ganeti.Utils import qualified Ganeti.Constants as C +import qualified Ganeti.Ssconf as Ssconf + +-- * Constants + +-- | \/dev\/null path. +devNull :: FilePath +devNull = "/dev/null" + +-- | Error message prefix, used in two separate paths (when forking +-- and when not). +daemonStartupErr :: String -> String +daemonStartupErr = ("Error when starting the daemon process: " ++) -- * Data types @@ -66,10 +88,13 @@ import qualified Ganeti.Constants as C data DaemonOptions = DaemonOptions { optShowHelp :: Bool -- ^ Just show the help , optShowVer :: Bool -- ^ Just show the program version + , optShowComp :: Bool -- ^ Just show the completion info , 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 + , optBindAddress :: Maybe String -- ^ Override for the bind address + , optSyslogUsage :: Maybe SyslogUsage -- ^ Override for Syslog usage } -- | Default values for the command line options. @@ -77,114 +102,129 @@ defaultOptions :: DaemonOptions defaultOptions = DaemonOptions { optShowHelp = False , optShowVer = False + , optShowComp = False , optDaemonize = True , optPort = Nothing , optDebug = False , optNoUserChecks = False + , optBindAddress = Nothing + , optSyslogUsage = Nothing } +instance StandardOptions DaemonOptions where + helpRequested = optShowHelp + verRequested = optShowVer + compRequested = optShowComp + requestHelp o = o { optShowHelp = True } + requestVer o = o { optShowVer = True } + requestComp o = o { optShowComp = True } + -- | Abrreviation for the option type. -type OptType = OptDescr (DaemonOptions -> Result DaemonOptions) - --- | Helper function for required arguments which need to be converted --- as opposed to stored just as string. -reqWithConversion :: (String -> Result a) - -> (a -> DaemonOptions -> Result DaemonOptions) - -> String - -> ArgDescr (DaemonOptions -> Result DaemonOptions) -reqWithConversion conversion_fn updater_fn metavar = - ReqArg (\string_opt opts -> do - parsed_value <- conversion_fn string_opt - updater_fn parsed_value opts) metavar +type OptType = GenericOptType DaemonOptions --- * Command line options +-- | Check function type. +type CheckFn a = DaemonOptions -> IO (Either ExitCode a) + +-- | Prepare function type. +type PrepFn a b = DaemonOptions -> a -> IO b -oShowHelp :: OptType -oShowHelp = Option "h" ["help"] - (NoArg (\ opts -> Ok opts { optShowHelp = True})) - "Show the help message and exit" +-- | Main execution function type. +type MainFn a b = DaemonOptions -> a -> b -> IO () -oShowVer :: OptType -oShowVer = Option "V" ["version"] - (NoArg (\ opts -> Ok opts { optShowVer = True})) - "Show the version of the program and exit" +-- * Command line options oNoDaemonize :: OptType -oNoDaemonize = Option "f" ["foreground"] - (NoArg (\ opts -> Ok opts { optDaemonize = False})) - "Don't detach from the current terminal" +oNoDaemonize = + (Option "f" ["foreground"] + (NoArg (\ opts -> Ok opts { optDaemonize = False})) + "Don't detach from the current terminal", + OptComplNone) oDebug :: OptType -oDebug = Option "d" ["debug"] - (NoArg (\ opts -> Ok opts { optDebug = True })) - "Enable debug messages" +oDebug = + (Option "d" ["debug"] + (NoArg (\ opts -> Ok opts { optDebug = True })) + "Enable debug messages", + OptComplNone) oNoUserChecks :: OptType -oNoUserChecks = Option "" ["no-user-checks"] - (NoArg (\ opts -> Ok opts { optNoUserChecks = True })) - "Ignore user checks" +oNoUserChecks = + (Option "" ["no-user-checks"] + (NoArg (\ opts -> Ok opts { optNoUserChecks = True })) + "Ignore user checks", + OptComplNone) oPort :: Int -> OptType -oPort def = Option "p" ["--port"] - (reqWithConversion (tryRead "reading port") - (\port opts -> Ok opts { optPort = Just port }) "PORT") - ("Network port (default: " ++ show def ++ ")") - --- | Usage info. -usageHelp :: String -> [OptType] -> String -usageHelp progname = - usageInfo (printf "%s %s\nUsage: %s [OPTION...]" - progname Version.version progname) - --- | Command line parser, using the 'Options' structure. -parseOpts :: [String] -- ^ The command line arguments - -> String -- ^ The program name - -> [OptType] -- ^ The supported command line options - -> IO (DaemonOptions, [String]) -- ^ The resulting options - -- and leftover arguments -parseOpts argv progname options = - case getOpt Permute options argv of - (opt_list, args, []) -> - do - parsed_opts <- - case foldM (flip id) defaultOptions opt_list of - Bad msg -> do - hPutStrLn stderr "Error while parsing command\ - \line arguments:" - hPutStrLn stderr msg - exitWith $ ExitFailure 1 - Ok val -> return val - return (parsed_opts, args) - (_, _, errs) -> do - hPutStrLn stderr $ "Command line error: " ++ concat errs - hPutStrLn stderr $ usageHelp progname options - exitWith $ ExitFailure 2 +oPort def = + (Option "p" ["port"] + (reqWithConversion (tryRead "reading port") + (\port opts -> Ok opts { optPort = Just port }) "PORT") + ("Network port (default: " ++ show def ++ ")"), + OptComplInteger) + +oBindAddress :: OptType +oBindAddress = + (Option "b" ["bind"] + (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr }) + "ADDR") + "Bind address (default depends on cluster configuration)", + OptComplInetAddr) + +oSyslogUsage :: OptType +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"]) + +-- | Generic options. +genericOpts :: [OptType] +genericOpts = [ oShowHelp + , oShowVer + , oShowComp + ] + +-- | 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 -- | Small wrapper over getArgs and 'parseOpts'. parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String]) parseArgs cmd options = do cmd_args <- getArgs - parseOpts cmd_args cmd options + parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) [] -- * Daemon-related functions + -- | PID file mode. pidFileMode :: FileMode pidFileMode = unionFileModes ownerReadMode ownerWriteMode +-- | PID file open flags. +pidFileFlags :: OpenFileFlags +pidFileFlags = defaultFileFlags { noctty = True, trunc = False } + -- | Writes a PID file and locks it. -_writePidFile :: FilePath -> IO Fd -_writePidFile path = do - fd <- createFile path pidFileMode +writePidFile :: FilePath -> IO Fd +writePidFile path = do + fd <- openFd path ReadWrite (Just pidFileMode) pidFileFlags setLock fd (WriteLock, AbsoluteSeek, 0, 0) my_pid <- getProcessID _ <- fdWrite fd (show my_pid ++ "\n") return fd --- | Wrapper over '_writePidFile' that transforms IO exceptions into a --- 'Bad' value. -writePidFile :: FilePath -> IO (Result Fd) -writePidFile path = do - catch (fmap Ok $ _writePidFile path) (return . Bad . show) +-- | Helper function to ensure a socket doesn't exist. Should only be +-- called once we have locked the pid file successfully. +cleanupSocket :: FilePath -> IO () +cleanupSocket socketPath = + catchJust (guard . isDoesNotExistError) (removeLink socketPath) + (const $ return ()) -- | Sets up a daemon's environment. setupDaemonEnv :: FilePath -> FileMode -> IO () @@ -194,67 +234,189 @@ setupDaemonEnv cwd umask = do _ <- createSession return () --- | Run an I/O action as a daemon. +-- | Signal handler for reopening log files. +handleSigHup :: FilePath -> IO () +handleSigHup path = do + setupDaemonFDs (Just path) + logInfo "Reopening log files after receiving SIGHUP" + +-- | 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 + +-- | 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 = + Ok (Socket.AF_INET, + Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY) +defaultBindAddr port Socket.AF_INET6 = + Ok (Socket.AF_INET6, + Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0) +defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam + +-- | Default hints for the resolver +resolveAddrHints :: Maybe Socket.AddrInfo +resolveAddrHints = + Just Socket.defaultHints { Socket.addrFlags = [Socket.AI_NUMERICHOST, + Socket.AI_NUMERICSERV] } + +-- | Resolves a numeric address. +resolveAddr :: Int -> String -> IO (Result (Socket.Family, Socket.SockAddr)) +resolveAddr port str = do + resolved <- Socket.getAddrInfo resolveAddrHints (Just str) (Just (show port)) + return $ case resolved of + [] -> Bad "Invalid results from lookup?" + best:_ -> Ok (Socket.addrFamily best, Socket.addrAddress best) + +-- | 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 + case optBindAddress opts of + Nothing -> return (def_family >>= defaultBindAddr port) + Just saddr -> Control.Exception.catch + (resolveAddr port saddr) + (ioErrorToResult $ "Invalid address " ++ saddr) + +-- | 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. -- -- 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). --- --- FIXME: this doesn't support error reporting and the prepfn --- functionality. -daemonize :: IO () -> IO () -daemonize action = do +daemonize :: FilePath -> (Maybe Fd -> IO ()) -> IO () +daemonize logfile action = do + (rpipe, wpipe) <- createPipe -- first fork _ <- forkProcess $ do -- in the child + closeFd rpipe + let wpipe' = Just wpipe setupDaemonEnv "/" (unionFileModes groupModes otherModes) - _ <- forkProcess action + setupDaemonFDs (Just logfile) `Control.Exception.catch` + handlePrepErr False wpipe' + _ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing + -- second fork, launches the actual child code; standard + -- double-fork technique + _ <- forkProcess (action wpipe') exitImmediately ExitSuccess - exitImmediately ExitSuccess + 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 -- | Generic daemon startup. -genericMain :: GanetiDaemon -> [OptType] -> (DaemonOptions -> IO ()) -> IO () -genericMain daemon options main = do +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 let progname = daemonName daemon (opts, args) <- parseArgs progname options - when (optShowHelp opts) $ do - putStr $ usageHelp progname options - exitWith ExitSuccess - when (optShowVer opts) $ do - printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n" - progname Version.version - compilerName (Data.Version.showVersion compilerVersion) - os arch :: IO () - exitWith ExitSuccess - unless (null args) $ do - hPutStrLn stderr "This program doesn't take any arguments" - exitWith $ ExitFailure C.exitFailure + exitUnless (null args) "This program doesn't take any arguments" unless (optNoUserChecks opts) $ do runtimeEnts <- getEnts - case runtimeEnts of - Bad msg -> do - hPutStrLn stderr $ "Can't find required user/groups: " ++ msg - exitWith $ ExitFailure C.exitFailure - Ok ents -> verifyDaemonUser daemon ents - - let processFn = if optDaemonize opts then daemonize else id - processFn $ innerMain daemon opts (main opts) + ents <- exitIfBad "Can't find required user/groups" runtimeEnts + verifyDaemonUser daemon ents + + syslog <- case optSyslogUsage opts of + Nothing -> exitIfBad "Invalid cluster syslog setting" $ + syslogUsageFromRaw C.syslogUsage + Just v -> return v + + log_file <- daemonLogFile daemon + -- 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 + + let processFn = if optDaemonize opts + then daemonize log_file + else \action -> action Nothing + processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn + +-- | 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 + -> IO b +fullPrep daemon opts syslog check_result prep_fn = do + logfile <- if optDaemonize opts + then return Nothing + else liftM Just $ daemonLogFile daemon + pidfile <- daemonPidFile daemon + let dname = daemonName daemon + setupLogging logfile dname (optDebug opts) True False syslog + _ <- describeError "writing PID file; already locked?" + Nothing (Just pidfile) $ writePidFile pidfile + logNotice $ dname ++ " daemon startup" + prep_fn opts check_result -- | Inner daemon function. -- -- This is executed after daemonization. -innerMain :: GanetiDaemon -> DaemonOptions -> IO () -> IO () -innerMain daemon opts main = do - setupLogging (daemonLogFile daemon) (daemonName daemon) (optDebug opts) - (not (optDaemonize opts)) False - pid_fd <- writePidFile (daemonPidFile daemon) - case pid_fd of - Bad msg -> do - hPutStrLn stderr $ "Cannot write PID file; already locked? Error: " ++ - msg - exitWith $ ExitFailure 1 - _ -> return () - logNotice "starting" - main +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 + -> Maybe Fd -- ^ Error reporting function + -> IO () +innerMain daemon opts syslog check_result prep_fn exec_fn fd = do + prep_result <- fullPrep daemon opts syslog check_result prep_fn + `Control.Exception.catch` handlePrepErr True fd + -- no error reported, we should now close the fd + maybeCloseFd fd + exec_fn opts check_result prep_result + +-- | Daemon prepare error handling function. +handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a +handlePrepErr logging_setup fd err = do + 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) + when logging_setup $ logError msg + exitWith $ ExitFailure 1 + +-- | Close a file descriptor. +maybeCloseFd :: Maybe Fd -> IO () +maybeCloseFd Nothing = return () +maybeCloseFd (Just fd) = closeFd fd