X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/6ec7a50e66085b18824aef753551ae91b3fcb74a..13f2321cc5e852dd2183faa1de1c5e14569a5599:/htools/Ganeti/Daemon.hs diff --git a/htools/Ganeti/Daemon.hs b/htools/Ganeti/Daemon.hs index a88ffe8..c6708f1 100644 --- a/htools/Ganeti/Daemon.hs +++ b/htools/Ganeti/Daemon.hs @@ -33,14 +33,22 @@ module Ganeti.Daemon , oNoUserChecks , oDebug , oPort + , oBindAddress + , oSyslogUsage , parseArgs + , parseAddress , writePidFile , 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 @@ -51,6 +59,7 @@ 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.Logging @@ -59,6 +68,13 @@ import Ganeti.BasicTypes import Ganeti.HTools.Utils import qualified Ganeti.HTools.Version as Version(version) import qualified Ganeti.Constants as C +import qualified Ganeti.Ssconf as Ssconf + +-- * Constants + +-- | \/dev\/null path. +devNull :: FilePath +devNull = "/dev/null" -- * Data types @@ -70,6 +86,8 @@ data DaemonOptions = DaemonOptions , 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. @@ -81,6 +99,8 @@ defaultOptions = DaemonOptions , optPort = Nothing , optDebug = False , optNoUserChecks = False + , optBindAddress = Nothing + , optSyslogUsage = Nothing } -- | Abrreviation for the option type. @@ -125,11 +145,26 @@ oNoUserChecks = Option "" ["no-user-checks"] "Ignore user checks" oPort :: Int -> OptType -oPort def = Option "p" ["--port"] +oPort def = Option "p" ["port"] (reqWithConversion (tryRead "reading port") (\port opts -> Ok opts { optPort = Just port }) "PORT") ("Network port (default: " ++ show def ++ ")") +oBindAddress :: OptType +oBindAddress = Option "b" ["bind"] + (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr }) + "ADDR") + "Bind address (default depends on cluster configuration)" + +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 = @@ -147,13 +182,8 @@ parseOpts argv progname options = (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 + 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 @@ -180,11 +210,16 @@ _writePidFile path = do _ <- 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 . show) + catch (fmap Ok $ _writePidFile path) + (return . Bad . formatIOError "Failure during writing of the pid file") -- | Sets up a daemon's environment. setupDaemonEnv :: FilePath -> FileMode -> IO () @@ -194,6 +229,63 @@ setupDaemonEnv cwd umask = do _ <- createSession return () +-- | 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 + 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. -- -- WARNING: this only works in single-threaded mode (either using the @@ -202,12 +294,14 @@ setupDaemonEnv cwd umask = do -- -- FIXME: this doesn't support error reporting and the prepfn -- functionality. -daemonize :: IO () -> IO () -daemonize action = do +daemonize :: FilePath -> IO () -> IO () +daemonize logfile action = do -- first fork _ <- forkProcess $ do -- in the child setupDaemonEnv "/" (unionFileModes groupModes otherModes) + setupDaemonFDs $ Just logfile + _ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing _ <- forkProcess action exitImmediately ExitSuccess exitImmediately ExitSuccess @@ -227,34 +321,33 @@ genericMain daemon options main = do 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 + let processFn = if optDaemonize opts + then daemonize (daemonLogFile daemon) + else id + processFn $ innerMain daemon opts syslog (main opts) -- | 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 +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) - case pid_fd of - Bad msg -> do - hPutStrLn stderr $ "Cannot write PID file; already locked? Error: " ++ - msg - exitWith $ ExitFailure 1 - _ -> return () + _ <- exitIfBad "Cannot write PID file; already locked? Error" pid_fd logNotice "starting" main