module Ganeti.Daemon
( DaemonOptions(..)
, OptType
+ , CheckFn
+ , PrepFn
+ , MainFn
, defaultOptions
, oShowHelp
, oShowVer
, 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
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.
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 ()
_ <- 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
projects / ganeti-local / blobdiff