write pid file even when running in foreground

This prevents multiple runs of the assistant in the foreground, and lets
--stop stop foregrounded runs too.

The webapp firstrun case also now writes a pid file, once it's made the git
repo to put it in.
This commit is contained in:
Joey Hess 2012-08-01 16:29:38 -04:00
parent ecc168aba3
commit 8181b38ef6
3 changed files with 15 additions and 10 deletions

View file

@ -27,7 +27,7 @@ daemonize logfd pidfile changedirectory a = do
_ <- forkProcess child2
out
child2 = do
maybe noop (lockPidFile alreadyrunning) pidfile
maybe noop lockPidFile pidfile
when changedirectory $
setCurrentDirectory "/"
nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
@ -39,28 +39,28 @@ daemonize logfd pidfile changedirectory a = do
redir newh h = do
closeFd h
dupTo newh h
alreadyrunning = error "Daemon is already running."
out = exitImmediately ExitSuccess
{- Locks the pid file, with an exclusive, non-blocking lock.
- Runs an action on failure. On success, writes the pid to the file,
- fully atomically. -}
lockPidFile :: IO () -> FilePath -> IO ()
lockPidFile onfailure file = do
- Writes the pid to the file, fully atomically.
- Fails if the pid file is already locked by another process. -}
lockPidFile :: FilePath -> IO ()
lockPidFile file = do
fd <- openFd file ReadWrite (Just stdFileMode) defaultFileFlags
locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
fd' <- openFd newfile ReadWrite (Just stdFileMode) defaultFileFlags
{ trunc = True }
locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0)
case (locked, locked') of
(Nothing, _) -> onfailure
(_, Nothing) -> onfailure
(Nothing, _) -> alreadyrunning
(_, Nothing) -> alreadyrunning
_ -> do
_ <- fdWrite fd' =<< show <$> getProcessID
renameFile newfile file
closeFd fd
where
newfile = file ++ ".new"
alreadyrunning = error "Daemon is already running."
{- Checks if the daemon is running, by checking that the pid file
- is locked by the same process that is listed in the pid file.