module Ganeti.Daemon
( DaemonOptions(..)
, OptType
+ , CheckFn
+ , PrepFn
+ , MainFn
, defaultOptions
, oShowHelp
, oShowVer
, oSyslogUsage
, parseArgs
, parseAddress
- , writePidFile
+ , cleanupSocket
+ , describeError
, genericMain
) where
import Control.Exception
import Control.Monad
import Data.Maybe (fromMaybe)
-import qualified Data.Version
import Data.Word
import GHC.IO.Handle (hDuplicateTo)
import qualified Network.Socket as Socket
-import Prelude hiding (catch)
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 System.Posix.Signals
-import Text.Printf
+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
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
-- | Command line options structure.
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
defaultOptions = DaemonOptions
{ optShowHelp = False
, optShowVer = False
+ , optShowComp = False
, optDaemonize = True
, optPort = Nothing
, optDebug = False
, 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)
-oShowHelp :: OptType
-oShowHelp = Option "h" ["help"]
- (NoArg (\ opts -> Ok opts { optShowHelp = True}))
- "Show the help message and exit"
+-- | Prepare function type.
+type PrepFn a b = DaemonOptions -> a -> IO b
-oShowVer :: OptType
-oShowVer = Option "V" ["version"]
- (NoArg (\ opts -> Ok opts { optShowVer = True}))
- "Show the version of the program and exit"
+-- | Main execution function type.
+type MainFn a b = DaemonOptions -> a -> b -> IO ()
+
+-- * 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 ++ ")")
+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)"
+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 ++
- "]")
-
--- | 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 <-
- exitIfBad "Error while parsing command line arguments" $
- foldM (flip id) defaultOptions opt_list
- return (parsed_opts, args)
- (_, _, errs) -> do
- hPutStrLn stderr $ "Command line error: " ++ concat errs
- hPutStrLn stderr $ usageHelp progname options
- exitWith $ ExitFailure 2
+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
--- | Helper to format an IOError.
-formatIOError :: String -> IOError -> String
-formatIOError msg err = msg ++ ": " ++ show err
-
--- | 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 . formatIOError "Failure during writing of the pid file")
+-- | 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 ()
-> 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)
+ 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)
+ 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
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)
+ best:_ -> Ok (Socket.addrFamily best, Socket.addrAddress best)
-- | Based on the options, compute the socket address to use for the
-- daemon.
parseAddress opts defport = do
let port = maybe defport fromIntegral $ optPort opts
def_family <- Ssconf.getPrimaryIPFamily Nothing
- ainfo <- case optBindAddress opts of
- Nothing -> return (def_family >>= defaultBindAddr port)
- Just saddr -> catch (resolveAddr port saddr)
- (annotateIOError $ "Invalid address " ++ saddr)
- return ainfo
-
--- | Run an I/O action as a daemon.
+ 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 :: FilePath -> IO () -> IO ()
+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)
- setupDaemonFDs $ Just logfile
+ setupDaemonFDs (Just logfile) `Control.Exception.catch`
+ handlePrepErr False wpipe'
_ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing
- _ <- forkProcess action
+ -- 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
- 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 ()
- exitSuccess
-
exitUnless (null args) "This program doesn't take any arguments"
unless (optNoUserChecks opts) $ do
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 (daemonLogFile daemon)
- else id
- processFn $ innerMain daemon opts syslog (main 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 -> SyslogUsage -> IO () -> IO ()
-innerMain daemon opts syslog main = do
- let logfile = if optDaemonize opts
- then Nothing
- else Just $ daemonLogFile daemon
- setupLogging logfile (daemonName daemon) (optDebug opts) True False syslog
- pid_fd <- writePidFile (daemonPidFile daemon)
- _ <- exitIfBad "Cannot write PID file; already locked? Error" pid_fd
- 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