, parseArgs
, parseAddress
, cleanupSocket
- , writePidFile
+ , describeError
, genericMain
) where
import System.Exit
import System.Environment
import System.IO
-import System.IO.Error (isDoesNotExistError)
+import System.IO.Error (isDoesNotExistError, modifyIOError, annotateIOError)
import System.Posix.Directory
import System.Posix.Files
import System.Posix.IO
, oShowComp
]
+-- | Annotates and transforms IOErrors into a Result type. This can be
+-- used in the error handler argument to 'catch', for example.
+ioErrorToResult :: String -> IOError -> IO (Result a)
+ioErrorToResult description exc =
+ return . Bad $ description ++ ": " ++ show exc
+
-- | Small wrapper over getArgs and 'parseOpts'.
parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
parseArgs cmd options = do
parseOpts defaultOptions cmd_args cmd (options ++ genericOpts) []
-- * Daemon-related functions
+
-- | PID file mode.
pidFileMode :: FileMode
pidFileMode = unionFileModes ownerReadMode ownerWriteMode
+-- | PID file open flags.
+pidFileFlags :: OpenFileFlags
+pidFileFlags = defaultFileFlags { noctty = True, trunc = False }
+
-- | Writes a PID file and locks it.
-_writePidFile :: FilePath -> IO Fd
-_writePidFile path = do
- fd <- createFile path pidFileMode
+writePidFile :: FilePath -> IO Fd
+writePidFile path = do
+ fd <- openFd path ReadWrite (Just pidFileMode) pidFileFlags
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
my_pid <- getProcessID
_ <- fdWrite fd (show my_pid ++ "\n")
return fd
--- | Helper to format an IOError.
-formatIOError :: String -> IOError -> String
-formatIOError msg err = msg ++ ": " ++ show err
-
--- | Wrapper over '_writePidFile' that transforms IO exceptions into a
--- 'Bad' value.
-writePidFile :: FilePath -> IO (Result Fd)
-writePidFile path =
- Control.Exception.catch
- (fmap Ok $ _writePidFile path)
- (return . Bad . formatIOError "Failure during writing of the pid file")
-
-- | Helper function to ensure a socket doesn't exist. Should only be
-- called once we have locked the pid file successfully.
cleanupSocket :: FilePath -> IO ()
Nothing -> return (def_family >>= defaultBindAddr port)
Just saddr -> Control.Exception.catch
(resolveAddr port saddr)
- (annotateIOError $ "Invalid address " ++ saddr)
+ (ioErrorToResult $ "Invalid address " ++ saddr)
+
+-- | Run an I\/O action that might throw an I\/O error, under a
+-- handler that will simply annotate and re-throw the exception.
+describeError :: String -> Maybe Handle -> Maybe FilePath -> IO a -> IO a
+describeError descr hndl fpath =
+ modifyIOError (\e -> annotateIOError e descr hndl fpath)
--- | Run an I/O action as a daemon.
+-- | Run an I\/O action as a daemon.
--
-- WARNING: this only works in single-threaded mode (either using the
-- single-threaded runtime, or using the multi-threaded one but with
_ <- forkProcess $ do
-- in the child
closeFd rpipe
+ let wpipe' = Just wpipe
setupDaemonEnv "/" (unionFileModes groupModes otherModes)
- setupDaemonFDs $ Just logfile
+ setupDaemonFDs (Just logfile) `Control.Exception.catch`
+ handlePrepErr False wpipe'
_ <- installHandler lostConnection (Catch (handleSigHup logfile)) Nothing
-- second fork, launches the actual child code; standard
-- double-fork technique
- _ <- forkProcess (action (Just wpipe))
+ _ <- forkProcess (action wpipe')
exitImmediately ExitSuccess
closeFd wpipe
hndl <- fdToHandle rpipe
syslogUsageFromRaw C.syslogUsage
Just v -> return v
+ log_file <- daemonLogFile daemon
-- run the check function and optionally exit if it returns an exit code
check_result <- check_fn opts
check_result' <- case check_result of
Right v -> return v
let processFn = if optDaemonize opts
- then daemonize (daemonLogFile daemon)
+ then daemonize log_file
else \action -> action Nothing
processFn $ innerMain daemon opts syslog check_result' prep_fn exec_fn
-> PrepFn a b -- ^ Prepare function
-> IO b
fullPrep daemon opts syslog check_result prep_fn = do
- let logfile = if optDaemonize opts
- then Nothing
- else Just $ daemonLogFile daemon
- setupLogging logfile (daemonName daemon) (optDebug opts) True False syslog
- pid_fd <- writePidFile (daemonPidFile daemon)
- _ <- exitIfBad "Cannot write PID file; already locked? Error" pid_fd
- logNotice "starting"
+ logfile <- if optDaemonize opts
+ then return Nothing
+ else liftM Just $ daemonLogFile daemon
+ pidfile <- daemonPidFile daemon
+ let dname = daemonName daemon
+ setupLogging logfile dname (optDebug opts) True False syslog
+ _ <- describeError "writing PID file; already locked?"
+ Nothing (Just pidfile) $ writePidFile pidfile
+ logNotice $ dname ++ " daemon startup"
prep_fn opts check_result
-- | Inner daemon function.
-> IO ()
innerMain daemon opts syslog check_result prep_fn exec_fn fd = do
prep_result <- fullPrep daemon opts syslog check_result prep_fn
- `Control.Exception.catch` handlePrepErr fd
+ `Control.Exception.catch` handlePrepErr True fd
-- no error reported, we should now close the fd
maybeCloseFd fd
exec_fn opts check_result prep_result
-- | Daemon prepare error handling function.
-handlePrepErr :: Maybe Fd -> IOError -> IO a
-handlePrepErr fd err = do
+handlePrepErr :: Bool -> Maybe Fd -> IOError -> IO a
+handlePrepErr logging_setup fd err = do
let msg = show err
case fd of
-- explicitly writing to the fd directly, since when forking it's
-- better (safer) than trying to convert this into a full handle
Just fd' -> fdWrite fd' msg >> return ()
Nothing -> hPutStrLn stderr (daemonStartupErr msg)
+ when logging_setup $ logError msg
exitWith $ ExitFailure 1
-- | Close a file descriptor.
projects / ganeti-local / blobdiff