windows: Fix daemon pid file locking.

Well, as much as it can be fixed on windows. Not atomic; not entirely
guarded against the wrong process having the pid file locked.

1 files changed, 44 insertions, 9 deletions

diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs
index c10e87192..b604b1794 100644
--- a/Utility/Daemon.hs
+++ b/Utility/Daemon.hs
@@ -15,6 +15,7 @@ import Utility.PID
 import Utility.LogFile
 #else
 import Utility.WinProcess
+import Utility.WinLock
 #endif
 
 #ifndef mingw32_HOST_OS
@@ -55,14 +56,16 @@ daemonize logfd pidfile changedirectory a = do
 	out = exitImmediately ExitSuccess
 #endif
 
-{- Locks the pid file, with an exclusive, non-blocking lock.
+{- Locks the pid file, with an exclusive, non-blocking lock,
+ - and leaves it locked on return.
+ -
  - 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
-	createDirectoryIfMissing True (parentDir file)
+lockPidFile pidfile = do
+	createDirectoryIfMissing True (parentDir pidfile)
 #ifndef mingw32_HOST_OS
-	fd <- openFd file ReadWrite (Just stdFileMode) defaultFileFlags
+	fd <- openFd pidfile ReadWrite (Just stdFileMode) defaultFileFlags
 	locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
 	fd' <- openFd newfile ReadWrite (Just stdFileMode) defaultFileFlags
 		{ trunc = True }
@@ -73,12 +76,17 @@ lockPidFile file = do
 		_ -> do
 			_ <- fdWrite fd' =<< show <$> getPID
 			closeFd fd
+	rename newfile pidfile
+  where
+	newfile = pidfile ++ ".new"
 #else
-	writeFile newfile . show =<< getPID
+	{- Not atomic on Windows, oh well. -}
+	pid <- getPID
+	writeFile pidfile (show pid)
+	lckfile <- winLockFile pid pidfile
+	writeFile lckfile ""
+	void $ lockExclusive lckfile
 #endif
-	rename newfile file
-  where
-	newfile = file ++ ".new"
 
 alreadyRunning :: IO ()
 alreadyRunning = error "Daemon is already running."
@@ -108,7 +116,17 @@ checkDaemon pidfile = do
 			" (got " ++ show pid' ++ 
 			"; expected " ++ show pid ++ " )"
 #else
-checkDaemon pidfile = maybe Nothing readish <$> catchMaybeIO (readFile pidfile)
+checkDaemon pidfile = maybe (return Nothing) (check . readish)
+	=<< catchMaybeIO (readFile pidfile)
+  where
+	check Nothing = return Nothing
+	check (Just pid) = do
+		v <- lockShared =<< winLockFile pid pidfile
+		case v of
+			Just h -> do
+				dropLock h
+				return Nothing
+			Nothing -> return (Just pid)
 #endif
 
 {- Stops the daemon, safely. -}
@@ -122,3 +140,20 @@ stopDaemon pidfile = go =<< checkDaemon pidfile
 #else
 		terminatePID pid
 #endif
+
+{- Windows locks a lock file that corresponds with the pid of the process.
+ - This allows changing the process in the pid file and taking a new lock
+ - when eg, restarting the daemon.
+ -}
+#ifdef mingw32_HOST_OS
+winLockFile :: PID -> FilePath -> IO FilePath
+winLockFile pid pidfile = do
+	cleanstale
+	return $ prefix ++ show pid ++ suffix
+  where
+  	prefix = pidfile ++ "."
+	suffix = ".lck"
+	cleanstale = mapM_ (void . tryIO . removeFile) =<<
+		(filter iswinlockfile <$> dirContents (parentDir pidfile))
+	iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f
+#endif