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