windows: Fix process termination code.

The ctrl-c hack used before didn't actually seem to work.

No haskell libraries expose TerminateProcess. I tried just calling it via
FFI, but got segfaults, probably to do with the wacky process handle not
being managed correctly. Moving it all into one C function worked.

This was hell. The EvilLinker hack was just final icing on the cake.
We all know what the cake was made of.

Assistant.hs

@@ -93,7 +93,8 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
 			start (Utility.Daemon.daemonize logfd (Just pidfile) False) Nothing
 #else
 	-- Windows is always foreground, and has no log file.
-	start id $
+	liftIO $ Utility.Daemon.lockPidFile pidfile
+	start id $ do
 		case startbrowser of
 			Nothing -> Nothing
 			Just a -> Just $ a Nothing Nothing

Assistant/Restart.hs

@@ -28,7 +28,7 @@ import System.Process (cwd)
 #ifndef mingw32_HOST_OS
 import System.Posix (signalProcess, sigTERM)
 #else
-import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT)
+import Utility.WinProcess
 #endif
 
 {- Before the assistant can be restarted, have to remove our 
@@ -55,7 +55,7 @@ postRestart url = do
 #ifndef mingw32_HOST_OS
 		signalProcess sigTERM =<< getPID
 #else
-		generateConsoleCtrlEvent cTRL_C_EVENT =<< getPID
+		terminatePID =<< getPID
 #endif
 
 runRestart :: Assistant URLString

Assistant/TransferSlots.hs

@@ -39,7 +39,7 @@ import qualified Control.Concurrent.MSemN as MSemN
 import System.Posix.Process (getProcessGroupIDOf)
 import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
 #else
-import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT)
+import Utility.WinProcess
 #endif
 
 type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
@@ -256,23 +256,19 @@ cancelTransfer pause t = do
 	signalthread tid
 		| pause = throwTo tid PauseTransfer
 		| otherwise = killThread tid
-	{- In order to stop helper processes like rsync,
-	 - kill the whole process group of the process
-	 - running the transfer. -}
 	killproc pid = void $ tryIO $ do
 #ifndef mingw32_HOST_OS
+		{- In order to stop helper processes like rsync,
+		 - kill the whole process group of the process
+		 - running the transfer. -}
 		g <- getProcessGroupIDOf pid
 		let signal sig = void $ tryIO $ signalProcessGroup sig g
 		signal sigTERM
-		graceperiod
+		threadDelay 50000 -- 0.05 second grace period
 		signal sigKILL
 #else
-		let signal sig = void $ tryIO $ generateConsoleCtrlEvent sig pid
-		signal cTRL_C_EVENT
-		graceperiod
-		signal cTRL_BREAK_EVENT
+		terminatePID pid
 #endif
-	graceperiod = threadDelay 50000 -- 0.05 second
 
 {- Start or resume a transfer. -}
 startTransfer :: Transfer -> Assistant ()

Assistant/WebApp/Control.hs

@@ -24,7 +24,7 @@ import qualified Data.Text as T
 #ifndef mingw32_HOST_OS
 import System.Posix (signalProcess, sigTERM)
 #else
-import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT)
+import Utility.WinProcess
 #endif
 
 getShutdownR :: Handler Html
@@ -56,7 +56,7 @@ getShutdownConfirmedR = do
 #ifndef mingw32_HOST_OS
 		signalProcess sigTERM =<< getPID
 #else
-		generateConsoleCtrlEvent cTRL_C_EVENT =<< getPID
+		terminatePID =<< getPID
 #endif
 	redirect NotRunningR
 

Build/EvilLinker.hs

@@ -17,6 +17,7 @@ import Control.Applicative ((<$>))
 import Control.Monad
 import System.Directory
 import Data.Maybe
+import Data.List
 
 import Utility.Monad
 import Utility.Process
@@ -94,13 +95,19 @@ parseCollect2 = do
 	path <- manyTill anyChar (try $ string ldcmd)
 	void $ char ' '
 	params <- restOfLine
-	return $ CmdParams (path ++ ldcmd) (escapeDosPaths params) Nothing
+	return $ CmdParams (path ++ ldcmd) (skipHack $ escapeDosPaths params) Nothing
   where
 	ldcmd = "ld.exe"
 	versionline = do
 		void $ string "collect2 version"
 		restOfLine
-	
+
+{- For unknown reasons, asking the linker to link this in fails,
+ - with error about multiple definitions of a symbol from the library.
+ - This is a horrible hack. -}
+skipHack :: String -> String
+skipHack = replace "dist/build/git-annex/git-annex-tmp/Utility/winprocess.o" ""
+
 {- Input contains something like 
  - c:/program files/haskell platform/foo -LC:/Program Files/Haskell Platform/ -L...
  - and the *right* spaces must be escaped with \

Utility/Daemon.hs

@@ -13,14 +13,13 @@ import Common
 import Utility.PID
 #ifndef mingw32_HOST_OS
 import Utility.LogFile
+#else
+import Utility.WinProcess
 #endif
 
 #ifndef mingw32_HOST_OS
 import System.Posix
 import Control.Concurrent.Async
-#else
-import System.PosixCompat.Types
-import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT)
 #endif
 
 #ifndef mingw32_HOST_OS
@@ -75,7 +74,7 @@ lockPidFile file = do
 			_ <- fdWrite fd' =<< show <$> getPID
 			closeFd fd
 #else
-	writeFile newfile "-1"
+	writeFile newfile . show =<< getPID
 #endif
 	rename newfile file
   where
@@ -121,5 +120,5 @@ stopDaemon pidfile = go =<< checkDaemon pidfile
 #ifndef mingw32_HOST_OS
 		signalProcess sigTERM pid
 #else
-		generateConsoleCtrlEvent cTRL_C_EVENT pid
+		terminatePID pid
 #endif

Utility/WinProcess.hs

@@ -0,0 +1,19 @@
+{- Windows processes
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Utility.WinProcess where
+
+import Utility.PID
+
+import System.Win32.Process
+import Foreign.C
+import Control.Exception
+
+foreign import ccall unsafe "terminatepid"
+	terminatePID :: PID -> IO ()

Utility/winprocess.c

@@ -0,0 +1,10 @@
+#include <windows.h>
+
+void terminatepid (DWORD pid) {
+	HANDLE h;
+	h = OpenProcess(PROCESS_TERMINATE, 0, pid);
+	if (h != NULL) {
+		TerminateProcess(h, 1);
+	}
+	CloseHandle(h);
+}

doc/todo/windows_support.mdwn

@@ -53,11 +53,12 @@ now! --[[Joey]]
 * 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.
+  doesn't work. (Restarting the daemon also does not stop the old process,
+  same reason.)
 
 ## stuff needing testing
 
 * test S3 and box.com setup in webapp now that they should work..
 * test that adding a repo on a removable drive works; that git is synced to
   it and files can be transferred to it and back
-
+* Does stopping in progress transfers work in the webapp?

git-annex.cabal

@@ -105,6 +105,7 @@ Executable git-annex
 
   if (os(windows))
     Build-Depends: Win32, Win32-extras
+    C-Sources: Utility/winprocess.c
   else
     Build-Depends: unix
     -- Need to list these because they're generated from .hsc files.