From b2597fed2737ed9785908a46b032cb8090e7252d Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 13 Feb 2014 16:03:49 -0400
Subject: 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.
---
 Utility/Daemon.hs             | 53 +++++++++++++++++++++++++++++++++++--------
 doc/todo/windows_support.mdwn |  3 ---
 2 files changed, 44 insertions(+), 12 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
diff --git a/doc/todo/windows_support.mdwn b/doc/todo/windows_support.mdwn
index 87a39acf2..520588e59 100644
--- a/doc/todo/windows_support.mdwn
+++ b/doc/todo/windows_support.mdwn
@@ -52,9 +52,6 @@ now! --[[Joey]]
   there.
 * Deleting a git repository from inside the webapp fails "RemoveDirectory
   permision denined ... file is being used by another process"
-* Shutting down the webapp does not stop the daemon; the ctrl-c hack
-  doesn't work. (Restarting the daemon also does not stop the old process,
-  same reason.)
 
 ## stuff needing testing
 
-- 
cgit v1.2.3