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 qualified Network.Socket as Socket
54 import System.Console.GetOpt
56 import System.Environment
58 import System.IO.Error (isDoesNotExistError, modifyIOError, annotateIOError)
59 import System.Posix.Directory
60 import System.Posix.Files
61 import System.Posix.IO
62 import System.Posix.Process
63 import System.Posix.Types
64 import System.Posix.Signals
66 import Ganeti.Common as Common
69 import Ganeti.BasicTypes
71 import qualified Ganeti.Constants as C
72 import qualified Ganeti.Ssconf as Ssconf
76 -- | \/dev\/null path.
80 -- | Error message prefix, used in two separate paths (when forking
82 daemonStartupErr :: String -> String
83 daemonStartupErr = ("Error when starting the daemon process: " ++)
87 -- | Command line options structure.
88 data DaemonOptions = DaemonOptions
89 { optShowHelp :: Bool -- ^ Just show the help
90 , optShowVer :: Bool -- ^ Just show the program version
91 , optShowComp :: Bool -- ^ Just show the completion info
92 , optDaemonize :: Bool -- ^ Whether to daemonize or not
93 , optPort :: Maybe Word16 -- ^ Override for the network port
94 , optDebug :: Bool -- ^ Enable debug messages
95 , optNoUserChecks :: Bool -- ^ Ignore user checks
96 , optBindAddress :: Maybe String -- ^ Override for the bind address
97 , optSyslogUsage :: Maybe SyslogUsage -- ^ Override for Syslog usage
100 -- | Default values for the command line options.
101 defaultOptions :: DaemonOptions
102 defaultOptions = DaemonOptions
103 { optShowHelp = False
105 , optShowComp = False
106 , optDaemonize = True
109 , optNoUserChecks = False
110 , optBindAddress = Nothing
111 , optSyslogUsage = Nothing
114 instance StandardOptions DaemonOptions where
115 helpRequested = optShowHelp
116 verRequested = optShowVer
117 compRequested = optShowComp
118 requestHelp o = o { optShowHelp = True }
119 requestVer o = o { optShowVer = True }
120 requestComp o = o { optShowComp = True }
122 -- | Abrreviation for the option type.
123 type OptType = GenericOptType DaemonOptions
125 -- | Check function type.
126 type CheckFn a = DaemonOptions -> IO (Either ExitCode a)
128 -- | Prepare function type.
129 type PrepFn a b = DaemonOptions -> a -> IO b
131 -- | Main execution function type.
132 type MainFn a b = DaemonOptions -> a -> b -> IO ()
134 -- * Command line options
136 oNoDaemonize :: OptType
138 (Option "f" ["foreground"]
139 (NoArg (\ opts -> Ok opts { optDaemonize = False}))
140 "Don't detach from the current terminal",
145 (Option "d" ["debug"]
146 (NoArg (\ opts -> Ok opts { optDebug = True }))
147 "Enable debug messages",
150 oNoUserChecks :: OptType
152 (Option "" ["no-user-checks"]
153 (NoArg (\ opts -> Ok opts { optNoUserChecks = True }))
154 "Ignore user checks",
157 oPort :: Int -> OptType
160 (reqWithConversion (tryRead "reading port")
161 (\port opts -> Ok opts { optPort = Just port }) "PORT")
162 ("Network port (default: " ++ show def ++ ")"),
165 oBindAddress :: OptType
168 (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr })
170 "Bind address (default depends on cluster configuration)",
173 oSyslogUsage :: OptType
175 (Option "" ["syslog"]
176 (reqWithConversion syslogUsageFromRaw
177 (\su opts -> Ok opts { optSyslogUsage = Just su })
179 ("Enable logging to syslog (except debug \
180 \messages); one of 'no', 'yes' or 'only' [" ++ C.syslogUsage ++
182 OptComplChoices ["yes", "no", "only"])
184 -- | Generic options.
185 genericOpts :: [OptType]
186 genericOpts = [ oShowHelp
191 -- | Annotates and transforms IOErrors into a Result type. This can be
192 -- used in the error handler argument to 'catch', for example.
193 ioErrorToResult :: String -> IOError -> IO (Result a)
194 ioErrorToResult description exc =
195 return . Bad $ description ++ ": " ++ show exc
197 -- | Small wrapper over getArgs and 'parseOpts'.
198 parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
199 parseArgs cmd options = do
201 parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) []
203 -- * Daemon-related functions
206 pidFileMode :: FileMode
207 pidFileMode = unionFileModes ownerReadMode ownerWriteMode
209 -- | PID file open flags.
210 pidFileFlags :: OpenFileFlags
211 pidFileFlags = defaultFileFlags { noctty = True, trunc = False }
213 -- | Writes a PID file and locks it.
214 writePidFile :: FilePath -> IO Fd
215 writePidFile path = do
216 fd <- openFd path ReadWrite (Just pidFileMode) pidFileFlags
217 setLock fd (WriteLock, AbsoluteSeek, 0, 0)
218 my_pid <- getProcessID
219 _ <- fdWrite fd (show my_pid ++ "\n")
222 -- | Helper function to ensure a socket doesn't exist. Should only be
223 -- called once we have locked the pid file successfully.
224 cleanupSocket :: FilePath -> IO ()
225 cleanupSocket socketPath =
226 catchJust (guard . isDoesNotExistError) (removeLink socketPath)
229 -- | Sets up a daemon's environment.
230 setupDaemonEnv :: FilePath -> FileMode -> IO ()
231 setupDaemonEnv cwd umask = do
232 changeWorkingDirectory cwd
233 _ <- setFileCreationMask umask
237 -- | Signal handler for reopening log files.
238 handleSigHup :: FilePath -> IO ()
239 handleSigHup path = do
240 setupDaemonFDs (Just path)
241 logInfo "Reopening log files after receiving SIGHUP"
243 -- | Sets up a daemon's standard file descriptors.
244 setupDaemonFDs :: Maybe FilePath -> IO ()
245 setupDaemonFDs logfile = do
246 null_in_handle <- openFile devNull ReadMode
247 null_out_handle <- openFile (fromMaybe devNull logfile) AppendMode
248 hDuplicateTo null_in_handle stdin
249 hDuplicateTo null_out_handle stdout
250 hDuplicateTo null_out_handle stderr
251 hClose null_in_handle
252 hClose null_out_handle
254 -- | Computes the default bind address for a given family.
255 defaultBindAddr :: Int -- ^ The port we want
256 -> Socket.Family -- ^ The cluster IP family
257 -> Result (Socket.Family, Socket.SockAddr)
258 defaultBindAddr port Socket.AF_INET =
260 Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
261 defaultBindAddr port Socket.AF_INET6 =
263 Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
264 defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam
266 -- | Default hints for the resolver
267 resolveAddrHints :: Maybe Socket.AddrInfo
269 Just Socket.defaultHints { Socket.addrFlags = [Socket.AI_NUMERICHOST,
270 Socket.AI_NUMERICSERV] }
272 -- | Resolves a numeric address.
273 resolveAddr :: Int -> String -> IO (Result (Socket.Family, Socket.SockAddr))
274 resolveAddr port str = do
275 resolved <- Socket.getAddrInfo resolveAddrHints (Just str) (Just (show port))
276 return $ case resolved of
277 [] -> Bad "Invalid results from lookup?"
278 best:_ -> Ok (Socket.addrFamily best, Socket.addrAddress best)
280 -- | Based on the options, compute the socket address to use for the
282 parseAddress :: DaemonOptions -- ^ Command line options
283 -> Int -- ^ Default port for this daemon
284 -> IO (Result (Socket.Family, Socket.SockAddr))
285 parseAddress opts defport = do
286 let port = maybe defport fromIntegral $ optPort opts
287 def_family <- Ssconf.getPrimaryIPFamily Nothing
288 case optBindAddress opts of
289 Nothing -> return (def_family >>= defaultBindAddr port)
290 Just saddr -> Control.Exception.catch
291 (resolveAddr port saddr)
292 (ioErrorToResult $ "Invalid address " ++ saddr)
294 -- | Run an I\/O action that might throw an I\/O error, under a
295 -- handler that will simply annotate and re-throw the exception.
296 describeError :: String -> Maybe Handle -> Maybe FilePath -> IO a -> IO a
297 describeError descr hndl fpath =
298 modifyIOError (\e -> annotateIOError e descr hndl fpath)
300 -- | Run an I\/O action as a daemon.
302 -- WARNING: this only works in single-threaded mode (either using the
303 -- single-threaded runtime, or using the multi-threaded one but with
304 -- only one OS thread, i.e. -N1).
305 daemonize :: FilePath -> (Maybe Fd -> IO ()) -> IO ()
306 daemonize logfile action = do
307 (rpipe, wpipe) <- createPipe
309 _ <- forkProcess $ do
312 let wpipe' = Just wpipe
313 setupDaemonEnv "/" (unionFileModes groupModes otherModes)
314 setupDaemonFDs (Just logfile) `Control.Exception.catch`
315 handlePrepErr False wpipe'
316 _ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing
317 -- second fork, launches the actual child code; standard
318 -- double-fork technique
319 _ <- forkProcess (action wpipe')
320 exitImmediately ExitSuccess
322 hndl <- fdToHandle rpipe
323 errors <- hGetContents hndl
324 ecode <- if null errors
325 then return ExitSuccess
327 hPutStrLn stderr $ daemonStartupErr errors
328 return $ ExitFailure C.exitFailure
329 exitImmediately ecode
331 -- | Generic daemon startup.
332 genericMain :: GanetiDaemon -- ^ The daemon we're running
333 -> [OptType] -- ^ The available options
334 -> CheckFn a -- ^ Check function
335 -> PrepFn a b -- ^ Prepare function
336 -> MainFn a b -- ^ Execution function
338 genericMain daemon options check_fn prep_fn exec_fn = do
339 let progname = daemonName daemon
340 (opts, args) <- parseArgs progname options
342 exitUnless (null args) "This program doesn't take any arguments"
344 unless (optNoUserChecks opts) $ do
345 runtimeEnts <- getEnts
346 ents <- exitIfBad "Can't find required user/groups" runtimeEnts
347 verifyDaemonUser daemon ents
349 syslog <- case optSyslogUsage opts of
350 Nothing -> exitIfBad "Invalid cluster syslog setting" $
351 syslogUsageFromRaw C.syslogUsage
354 log_file <- daemonLogFile daemon
355 -- run the check function and optionally exit if it returns an exit code
356 check_result <- check_fn opts
357 check_result' <- case check_result of
358 Left code -> exitWith code
361 let processFn = if optDaemonize opts
362 then daemonize log_file
363 else \action -> action Nothing
364 processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn
366 -- | Full prepare function.
368 -- This is executed after daemonization, and sets up both the log
369 -- files (a generic functionality) and the custom prepare function of
371 fullPrep :: GanetiDaemon -- ^ The daemon we're running
372 -> DaemonOptions -- ^ The options structure, filled from the cmdline
373 -> SyslogUsage -- ^ Syslog mode
374 -> a -- ^ Check results
375 -> PrepFn a b -- ^ Prepare function
377 fullPrep daemon opts syslog check_result prep_fn = do
378 logfile <- if optDaemonize opts
380 else liftM Just $ daemonLogFile daemon
381 pidfile <- daemonPidFile daemon
382 let dname = daemonName daemon
383 setupLogging logfile dname (optDebug opts) True False syslog
384 _ <- describeError "writing PID file; already locked?"
385 Nothing (Just pidfile) $ writePidFile pidfile
386 logNotice $ dname ++ " daemon startup"
387 prep_fn opts check_result
389 -- | Inner daemon function.
391 -- This is executed after daemonization.
392 innerMain :: GanetiDaemon -- ^ The daemon we're running
393 -> DaemonOptions -- ^ The options structure, filled from the cmdline
394 -> SyslogUsage -- ^ Syslog mode
395 -> a -- ^ Check results
396 -> PrepFn a b -- ^ Prepare function
397 -> MainFn a b -- ^ Execution function
398 -> Maybe Fd -- ^ Error reporting function
400 innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
401 prep_result <- fullPrep daemon opts syslog check_result prep_fn
402 `Control.Exception.catch` handlePrepErr True fd
403 -- no error reported, we should now close the fd
405 exec_fn opts check_result prep_result
407 -- | Daemon prepare error handling function.
408 handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
409 handlePrepErr logging_setup fd err = do
412 -- explicitly writing to the fd directly, since when forking it's
413 -- better (safer) than trying to convert this into a full handle
414 Just fd' -> fdWrite fd' msg >> return ()
415 Nothing -> hPutStrLn stderr (daemonStartupErr msg)
416 when logging_setup $ logError msg
417 exitWith $ ExitFailure 1
419 -- | Close a file descriptor.
420 maybeCloseFd :: Maybe Fd -> IO ()
421 maybeCloseFd Nothing = return ()
422 maybeCloseFd (Just fd) = closeFd fd