Perform proper cleanup on termination of Haskell daemons
[ganeti-github.git] / src / Ganeti / Daemon.hs
1 {-| Implementation of the generic daemon functionality.
2
3 -}
4
5 {-
6
7 Copyright (C) 2011, 2012 Google Inc.
8
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.
13
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.
18
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
22 02110-1301, USA.
23
24 -}
25
26 module Ganeti.Daemon
27 ( DaemonOptions(..)
28 , OptType
29 , CheckFn
30 , PrepFn
31 , MainFn
32 , defaultOptions
33 , oShowHelp
34 , oShowVer
35 , oNoDaemonize
36 , oNoUserChecks
37 , oDebug
38 , oPort
39 , oBindAddress
40 , oSyslogUsage
41 , parseArgs
42 , parseAddress
43 , cleanupSocket
44 , describeError
45 , genericMain
46 ) where
47
48 import Control.Concurrent
49 import Control.Exception
50 import Control.Monad
51 import Data.Maybe (fromMaybe, listToMaybe)
52 import Data.Word
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
58 import System.Exit
59 import System.Environment
60 import System.IO
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
68
69 import Ganeti.Common as Common
70 import Ganeti.Logging
71 import Ganeti.Runtime
72 import Ganeti.BasicTypes
73 import Ganeti.Utils
74 import qualified Ganeti.Constants as C
75 import qualified Ganeti.Ssconf as Ssconf
76
77 -- * Constants
78
79 -- | \/dev\/null path.
80 devNull :: FilePath
81 devNull = "/dev/null"
82
83 -- | Error message prefix, used in two separate paths (when forking
84 -- and when not).
85 daemonStartupErr :: String -> String
86 daemonStartupErr = ("Error when starting the daemon process: " ++)
87
88 -- * Data types
89
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
101 }
102
103 -- | Default values for the command line options.
104 defaultOptions :: DaemonOptions
105 defaultOptions = DaemonOptions
106 { optShowHelp = False
107 , optShowVer = False
108 , optShowComp = False
109 , optDaemonize = True
110 , optPort = Nothing
111 , optDebug = False
112 , optNoUserChecks = False
113 , optBindAddress = Nothing
114 , optSyslogUsage = Nothing
115 }
116
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 }
124
125 -- | Abrreviation for the option type.
126 type OptType = GenericOptType DaemonOptions
127
128 -- | Check function type.
129 type CheckFn a = DaemonOptions -> IO (Either ExitCode a)
130
131 -- | Prepare function type.
132 type PrepFn a b = DaemonOptions -> a -> IO b
133
134 -- | Main execution function type.
135 type MainFn a b = DaemonOptions -> a -> b -> IO ()
136
137 -- * Command line options
138
139 oNoDaemonize :: OptType
140 oNoDaemonize =
141 (Option "f" ["foreground"]
142 (NoArg (\ opts -> Ok opts { optDaemonize = False}))
143 "Don't detach from the current terminal",
144 OptComplNone)
145
146 oDebug :: OptType
147 oDebug =
148 (Option "d" ["debug"]
149 (NoArg (\ opts -> Ok opts { optDebug = True }))
150 "Enable debug messages",
151 OptComplNone)
152
153 oNoUserChecks :: OptType
154 oNoUserChecks =
155 (Option "" ["no-user-checks"]
156 (NoArg (\ opts -> Ok opts { optNoUserChecks = True }))
157 "Ignore user checks",
158 OptComplNone)
159
160 oPort :: Int -> OptType
161 oPort def =
162 (Option "p" ["port"]
163 (reqWithConversion (tryRead "reading port")
164 (\port opts -> Ok opts { optPort = Just port }) "PORT")
165 ("Network port (default: " ++ show def ++ ")"),
166 OptComplInteger)
167
168 oBindAddress :: OptType
169 oBindAddress =
170 (Option "b" ["bind"]
171 (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr })
172 "ADDR")
173 "Bind address (default depends on cluster configuration)",
174 OptComplInetAddr)
175
176 oSyslogUsage :: OptType
177 oSyslogUsage =
178 (Option "" ["syslog"]
179 (reqWithConversion syslogUsageFromRaw
180 (\su opts -> Ok opts { optSyslogUsage = Just su })
181 "SYSLOG")
182 ("Enable logging to syslog (except debug \
183 \messages); one of 'no', 'yes' or 'only' [" ++ C.syslogUsage ++
184 "]"),
185 OptComplChoices ["yes", "no", "only"])
186
187 -- | Generic options.
188 genericOpts :: [OptType]
189 genericOpts = [ oShowHelp
190 , oShowVer
191 , oShowComp
192 ]
193
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
199
200 -- | Small wrapper over getArgs and 'parseOpts'.
201 parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
202 parseArgs cmd options = do
203 cmd_args <- getArgs
204 parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) []
205
206 -- * Daemon-related functions
207
208 -- | PID file mode.
209 pidFileMode :: FileMode
210 pidFileMode = unionFileModes ownerReadMode ownerWriteMode
211
212 -- | PID file open flags.
213 pidFileFlags :: OpenFileFlags
214 pidFileFlags = defaultFileFlags { noctty = True, trunc = False }
215
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")
223 return fd
224
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)
230 (const $ return ())
231
232 -- | Sets up a daemon's environment.
233 setupDaemonEnv :: FilePath -> FileMode -> IO ()
234 setupDaemonEnv cwd umask = do
235 changeWorkingDirectory cwd
236 _ <- setFileCreationMask umask
237 _ <- createSession
238 return ()
239
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
244
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
252
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"
258
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
269
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 =
275 Ok (Socket.AF_INET,
276 Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
277 defaultBindAddr port Socket.AF_INET6 =
278 Ok (Socket.AF_INET6,
279 Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
280 defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam
281
282 -- | Default hints for the resolver
283 resolveAddrHints :: Maybe Socket.AddrInfo
284 resolveAddrHints =
285 Just Socket.defaultHints { Socket.addrFlags = [Socket.AI_NUMERICHOST,
286 Socket.AI_NUMERICSERV] }
287
288 -- | Resolves a numeric address.
289 resolveAddr :: Int -> String -> IO (Result (Socket.Family, Socket.SockAddr))
290 resolveAddr port str = do
291 resolved <- Socket.getAddrInfo resolveAddrHints (Just str) (Just (show port))
292 return $ case resolved of
293 [] -> Bad "Invalid results from lookup?"
294 best:_ -> Ok (Socket.addrFamily best, Socket.addrAddress best)
295
296 -- | Based on the options, compute the socket address to use for the
297 -- daemon.
298 parseAddress :: DaemonOptions -- ^ Command line options
299 -> Int -- ^ Default port for this daemon
300 -> IO (Result (Socket.Family, Socket.SockAddr))
301 parseAddress opts defport = do
302 let port = maybe defport fromIntegral $ optPort opts
303 def_family <- Ssconf.getPrimaryIPFamily Nothing
304 case optBindAddress opts of
305 Nothing -> return (def_family >>= defaultBindAddr port)
306 Just saddr -> Control.Exception.catch
307 (resolveAddr port saddr)
308 (ioErrorToResult $ "Invalid address " ++ saddr)
309
310 -- | Environment variable to override the assumed host name of the
311 -- current node.
312 vClusterHostNameEnvVar :: String
313 vClusterHostNameEnvVar = "GANETI_HOSTNAME"
314
315 getFQDN :: IO String
316 getFQDN = do
317 hostname <- getHostName
318 addrInfos <- Socket.getAddrInfo Nothing (Just hostname) Nothing
319 let address = listToMaybe addrInfos >>= (Just . Socket.addrAddress)
320 case address of
321 Just a -> do
322 fqdn <- liftM fst $ Socket.getNameInfo [] True False a
323 return (fromMaybe hostname fqdn)
324 Nothing -> return hostname
325
326 -- | Returns if the current node is the master node.
327 isMaster :: IO Bool
328 isMaster = do
329 let ioErrorToNothing :: IOError -> IO (Maybe String)
330 ioErrorToNothing _ = return Nothing
331 vcluster_node <- Control.Exception.catch
332 (liftM Just (getEnv vClusterHostNameEnvVar))
333 ioErrorToNothing
334 curNode <- case vcluster_node of
335 Just node_name -> return node_name
336 Nothing -> getFQDN
337 masterNode <- Ssconf.getMasterNode Nothing
338 case masterNode of
339 Ok n -> return (curNode == n)
340 Bad _ -> return False
341
342 -- | Ensures that the daemon runs on the right node (and exits
343 -- gracefully if it doesnt)
344 ensureNode :: GanetiDaemon -> IO ()
345 ensureNode daemon = do
346 is_master <- isMaster
347 when (daemonOnlyOnMaster daemon && not is_master) $ do
348 putStrLn "Not master, exiting."
349 exitWith (ExitFailure C.exitNotmaster)
350
351 -- | Run an I\/O action that might throw an I\/O error, under a
352 -- handler that will simply annotate and re-throw the exception.
353 describeError :: String -> Maybe Handle -> Maybe FilePath -> IO a -> IO a
354 describeError descr hndl fpath =
355 modifyIOError (\e -> annotateIOError e descr hndl fpath)
356
357 -- | Run an I\/O action as a daemon.
358 --
359 -- WARNING: this only works in single-threaded mode (either using the
360 -- single-threaded runtime, or using the multi-threaded one but with
361 -- only one OS thread, i.e. -N1).
362 daemonize :: FilePath -> (Maybe Fd -> IO ()) -> IO ()
363 daemonize logfile action = do
364 (rpipe, wpipe) <- createPipe
365 -- first fork
366 _ <- forkProcess $ do
367 -- in the child
368 closeFd rpipe
369 let wpipe' = Just wpipe
370 setupDaemonEnv "/" (unionFileModes groupModes otherModes)
371 setupDaemonFDs (Just logfile) `Control.Exception.catch`
372 handlePrepErr False wpipe'
373 _ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing
374 -- second fork, launches the actual child code; standard
375 -- double-fork technique
376 _ <- forkProcess (action wpipe')
377 exitImmediately ExitSuccess
378 closeFd wpipe
379 hndl <- fdToHandle rpipe
380 errors <- hGetContents hndl
381 ecode <- if null errors
382 then return ExitSuccess
383 else do
384 hPutStrLn stderr $ daemonStartupErr errors
385 return $ ExitFailure C.exitFailure
386 exitImmediately ecode
387
388 -- | Generic daemon startup.
389 genericMain :: GanetiDaemon -- ^ The daemon we're running
390 -> [OptType] -- ^ The available options
391 -> CheckFn a -- ^ Check function
392 -> PrepFn a b -- ^ Prepare function
393 -> MainFn a b -- ^ Execution function
394 -> IO ()
395 genericMain daemon options check_fn prep_fn exec_fn = do
396 let progname = daemonName daemon
397
398 (opts, args) <- parseArgs progname options
399
400 ensureNode daemon
401
402 exitUnless (null args) "This program doesn't take any arguments"
403
404 unless (optNoUserChecks opts) $ do
405 runtimeEnts <- getEnts
406 ents <- exitIfBad "Can't find required user/groups" runtimeEnts
407 verifyDaemonUser daemon ents
408
409 syslog <- case optSyslogUsage opts of
410 Nothing -> exitIfBad "Invalid cluster syslog setting" $
411 syslogUsageFromRaw C.syslogUsage
412 Just v -> return v
413
414 log_file <- daemonLogFile daemon
415 -- run the check function and optionally exit if it returns an exit code
416 check_result <- check_fn opts
417 check_result' <- case check_result of
418 Left code -> exitWith code
419 Right v -> return v
420
421 let processFn = if optDaemonize opts
422 then daemonize log_file
423 else \action -> action Nothing
424 processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn
425
426 -- | Full prepare function.
427 --
428 -- This is executed after daemonization, and sets up both the log
429 -- files (a generic functionality) and the custom prepare function of
430 -- the daemon.
431 fullPrep :: GanetiDaemon -- ^ The daemon we're running
432 -> DaemonOptions -- ^ The options structure, filled from the cmdline
433 -> SyslogUsage -- ^ Syslog mode
434 -> a -- ^ Check results
435 -> PrepFn a b -- ^ Prepare function
436 -> IO (FilePath, b)
437 fullPrep daemon opts syslog check_result prep_fn = do
438 logfile <- if optDaemonize opts
439 then return Nothing
440 else liftM Just $ daemonLogFile daemon
441 pidfile <- daemonPidFile daemon
442 let dname = daemonName daemon
443 setupLogging logfile dname (optDebug opts) True False syslog
444 _ <- describeError "writing PID file; already locked?"
445 Nothing (Just pidfile) $ writePidFile pidfile
446 logNotice $ dname ++ " daemon startup"
447 prep_res <- prep_fn opts check_result
448 tid <- myThreadId
449 _ <- installHandler sigTERM (Catch $ handleSigTerm tid) Nothing
450 return (pidfile, prep_res)
451
452 -- | Inner daemon function.
453 --
454 -- This is executed after daemonization.
455 innerMain :: GanetiDaemon -- ^ The daemon we're running
456 -> DaemonOptions -- ^ The options structure, filled from the cmdline
457 -> SyslogUsage -- ^ Syslog mode
458 -> a -- ^ Check results
459 -> PrepFn a b -- ^ Prepare function
460 -> MainFn a b -- ^ Execution function
461 -> Maybe Fd -- ^ Error reporting function
462 -> IO ()
463 innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
464 (pidFile, prep_result) <- fullPrep daemon opts syslog check_result prep_fn
465 `Control.Exception.catch` handlePrepErr True fd
466 -- no error reported, we should now close the fd
467 maybeCloseFd fd
468 finally (exec_fn opts check_result prep_result) (finalCleanup pidFile)
469
470 -- | Daemon prepare error handling function.
471 handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
472 handlePrepErr logging_setup fd err = do
473 let msg = show err
474 case fd of
475 -- explicitly writing to the fd directly, since when forking it's
476 -- better (safer) than trying to convert this into a full handle
477 Just fd' -> fdWrite fd' msg >> return ()
478 Nothing -> hPutStrLn stderr (daemonStartupErr msg)
479 when logging_setup $ logError msg
480 exitWith $ ExitFailure 1
481
482 -- | Close a file descriptor.
483 maybeCloseFd :: Maybe Fd -> IO ()
484 maybeCloseFd Nothing = return ()
485 maybeCloseFd (Just fd) = closeFd fd