code.grnet.gr Git - ganeti-local/blob - htools/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   , defaultOptions
  30   , oShowHelp
  31   , oShowVer
  32   , oNoDaemonize
  33   , oNoUserChecks
  34   , oDebug
  35   , oPort
  36   , oBindAddress
  37   , oSyslogUsage
  38   , parseArgs
  39   , parseAddress
  40   , writePidFile
  41   , genericMain
  42   ) where
  43
  44 import Control.Monad
  45 import qualified Data.Version
  46 import Data.Word
  47 import qualified Network.Socket as Socket
  48 import System.Console.GetOpt
  49 import System.Exit
  50 import System.Environment
  51 import System.Info
  52 import System.IO
  53 import System.Posix.Directory
  54 import System.Posix.Files
  55 import System.Posix.IO
  56 import System.Posix.Process
  57 import System.Posix.Types
  58 import Text.Printf
  59
  60 import Ganeti.Logging
  61 import Ganeti.Runtime
  62 import Ganeti.BasicTypes
  63 import Ganeti.HTools.Utils
  64 import qualified Ganeti.HTools.Version as Version(version)
  65 import qualified Ganeti.Constants as C
  66 import qualified Ganeti.Ssconf as Ssconf
  67
  68 -- * Data types
  69
  70 -- | Command line options structure.
  71 data DaemonOptions = DaemonOptions
  72   { optShowHelp     :: Bool           -- ^ Just show the help
  73   , optShowVer      :: Bool           -- ^ Just show the program version
  74   , optDaemonize    :: Bool           -- ^ Whether to daemonize or not
  75   , optPort         :: Maybe Word16   -- ^ Override for the network port
  76   , optDebug        :: Bool           -- ^ Enable debug messages
  77   , optNoUserChecks :: Bool           -- ^ Ignore user checks
  78   , optBindAddress  :: Maybe String   -- ^ Override for the bind address
  79   , optSyslogUsage  :: Maybe SyslogUsage -- ^ Override for Syslog usage
  80   }
  81
  82 -- | Default values for the command line options.
  83 defaultOptions :: DaemonOptions
  84 defaultOptions  = DaemonOptions
  85   { optShowHelp     = False
  86   , optShowVer      = False
  87   , optDaemonize    = True
  88   , optPort         = Nothing
  89   , optDebug        = False
  90   , optNoUserChecks = False
  91   , optBindAddress  = Nothing
  92   , optSyslogUsage  = Nothing
  93   }
  94
  95 -- | Abrreviation for the option type.
  96 type OptType = OptDescr (DaemonOptions -> Result DaemonOptions)
  97
  98 -- | Helper function for required arguments which need to be converted
  99 -- as opposed to stored just as string.
 100 reqWithConversion :: (String -> Result a)
 101                   -> (a -> DaemonOptions -> Result DaemonOptions)
 102                   -> String
 103                   -> ArgDescr (DaemonOptions -> Result DaemonOptions)
 104 reqWithConversion conversion_fn updater_fn metavar =
 105   ReqArg (\string_opt opts -> do
 106             parsed_value <- conversion_fn string_opt
 107             updater_fn parsed_value opts) metavar
 108
 109 -- * Command line options
 110
 111 oShowHelp :: OptType
 112 oShowHelp = Option "h" ["help"]
 113             (NoArg (\ opts -> Ok opts { optShowHelp = True}))
 114             "Show the help message and exit"
 115
 116 oShowVer :: OptType
 117 oShowVer = Option "V" ["version"]
 118            (NoArg (\ opts -> Ok opts { optShowVer = True}))
 119            "Show the version of the program and exit"
 120
 121 oNoDaemonize :: OptType
 122 oNoDaemonize = Option "f" ["foreground"]
 123                (NoArg (\ opts -> Ok opts { optDaemonize = False}))
 124                "Don't detach from the current terminal"
 125
 126 oDebug :: OptType
 127 oDebug = Option "d" ["debug"]
 128          (NoArg (\ opts -> Ok opts { optDebug = True }))
 129          "Enable debug messages"
 130
 131 oNoUserChecks :: OptType
 132 oNoUserChecks = Option "" ["no-user-checks"]
 133          (NoArg (\ opts -> Ok opts { optNoUserChecks = True }))
 134          "Ignore user checks"
 135
 136 oPort :: Int -> OptType
 137 oPort def = Option "p" ["port"]
 138             (reqWithConversion (tryRead "reading port")
 139              (\port opts -> Ok opts { optPort = Just port }) "PORT")
 140             ("Network port (default: " ++ show def ++ ")")
 141
 142 oBindAddress :: OptType
 143 oBindAddress = Option "b" ["bind"]
 144                (ReqArg (\addr opts -> Ok opts { optBindAddress = Just addr })
 145                 "ADDR")
 146                "Bind address (default depends on cluster configuration)"
 147
 148 oSyslogUsage :: OptType
 149 oSyslogUsage = Option "" ["syslog"]
 150                (reqWithConversion syslogUsageFromRaw
 151                 (\su opts -> Ok opts { optSyslogUsage = Just su })
 152                 "SYSLOG")
 153                ("Enable logging to syslog (except debug \
 154                 \messages); one of 'no', 'yes' or 'only' [" ++ C.syslogUsage ++
 155                 "]")
 156
 157 -- | Usage info.
 158 usageHelp :: String -> [OptType] -> String
 159 usageHelp progname =
 160   usageInfo (printf "%s %s\nUsage: %s [OPTION...]"
 161              progname Version.version progname)
 162
 163 -- | Command line parser, using the 'Options' structure.
 164 parseOpts :: [String]               -- ^ The command line arguments
 165           -> String                 -- ^ The program name
 166           -> [OptType]              -- ^ The supported command line options
 167           -> IO (DaemonOptions, [String]) -- ^ The resulting options
 168                                           -- and leftover arguments
 169 parseOpts argv progname options =
 170   case getOpt Permute options argv of
 171     (opt_list, args, []) ->
 172       do
 173         parsed_opts <-
 174           exitIfBad "Error while parsing command line arguments" $
 175           foldM (flip id) defaultOptions opt_list
 176         return (parsed_opts, args)
 177     (_, _, errs) -> do
 178       hPutStrLn stderr $ "Command line error: "  ++ concat errs
 179       hPutStrLn stderr $ usageHelp progname options
 180       exitWith $ ExitFailure 2
 181
 182 -- | Small wrapper over getArgs and 'parseOpts'.
 183 parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
 184 parseArgs cmd options = do
 185   cmd_args <- getArgs
 186   parseOpts cmd_args cmd options
 187
 188 -- * Daemon-related functions
 189 -- | PID file mode.
 190 pidFileMode :: FileMode
 191 pidFileMode = unionFileModes ownerReadMode ownerWriteMode
 192
 193 -- | Writes a PID file and locks it.
 194 _writePidFile :: FilePath -> IO Fd
 195 _writePidFile path = do
 196   fd <- createFile path pidFileMode
 197   setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 198   my_pid <- getProcessID
 199   _ <- fdWrite fd (show my_pid ++ "\n")
 200   return fd
 201
 202 -- | Wrapper over '_writePidFile' that transforms IO exceptions into a
 203 -- 'Bad' value.
 204 writePidFile :: FilePath -> IO (Result Fd)
 205 writePidFile path = do
 206   catch (fmap Ok $ _writePidFile path) (return . Bad . show)
 207
 208 -- | Sets up a daemon's environment.
 209 setupDaemonEnv :: FilePath -> FileMode -> IO ()
 210 setupDaemonEnv cwd umask = do
 211   changeWorkingDirectory cwd
 212   _ <- setFileCreationMask umask
 213   _ <- createSession
 214   return ()
 215
 216 -- | Computes the default bind address for a given family.
 217 defaultBindAddr :: Int                  -- ^ The port we want
 218                 -> Socket.Family        -- ^ The cluster IP family
 219                 -> Result (Socket.Family, Socket.SockAddr)
 220 defaultBindAddr port Socket.AF_INET =
 221   Ok $ (Socket.AF_INET,
 222         Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
 223 defaultBindAddr port Socket.AF_INET6 =
 224   Ok $ (Socket.AF_INET6,
 225         Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
 226 defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam
 227
 228 -- | Default hints for the resolver
 229 resolveAddrHints :: Maybe Socket.AddrInfo
 230 resolveAddrHints =
 231   Just Socket.defaultHints { Socket.addrFlags = [Socket.AI_NUMERICHOST,
 232                                                  Socket.AI_NUMERICSERV] }
 233
 234 -- | Resolves a numeric address.
 235 resolveAddr :: Int -> String -> IO (Result (Socket.Family, Socket.SockAddr))
 236 resolveAddr port str = do
 237   resolved <- Socket.getAddrInfo resolveAddrHints (Just str) (Just (show port))
 238   return $ case resolved of
 239              [] -> Bad "Invalid results from lookup?"
 240              best:_ -> Ok $ (Socket.addrFamily best, Socket.addrAddress best)
 241
 242 -- | Based on the options, compute the socket address to use for the
 243 -- daemon.
 244 parseAddress :: DaemonOptions      -- ^ Command line options
 245              -> Int                -- ^ Default port for this daemon
 246              -> IO (Result (Socket.Family, Socket.SockAddr))
 247 parseAddress opts defport = do
 248   let port = maybe defport fromIntegral $ optPort opts
 249   def_family <- Ssconf.getPrimaryIPFamily Nothing
 250   ainfo <- case optBindAddress opts of
 251              Nothing -> return (def_family >>= defaultBindAddr port)
 252              Just saddr -> catch (resolveAddr port saddr)
 253                            (annotateIOError $ "Invalid address " ++ saddr)
 254   return ainfo
 255
 256 -- | Run an I/O action as a daemon.
 257 --
 258 -- WARNING: this only works in single-threaded mode (either using the
 259 -- single-threaded runtime, or using the multi-threaded one but with
 260 -- only one OS thread, i.e. -N1).
 261 --
 262 -- FIXME: this doesn't support error reporting and the prepfn
 263 -- functionality.
 264 daemonize :: IO () -> IO ()
 265 daemonize action = do
 266   -- first fork
 267   _ <- forkProcess $ do
 268     -- in the child
 269     setupDaemonEnv "/" (unionFileModes groupModes otherModes)
 270     _ <- forkProcess action
 271     exitImmediately ExitSuccess
 272   exitImmediately ExitSuccess
 273
 274 -- | Generic daemon startup.
 275 genericMain :: GanetiDaemon -> [OptType] -> (DaemonOptions -> IO ()) -> IO ()
 276 genericMain daemon options main = do
 277   let progname = daemonName daemon
 278   (opts, args) <- parseArgs progname options
 279
 280   when (optShowHelp opts) $ do
 281     putStr $ usageHelp progname options
 282     exitWith ExitSuccess
 283   when (optShowVer opts) $ do
 284     printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n"
 285            progname Version.version
 286            compilerName (Data.Version.showVersion compilerVersion)
 287            os arch :: IO ()
 288     exitWith ExitSuccess
 289
 290   exitUnless (null args) "This program doesn't take any arguments"
 291
 292   unless (optNoUserChecks opts) $ do
 293     runtimeEnts <- getEnts
 294     ents <- exitIfBad "Can't find required user/groups" runtimeEnts
 295     verifyDaemonUser daemon ents
 296
 297   syslog <- case optSyslogUsage opts of
 298               Nothing -> exitIfBad "Invalid cluster syslog setting" $
 299                          syslogUsageFromRaw C.syslogUsage
 300               Just v -> return v
 301   let processFn = if optDaemonize opts then daemonize else id
 302   processFn $ innerMain daemon opts syslog (main opts)
 303
 304 -- | Inner daemon function.
 305 --
 306 -- This is executed after daemonization.
 307 innerMain :: GanetiDaemon -> DaemonOptions -> SyslogUsage -> IO () -> IO ()
 308 innerMain daemon opts syslog main = do
 309   setupLogging (daemonLogFile daemon) (daemonName daemon) (optDebug opts)
 310                  (not (optDaemonize opts)) False syslog
 311   pid_fd <- writePidFile (daemonPidFile daemon)
 312   _ <- exitIfBad "Cannot write PID file; already locked? Error" pid_fd
 313   logNotice "starting"
 314   main