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.Exception
50 import Data.Maybe (fromMaybe)
52 import GHC.IO.Handle (hDuplicateTo)
53 import Network.BSD (getHostName)
54 import qualified Network.Socket as Socket
55 import System.Console.GetOpt
57 import System.Environment
59 import System.IO.Error (isDoesNotExistError, modifyIOError, annotateIOError)
60 import System.Posix.Directory
61 import System.Posix.Files
62 import System.Posix.IO
63 import System.Posix.Process
64 import System.Posix.Types
65 import System.Posix.Signals
67 import Ganeti.Common as Common
70 import Ganeti.BasicTypes
72 import qualified Ganeti.Constants as C
73 import qualified Ganeti.Ssconf as Ssconf
77 -- | \/dev\/null path.
81 -- | Error message prefix, used in two separate paths (when forking
83 daemonStartupErr :: String -> String
84 daemonStartupErr = ("Error when starting the daemon process: " ++)
88 -- | Command line options structure.
89 data DaemonOptions = DaemonOptions
90 { optShowHelp :: Bool -- ^ Just show the help
91 , optShowVer :: Bool -- ^ Just show the program version
92 , optShowComp :: Bool -- ^ Just show the completion info
93 , optDaemonize :: Bool -- ^ Whether to daemonize or not
94 , optPort :: Maybe Word16 -- ^ Override for the network port
95 , optDebug :: Bool -- ^ Enable debug messages
96 , optNoUserChecks :: Bool -- ^ Ignore user checks
97 , optBindAddress :: Maybe String -- ^ Override for the bind address
98 , optSyslogUsage :: Maybe SyslogUsage -- ^ Override for Syslog usage
101 -- | Default values for the command line options.
102 defaultOptions :: DaemonOptions
103 defaultOptions = DaemonOptions
104 { optShowHelp = False
106 , optShowComp = False
107 , optDaemonize = True
110 , optNoUserChecks = False
111 , optBindAddress = Nothing
112 , optSyslogUsage = Nothing
115 instance StandardOptions DaemonOptions where
116 helpRequested = optShowHelp
117 verRequested = optShowVer
118 compRequested = optShowComp
119 requestHelp o = o { optShowHelp = True }
120 requestVer o = o { optShowVer = True }
121 requestComp o = o { optShowComp = True }
123 -- | Abrreviation for the option type.
124 type OptType = GenericOptType DaemonOptions
126 -- | Check function type.
127 type CheckFn a = DaemonOptions -> IO (Either ExitCode a)
129 -- | Prepare function type.
130 type PrepFn a b = DaemonOptions -> a -> IO b
132 -- | Main execution function type.
133 type MainFn a b = DaemonOptions -> a -> b -> IO ()
135 -- * Command line options
137 oNoDaemonize :: OptType
139 (Option "f" ["foreground"]
140 (NoArg (\ opts -> Ok opts { optDaemonize = False}))
141 "Don't detach from the current terminal",
146 (Option "d" ["debug"]
147 (NoArg (\ opts -> Ok opts { optDebug = True }))
148 "Enable debug messages",
151 oNoUserChecks :: OptType
153 (Option "" ["no-user-checks"]
154 (NoArg (\ opts -> Ok opts { optNoUserChecks = True }))
155 "Ignore user checks",
158 oPort :: Int -> OptType
161 (reqWithConversion (tryRead "reading port")
162 (\port opts -> Ok opts { optPort = Just port }) "PORT")
163 ("Network port (default: " ++ show def ++ ")"),
166 oBindAddress :: OptType
169 (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr })
171 "Bind address (default depends on cluster configuration)",
174 oSyslogUsage :: OptType
176 (Option "" ["syslog"]
177 (reqWithConversion syslogUsageFromRaw
178 (\su opts -> Ok opts { optSyslogUsage = Just su })
180 ("Enable logging to syslog (except debug \
181 \messages); one of 'no', 'yes' or 'only' [" ++ C.syslogUsage ++
183 OptComplChoices ["yes", "no", "only"])
185 -- | Generic options.
186 genericOpts :: [OptType]
187 genericOpts = [ oShowHelp
192 -- | Annotates and transforms IOErrors into a Result type. This can be
193 -- used in the error handler argument to 'catch', for example.
194 ioErrorToResult :: String -> IOError -> IO (Result a)
195 ioErrorToResult description exc =
196 return . Bad $ description ++ ": " ++ show exc
198 -- | Small wrapper over getArgs and 'parseOpts'.
199 parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
200 parseArgs cmd options = do
202 parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) []
204 -- * Daemon-related functions
207 pidFileMode :: FileMode
208 pidFileMode = unionFileModes ownerReadMode ownerWriteMode
210 -- | PID file open flags.
211 pidFileFlags :: OpenFileFlags
212 pidFileFlags = defaultFileFlags { noctty = True, trunc = False }
214 -- | Writes a PID file and locks it.
215 writePidFile :: FilePath -> IO Fd
216 writePidFile path = do
217 fd <- openFd path ReadWrite (Just pidFileMode) pidFileFlags
218 setLock fd (WriteLock, AbsoluteSeek, 0, 0)
219 my_pid <- getProcessID
220 _ <- fdWrite fd (show my_pid ++ "\n")
223 -- | Helper function to ensure a socket doesn't exist. Should only be
224 -- called once we have locked the pid file successfully.
225 cleanupSocket :: FilePath -> IO ()
226 cleanupSocket socketPath =
227 catchJust (guard . isDoesNotExistError) (removeLink socketPath)
230 -- | Sets up a daemon's environment.
231 setupDaemonEnv :: FilePath -> FileMode -> IO ()
232 setupDaemonEnv cwd umask = do
233 changeWorkingDirectory cwd
234 _ <- setFileCreationMask umask
238 -- | Signal handler for reopening log files.
239 handleSigHup :: FilePath -> IO ()
240 handleSigHup path = do
241 setupDaemonFDs (Just path)
242 logInfo "Reopening log files after receiving SIGHUP"
244 -- | Sets up a daemon's standard file descriptors.
245 setupDaemonFDs :: Maybe FilePath -> IO ()
246 setupDaemonFDs logfile = do
247 null_in_handle <- openFile devNull ReadMode
248 null_out_handle <- openFile (fromMaybe devNull logfile) AppendMode
249 hDuplicateTo null_in_handle stdin
250 hDuplicateTo null_out_handle stdout
251 hDuplicateTo null_out_handle stderr
252 hClose null_in_handle
253 hClose null_out_handle
255 -- | Computes the default bind address for a given family.
256 defaultBindAddr :: Int -- ^ The port we want
257 -> Socket.Family -- ^ The cluster IP family
258 -> Result (Socket.Family, Socket.SockAddr)
259 defaultBindAddr port Socket.AF_INET =
261 Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
262 defaultBindAddr port Socket.AF_INET6 =
264 Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
265 defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam
267 -- | Based on the options, compute the socket address to use for the
269 parseAddress :: DaemonOptions -- ^ Command line options
270 -> Int -- ^ Default port for this daemon
271 -> IO (Result (Socket.Family, Socket.SockAddr))
272 parseAddress opts defport = do
273 let port = maybe defport fromIntegral $ optPort opts
274 def_family <- Ssconf.getPrimaryIPFamily Nothing
275 case optBindAddress opts of
276 Nothing -> return (def_family >>= defaultBindAddr port)
277 Just saddr -> Control.Exception.catch
278 (resolveAddr port saddr)
279 (ioErrorToResult $ "Invalid address " ++ saddr)
281 -- | Environment variable to override the assumed host name of the
283 vClusterHostNameEnvVar :: String
284 vClusterHostNameEnvVar = "GANETI_HOSTNAME"
286 -- | Returns if the current node is the master node.
289 let ioErrorToNothing :: IOError -> IO (Maybe String)
290 ioErrorToNothing _ = return Nothing
291 vcluster_node <- Control.Exception.catch
292 (liftM Just (getEnv vClusterHostNameEnvVar))
294 curNode <- case vcluster_node of
295 Just node_name -> return node_name
296 Nothing -> getHostName
297 masterNode <- Ssconf.getMasterNode Nothing
299 Ok n -> return (curNode == n)
300 Bad _ -> return False
302 -- | Ensures that the daemon runs on the right node (and exits
303 -- gracefully if it doesnt)
304 ensureNode :: GanetiDaemon -> IO ()
305 ensureNode daemon = do
306 is_master <- isMaster
307 when (daemonOnlyOnMaster daemon && not is_master) $ do
308 putStrLn "Not master, exiting."
309 exitWith (ExitFailure C.exitNotmaster)
311 -- | Run an I\/O action that might throw an I\/O error, under a
312 -- handler that will simply annotate and re-throw the exception.
313 describeError :: String -> Maybe Handle -> Maybe FilePath -> IO a -> IO a
314 describeError descr hndl fpath =
315 modifyIOError (\e -> annotateIOError e descr hndl fpath)
317 -- | Run an I\/O action as a daemon.
319 -- WARNING: this only works in single-threaded mode (either using the
320 -- single-threaded runtime, or using the multi-threaded one but with
321 -- only one OS thread, i.e. -N1).
322 daemonize :: FilePath -> (Maybe Fd -> IO ()) -> IO ()
323 daemonize logfile action = do
324 (rpipe, wpipe) <- createPipe
326 _ <- forkProcess $ do
329 let wpipe' = Just wpipe
330 setupDaemonEnv "/" (unionFileModes groupModes otherModes)
331 setupDaemonFDs (Just logfile) `Control.Exception.catch`
332 handlePrepErr False wpipe'
333 _ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing
334 -- second fork, launches the actual child code; standard
335 -- double-fork technique
336 _ <- forkProcess (action wpipe')
337 exitImmediately ExitSuccess
339 hndl <- fdToHandle rpipe
340 errors <- hGetContents hndl
341 ecode <- if null errors
342 then return ExitSuccess
344 hPutStrLn stderr $ daemonStartupErr errors
345 return $ ExitFailure C.exitFailure
346 exitImmediately ecode
348 -- | Generic daemon startup.
349 genericMain :: GanetiDaemon -- ^ The daemon we're running
350 -> [OptType] -- ^ The available options
351 -> CheckFn a -- ^ Check function
352 -> PrepFn a b -- ^ Prepare function
353 -> MainFn a b -- ^ Execution function
355 genericMain daemon options check_fn prep_fn exec_fn = do
356 let progname = daemonName daemon
358 (opts, args) <- parseArgs progname options
362 exitUnless (null args) "This program doesn't take any arguments"
364 unless (optNoUserChecks opts) $ do
365 runtimeEnts <- getEnts
366 ents <- exitIfBad "Can't find required user/groups" runtimeEnts
367 verifyDaemonUser daemon ents
369 syslog <- case optSyslogUsage opts of
370 Nothing -> exitIfBad "Invalid cluster syslog setting" $
371 syslogUsageFromRaw C.syslogUsage
374 log_file <- daemonLogFile daemon
375 -- run the check function and optionally exit if it returns an exit code
376 check_result <- check_fn opts
377 check_result' <- case check_result of
378 Left code -> exitWith code
381 let processFn = if optDaemonize opts
382 then daemonize log_file
383 else \action -> action Nothing
384 processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn
386 -- | Full prepare function.
388 -- This is executed after daemonization, and sets up both the log
389 -- files (a generic functionality) and the custom prepare function of
391 fullPrep :: GanetiDaemon -- ^ The daemon we're running
392 -> DaemonOptions -- ^ The options structure, filled from the cmdline
393 -> SyslogUsage -- ^ Syslog mode
394 -> a -- ^ Check results
395 -> PrepFn a b -- ^ Prepare function
397 fullPrep daemon opts syslog check_result prep_fn = do
398 logfile <- if optDaemonize opts
400 else liftM Just $ daemonLogFile daemon
401 pidfile <- daemonPidFile daemon
402 let dname = daemonName daemon
403 setupLogging logfile dname (optDebug opts) True False syslog
404 _ <- describeError "writing PID file; already locked?"
405 Nothing (Just pidfile) $ writePidFile pidfile
406 logNotice $ dname ++ " daemon startup"
407 prep_fn opts check_result
409 -- | Inner daemon function.
411 -- This is executed after daemonization.
412 innerMain :: GanetiDaemon -- ^ The daemon we're running
413 -> DaemonOptions -- ^ The options structure, filled from the cmdline
414 -> SyslogUsage -- ^ Syslog mode
415 -> a -- ^ Check results
416 -> PrepFn a b -- ^ Prepare function
417 -> MainFn a b -- ^ Execution function
418 -> Maybe Fd -- ^ Error reporting function
420 innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
421 prep_result <- fullPrep daemon opts syslog check_result prep_fn
422 `Control.Exception.catch` handlePrepErr True fd
423 -- no error reported, we should now close the fd
425 exec_fn opts check_result prep_result
427 -- | Daemon prepare error handling function.
428 handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
429 handlePrepErr logging_setup fd err = do
432 -- explicitly writing to the fd directly, since when forking it's
433 -- better (safer) than trying to convert this into a full handle
434 Just fd' -> fdWrite fd' msg >> return ()
435 Nothing -> hPutStrLn stderr (daemonStartupErr msg)
436 when logging_setup $ logError msg
437 exitWith $ ExitFailure 1
439 -- | Close a file descriptor.
440 maybeCloseFd :: Maybe Fd -> IO ()
441 maybeCloseFd Nothing = return ()
442 maybeCloseFd (Just fd) = closeFd fd