module Ganeti.Daemon
( DaemonOptions(..)
, OptType
+ , CheckFn
+ , PrepFn
+ , MainFn
, defaultOptions
, oShowHelp
, oShowVer
, parseArgs
, parseAddress
, cleanupSocket
- , writePidFile
+ , describeError
, genericMain
) where
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.IO
-import System.IO.Error (isDoesNotExistError)
+import System.IO.Error (isDoesNotExistError, modifyIOError, annotateIOError)
import System.Posix.Directory
import System.Posix.Files
import System.Posix.IO
import Ganeti.Logging
import Ganeti.Runtime
import Ganeti.BasicTypes
-import Ganeti.HTools.Utils
+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
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 = GenericOptType DaemonOptions
+-- | Check function type.
+type CheckFn a = DaemonOptions -> IO (Either ExitCode a)
+
+-- | Prepare function type.
+type PrepFn a b = DaemonOptions -> a -> IO b
+
+-- | 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 ++
- "]")
+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 defaultOptions cmd_args cmd $ options ++ genericOpts
+ 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 =
- 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 ()
def_family <- Ssconf.getPrimaryIPFamily Nothing
case optBindAddress opts of
Nothing -> return (def_family >>= defaultBindAddr port)
- Just saddr -> catch (resolveAddr port saddr)
- (annotateIOError $ "Invalid address " ++ saddr)
+ 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.
+-- | 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
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