1 {-| Implementation of the generic daemon functionality.
7 Copyright (C) 2011, 2012 Google Inc.
9 This program is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2 of the License, or
12 (at your option) any later version.
14 This program is distributed in the hope that it will be useful, but
15 WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with this program; if not, write to the Free Software
21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
48 import Control.Concurrent
49 import Control.Exception
51 import Data.Maybe (fromMaybe, listToMaybe)
53 import GHC.IO.Handle (hDuplicateTo)
54 import Network.BSD (getHostName)
55 import qualified Network.Socket as Socket
56 import System.Console.GetOpt
57 import System.Directory
59 import System.Environment
61 import System.IO.Error (isDoesNotExistError, modifyIOError, annotateIOError)
62 import System.Posix.Directory
63 import System.Posix.Files
64 import System.Posix.IO
65 import System.Posix.Process
66 import System.Posix.Types
67 import System.Posix.Signals
69 import Ganeti.Common as Common
72 import Ganeti.BasicTypes
74 import qualified Ganeti.Constants as C
75 import qualified Ganeti.Ssconf as Ssconf
79 -- | \/dev\/null path.
83 -- | Error message prefix, used in two separate paths (when forking
85 daemonStartupErr :: String -> String
86 daemonStartupErr = ("Error when starting the daemon process: " ++)
90 -- | Command line options structure.
91 data DaemonOptions = DaemonOptions
92 { optShowHelp :: Bool -- ^ Just show the help
93 , optShowVer :: Bool -- ^ Just show the program version
94 , optShowComp :: Bool -- ^ Just show the completion info
95 , optDaemonize :: Bool -- ^ Whether to daemonize or not
96 , optPort :: Maybe Word16 -- ^ Override for the network port
97 , optDebug :: Bool -- ^ Enable debug messages
98 , optNoUserChecks :: Bool -- ^ Ignore user checks
99 , optBindAddress :: Maybe String -- ^ Override for the bind address
100 , optSyslogUsage :: Maybe SyslogUsage -- ^ Override for Syslog usage
103 -- | Default values for the command line options.
104 defaultOptions :: DaemonOptions
105 defaultOptions = DaemonOptions
106 { optShowHelp = False
108 , optShowComp = False
109 , optDaemonize = True
112 , optNoUserChecks = False
113 , optBindAddress = Nothing
114 , optSyslogUsage = Nothing
117 instance StandardOptions DaemonOptions where
118 helpRequested = optShowHelp
119 verRequested = optShowVer
120 compRequested = optShowComp
121 requestHelp o = o { optShowHelp = True }
122 requestVer o = o { optShowVer = True }
123 requestComp o = o { optShowComp = True }
125 -- | Abrreviation for the option type.
126 type OptType = GenericOptType DaemonOptions
128 -- | Check function type.
129 type CheckFn a = DaemonOptions -> IO (Either ExitCode a)
131 -- | Prepare function type.
132 type PrepFn a b = DaemonOptions -> a -> IO b
134 -- | Main execution function type.
135 type MainFn a b = DaemonOptions -> a -> b -> IO ()
137 -- * Command line options
139 oNoDaemonize :: OptType
141 (Option "f" ["foreground"]
142 (NoArg (\ opts -> Ok opts { optDaemonize = False}))
143 "Don't detach from the current terminal",
148 (Option "d" ["debug"]
149 (NoArg (\ opts -> Ok opts { optDebug = True }))
150 "Enable debug messages",
153 oNoUserChecks :: OptType
155 (Option "" ["no-user-checks"]
156 (NoArg (\ opts -> Ok opts { optNoUserChecks = True }))
157 "Ignore user checks",
160 oPort :: Int -> OptType
163 (reqWithConversion (tryRead "reading port")
164 (\port opts -> Ok opts { optPort = Just port }) "PORT")
165 ("Network port (default: " ++ show def ++ ")"),
168 oBindAddress :: OptType
171 (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr })
173 "Bind address (default depends on cluster configuration)",
176 oSyslogUsage :: OptType
178 (Option "" ["syslog"]
179 (reqWithConversion syslogUsageFromRaw
180 (\su opts -> Ok opts { optSyslogUsage = Just su })
182 ("Enable logging to syslog (except debug \
183 \messages); one of 'no', 'yes' or 'only' [" ++ C.syslogUsage ++
185 OptComplChoices ["yes", "no", "only"])
187 -- | Generic options.
188 genericOpts :: [OptType]
189 genericOpts = [ oShowHelp
194 -- | Annotates and transforms IOErrors into a Result type. This can be
195 -- used in the error handler argument to 'catch', for example.
196 ioErrorToResult :: String -> IOError -> IO (Result a)
197 ioErrorToResult description exc =
198 return . Bad $ description ++ ": " ++ show exc
200 -- | Small wrapper over getArgs and 'parseOpts'.
201 parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
202 parseArgs cmd options = do
204 parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) []
206 -- * Daemon-related functions
209 pidFileMode :: FileMode
210 pidFileMode = unionFileModes ownerReadMode ownerWriteMode
212 -- | PID file open flags.
213 pidFileFlags :: OpenFileFlags
214 pidFileFlags = defaultFileFlags { noctty = True, trunc = False }
216 -- | Writes a PID file and locks it.
217 writePidFile :: FilePath -> IO Fd
218 writePidFile path = do
219 fd <- openFd path ReadWrite (Just pidFileMode) pidFileFlags
220 setLock fd (WriteLock, AbsoluteSeek, 0, 0)
221 my_pid <- getProcessID
222 _ <- fdWrite fd (show my_pid ++ "\n")
225 -- | Helper function to ensure a socket doesn't exist. Should only be
226 -- called once we have locked the pid file successfully.
227 cleanupSocket :: FilePath -> IO ()
228 cleanupSocket socketPath =
229 catchJust (guard . isDoesNotExistError) (removeLink socketPath)
232 -- | Sets up a daemon's environment.
233 setupDaemonEnv :: FilePath -> FileMode -> IO ()
234 setupDaemonEnv cwd umask = do
235 changeWorkingDirectory cwd
236 _ <- setFileCreationMask umask
240 -- | Cleanup function, performing all the operations that need to be done prior
241 -- to shutting down a daemon.
242 finalCleanup :: FilePath -> IO ()
243 finalCleanup = removeFile
245 -- | Signal handler for the termination signal.
246 handleSigTerm :: ThreadId -> IO ()
247 handleSigTerm mainTID =
248 -- Throw termination exception to the main thread, so that the daemon is
249 -- actually stopped in the proper way, executing all the functions waiting on
250 -- "finally" statement.
251 Control.Exception.throwTo mainTID ExitSuccess
253 -- | Signal handler for reopening log files.
254 handleSigHup :: FilePath -> IO ()
255 handleSigHup path = do
256 setupDaemonFDs (Just path)
257 logInfo "Reopening log files after receiving SIGHUP"
259 -- | Sets up a daemon's standard file descriptors.
260 setupDaemonFDs :: Maybe FilePath -> IO ()
261 setupDaemonFDs logfile = do
262 null_in_handle <- openFile devNull ReadMode
263 null_out_handle <- openFile (fromMaybe devNull logfile) AppendMode
264 hDuplicateTo null_in_handle stdin
265 hDuplicateTo null_out_handle stdout
266 hDuplicateTo null_out_handle stderr
267 hClose null_in_handle
268 hClose null_out_handle
270 -- | Computes the default bind address for a given family.
271 defaultBindAddr :: Int -- ^ The port we want
272 -> Socket.Family -- ^ The cluster IP family
273 -> Result (Socket.Family, Socket.SockAddr)
274 defaultBindAddr port Socket.AF_INET =
276 Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
277 defaultBindAddr port Socket.AF_INET6 =
279 Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
280 defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam
282 -- | Based on the options, compute the socket address to use for the
284 parseAddress :: DaemonOptions -- ^ Command line options
285 -> Int -- ^ Default port for this daemon
286 -> IO (Result (Socket.Family, Socket.SockAddr))
287 parseAddress opts defport = do
288 let port = maybe defport fromIntegral $ optPort opts
289 def_family <- Ssconf.getPrimaryIPFamily Nothing
290 case optBindAddress opts of
291 Nothing -> return (def_family >>= defaultBindAddr port)
292 Just saddr -> Control.Exception.catch
293 (resolveAddr port saddr)
294 (ioErrorToResult $ "Invalid address " ++ saddr)
296 -- | Environment variable to override the assumed host name of the
298 vClusterHostNameEnvVar :: String
299 vClusterHostNameEnvVar = "GANETI_HOSTNAME"
303 hostname <- getHostName
304 addrInfos <- Socket.getAddrInfo Nothing (Just hostname) Nothing
305 let address = listToMaybe addrInfos >>= (Just . Socket.addrAddress)
308 fqdn <- liftM fst $ Socket.getNameInfo [] True False a
309 return (fromMaybe hostname fqdn)
310 Nothing -> return hostname
312 -- | Returns if the current node is the master node.
315 let ioErrorToNothing :: IOError -> IO (Maybe String)
316 ioErrorToNothing _ = return Nothing
317 vcluster_node <- Control.Exception.catch
318 (liftM Just (getEnv vClusterHostNameEnvVar))
320 curNode <- case vcluster_node of
321 Just node_name -> return node_name
323 masterNode <- Ssconf.getMasterNode Nothing
325 Ok n -> return (curNode == n)
326 Bad _ -> return False
328 -- | Ensures that the daemon runs on the right node (and exits
329 -- gracefully if it doesnt)
330 ensureNode :: GanetiDaemon -> IO ()
331 ensureNode daemon = do
332 is_master <- isMaster
333 when (daemonOnlyOnMaster daemon && not is_master) $ do
334 putStrLn "Not master, exiting."
335 exitWith (ExitFailure C.exitNotmaster)
337 -- | Run an I\/O action that might throw an I\/O error, under a
338 -- handler that will simply annotate and re-throw the exception.
339 describeError :: String -> Maybe Handle -> Maybe FilePath -> IO a -> IO a
340 describeError descr hndl fpath =
341 modifyIOError (\e -> annotateIOError e descr hndl fpath)
343 -- | Run an I\/O action as a daemon.
345 -- WARNING: this only works in single-threaded mode (either using the
346 -- single-threaded runtime, or using the multi-threaded one but with
347 -- only one OS thread, i.e. -N1).
348 daemonize :: FilePath -> (Maybe Fd -> IO ()) -> IO ()
349 daemonize logfile action = do
350 (rpipe, wpipe) <- createPipe
352 _ <- forkProcess $ do
355 let wpipe' = Just wpipe
356 setupDaemonEnv "/" (unionFileModes groupModes otherModes)
357 setupDaemonFDs (Just logfile) `Control.Exception.catch`
358 handlePrepErr False wpipe'
359 _ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing
360 -- second fork, launches the actual child code; standard
361 -- double-fork technique
362 _ <- forkProcess (action wpipe')
363 exitImmediately ExitSuccess
365 hndl <- fdToHandle rpipe
366 errors <- hGetContents hndl
367 ecode <- if null errors
368 then return ExitSuccess
370 hPutStrLn stderr $ daemonStartupErr errors
371 return $ ExitFailure C.exitFailure
372 exitImmediately ecode
374 -- | Generic daemon startup.
375 genericMain :: GanetiDaemon -- ^ The daemon we're running
376 -> [OptType] -- ^ The available options
377 -> CheckFn a -- ^ Check function
378 -> PrepFn a b -- ^ Prepare function
379 -> MainFn a b -- ^ Execution function
381 genericMain daemon options check_fn prep_fn exec_fn = do
382 let progname = daemonName daemon
384 (opts, args) <- parseArgs progname options
388 exitUnless (null args) "This program doesn't take any arguments"
390 unless (optNoUserChecks opts) $ do
391 runtimeEnts <- getEnts
392 ents <- exitIfBad "Can't find required user/groups" runtimeEnts
393 verifyDaemonUser daemon ents
395 syslog <- case optSyslogUsage opts of
396 Nothing -> exitIfBad "Invalid cluster syslog setting" $
397 syslogUsageFromRaw C.syslogUsage
400 log_file <- daemonLogFile daemon
401 -- run the check function and optionally exit if it returns an exit code
402 check_result <- check_fn opts
403 check_result' <- case check_result of
404 Left code -> exitWith code
407 let processFn = if optDaemonize opts
408 then daemonize log_file
409 else \action -> action Nothing
410 processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn
412 -- | Full prepare function.
414 -- This is executed after daemonization, and sets up both the log
415 -- files (a generic functionality) and the custom prepare function of
417 fullPrep :: GanetiDaemon -- ^ The daemon we're running
418 -> DaemonOptions -- ^ The options structure, filled from the cmdline
419 -> SyslogUsage -- ^ Syslog mode
420 -> a -- ^ Check results
421 -> PrepFn a b -- ^ Prepare function
423 fullPrep daemon opts syslog check_result prep_fn = do
424 logfile <- if optDaemonize opts
426 else liftM Just $ daemonLogFile daemon
427 pidfile <- daemonPidFile daemon
428 let dname = daemonName daemon
429 setupLogging logfile dname (optDebug opts) True False syslog
430 _ <- describeError "writing PID file; already locked?"
431 Nothing (Just pidfile) $ writePidFile pidfile
432 logNotice $ dname ++ " daemon startup"
433 prep_res <- prep_fn opts check_result
435 _ <- installHandler sigTERM (Catch $ handleSigTerm tid) Nothing
436 return (pidfile, prep_res)
438 -- | Inner daemon function.
440 -- This is executed after daemonization.
441 innerMain :: GanetiDaemon -- ^ The daemon we're running
442 -> DaemonOptions -- ^ The options structure, filled from the cmdline
443 -> SyslogUsage -- ^ Syslog mode
444 -> a -- ^ Check results
445 -> PrepFn a b -- ^ Prepare function
446 -> MainFn a b -- ^ Execution function
447 -> Maybe Fd -- ^ Error reporting function
449 innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
450 (pidFile, prep_result) <- fullPrep daemon opts syslog check_result prep_fn
451 `Control.Exception.catch` handlePrepErr True fd
452 -- no error reported, we should now close the fd
454 finally (exec_fn opts check_result prep_result) (finalCleanup pidFile)
456 -- | Daemon prepare error handling function.
457 handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
458 handlePrepErr logging_setup fd err = do
461 -- explicitly writing to the fd directly, since when forking it's
462 -- better (safer) than trying to convert this into a full handle
463 Just fd' -> fdWrite fd' msg >> return ()
464 Nothing -> hPutStrLn stderr (daemonStartupErr msg)
465 when logging_setup $ logError msg
466 exitWith $ ExitFailure 1
468 -- | Close a file descriptor.
469 maybeCloseFd :: Maybe Fd -> IO ()
470 maybeCloseFd Nothing = return ()
471 maybeCloseFd (Just fd) = closeFd fd