Merge branch 'master' into assistant

4 files changed, 51 insertions, 30 deletions

diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs
index 192340cef..f36a761d0 100644
--- a/Utility/Daemon.hs
+++ b/Utility/Daemon.hs
@@ -27,7 +27,7 @@ daemonize logfd pidfile changedirectory a = do
 			_ <- forkProcess child2
 			out
 		child2 = do
-			maybe noop (lockPidFile True alreadyrunning) pidfile 
+			maybe noop (lockPidFile alreadyrunning) pidfile 
 			when changedirectory $
 				setCurrentDirectory "/"
 			nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
@@ -42,31 +42,44 @@ daemonize logfd pidfile changedirectory a = do
 		alreadyrunning = error "Daemon is already running."
 		out = exitImmediately ExitSuccess
 
-lockPidFile :: Bool -> IO () -> FilePath -> IO ()
-lockPidFile write onfailure file = do
-	fd <- openFd file ReadWrite (Just stdFileMode)
-		defaultFileFlags { trunc = write }
-	locked <- catchMaybeIO $ setLock fd (locktype, AbsoluteSeek, 0, 0)
-	case locked of
-		Nothing -> onfailure
-		_ -> when write $ void $
-			fdWrite fd =<< show <$> getProcessID
+{- 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
+	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
+		_ -> do
+			_ <- fdWrite fd' =<< show <$> getProcessID
+			renameFile newfile file
+			closeFd fd
 	where
-		locktype
-			| write = WriteLock
-			| otherwise = ReadLock
+		newfile = file ++ ".new"
 
 {- Stops the daemon.
  -
  - The pid file is used to get the daemon's pid.
  -
- - To guard against a stale pid, try to take a nonblocking shared lock
- - of the pid file. If this *fails*, the daemon must be running,
- - and have the exclusive lock, so the pid file is trustworthy.
+ - To guard against a stale pid, check the lock of the pid file,
+ - and compare the process that has it locked with the file content.
  -}
 stopDaemon :: FilePath -> IO ()
-stopDaemon pidfile = lockPidFile False go pidfile
-	where
-		go = do
-			pid <- readish <$> readFile pidfile
-			maybe noop (signalProcess sigTERM) pid
+stopDaemon pidfile = do
+	fd <- openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags
+	locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
+	p <- readish <$> readFile pidfile
+	case (locked, p) of
+		(Nothing, _) -> noop
+		(_, Nothing) -> noop
+		(Just (pid, _), Just pid')
+			| pid == pid' -> signalProcess sigTERM pid
+			| otherwise -> error $
+				"stale pid in " ++ pidfile ++ 
+				" (got " ++ show pid' ++ 
+				"; expected" ++ show pid ++ " )"
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 2f2960a9d..057da6087 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -35,14 +35,15 @@ dirContents :: FilePath -> IO [FilePath]
 dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
 
 {- Gets files in a directory, and then its subdirectories, recursively,
- - and lazily. -}
+ - and lazily. If the directory does not exist, no exception is thrown,
+ - instead, [] is returned. -}
 dirContentsRecursive :: FilePath -> IO [FilePath]
 dirContentsRecursive topdir = dirContentsRecursive' topdir [""]
 
 dirContentsRecursive' :: FilePath -> [FilePath] -> IO [FilePath]
 dirContentsRecursive' _ [] = return []
 dirContentsRecursive' topdir (dir:dirs) = unsafeInterleaveIO $ do
-	(files, dirs') <- collect [] [] =<< dirContents (topdir </> dir)
+	(files, dirs') <- collect [] [] =<< catchDefaultIO (dirContents (topdir </> dir)) []
 	files' <- dirContentsRecursive' topdir (dirs' ++ dirs)
 	return (files ++ files')
 	where
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 3ac5ca5c0..3b359139b 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -35,3 +35,13 @@ separate c l = unbreak $ break c l
 {- Breaks out the first line. -}
 firstLine :: String-> String
 firstLine = takeWhile (/= '\n')
+
+{- Splits a list into segments that are delimited by items matching
+ - a predicate. (The delimiters are not included in the segments.) -}
+segment :: (a -> Bool) -> [a] -> [[a]]
+segment p l = map reverse $ go [] [] l
+	where
+		go c r [] = reverse $ c:r
+		go c r (i:is)
+			| p i = go [] (c:r) is
+			| otherwise = go (i:c) r is
diff --git a/Utility/RsyncFile.hs b/Utility/RsyncFile.hs
index db9057843..075e91d23 100644
--- a/Utility/RsyncFile.hs
+++ b/Utility/RsyncFile.hs
@@ -22,9 +22,9 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman
                  - string is a single quote. -}
 		escape s = "'" ++  join "''" (split "'" s) ++ "'"
 
-{- Runs rsync in server mode to send a file, and exits. -}
-rsyncServerSend :: FilePath -> IO ()
-rsyncServerSend file = rsyncExec $
+{- Runs rsync in server mode to send a file. -}
+rsyncServerSend :: FilePath -> IO Bool
+rsyncServerSend file = rsync $
 	rsyncServerParams ++ [Param "--sender", File file]
 
 {- Runs rsync in server mode to receive a file. -}
@@ -47,11 +47,8 @@ rsyncServerParams =
 rsync :: [CommandParam] -> IO Bool
 rsync = boolSystem "rsync"
 
-rsyncExec :: [CommandParam] -> IO ()
-rsyncExec params = executeFile "rsync" True (toCommand params) Nothing
-
 {- Checks if an rsync url involves the remote shell (ssh or rsh).
- - Use of such urls with rsync or rsyncExec requires additional shell
+ - Use of such urls with rsync requires additional shell
  - escaping. -}
 rsyncUrlIsShell :: String -> Bool
 rsyncUrlIsShell s