, oNoUserChecks
, oDebug
, oPort
+ , oBindAddress
+ , oSyslogUsage
, parseArgs
+ , parseAddress
+ , cleanupSocket
, writePidFile
, 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 Prelude hiding (catch)
import System.Console.GetOpt
import System.Exit
import System.Environment
-import System.Info
import System.IO
+import System.IO.Error (isDoesNotExistError)
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 qualified Ganeti.Constants as C
+import qualified Ganeti.Ssconf as Ssconf
+
+-- * Constants
+
+-- | \/dev\/null path.
+devNull :: FilePath
+devNull = "/dev/null"
-- * Data types
, 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.
, optPort = Nothing
, optDebug = False
, optNoUserChecks = False
+ , optBindAddress = Nothing
+ , optSyslogUsage = Nothing
}
+instance StandardOptions DaemonOptions where
+ helpRequested = optShowHelp
+ verRequested = optShowVer
+ requestHelp o = o { optShowHelp = True }
+ requestVer o = o { optShowVer = 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
-oShowHelp :: OptType
-oShowHelp = Option "h" ["help"]
- (NoArg (\ opts -> Ok opts { optShowHelp = True}))
- "Show the help message and exit"
-
-oShowVer :: OptType
-oShowVer = Option "V" ["version"]
- (NoArg (\ opts -> Ok opts { optShowVer = True}))
- "Show the version of the program and exit"
-
oNoDaemonize :: OptType
oNoDaemonize = Option "f" ["foreground"]
(NoArg (\ opts -> Ok opts { optDaemonize = False}))
(\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
+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 ++
+ "]")
-- | 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
-- * Daemon-related functions
-- | PID file mode.
_ <- 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)
+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 ()
+cleanupSocket socketPath =
+ catchJust (guard . isDoesNotExistError) (removeLink socketPath)
+ (const $ return ())
-- | Sets up a daemon's environment.
setupDaemonEnv :: FilePath -> FileMode -> IO ()
_ <- 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
+ case optBindAddress opts of
+ Nothing -> return (def_family >>= defaultBindAddr port)
+ Just saddr -> catch (resolveAddr port saddr)
+ (annotateIOError $ "Invalid address " ++ saddr)
+
-- | Run an I/O action as a daemon.
--
-- WARNING: this only works in single-threaded mode (either using the
--
-- 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
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
+ 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
projects / ganeti-local / blobdiff