From 011b8bc7ecb85809740f77e1b8f9c6157c81014b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 11 Dec 2013 00:15:10 -0400 Subject: [PATCH] pull in Win32-extras, to be able to get current process id in Windows Fixed up a number of things that had worked around there not being a way to get that. Most notably, transfer info files on windows now include the process id, since no locking is currently done. This means the file format varies between windows and unix. --- Assistant/Restart.hs | 7 +++++-- Assistant/WebApp/Control.hs | 13 ++++++++----- Command/Fsck.hs | 4 ++-- Logs/Transfer.hs | 35 ++++++++++++++++++++++++++++------- Remote/Rsync.hs | 4 ++-- git-annex.cabal | 2 +- 6 files changed, 46 insertions(+), 19 deletions(-) diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs index 64e897bc3a..20629cc818 100644 --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -26,6 +26,9 @@ import Control.Concurrent import System.Process (cwd) #ifndef mingw32_HOST_OS import System.Posix (getProcessID, signalProcess, sigTERM) +#else +import System.Win32.Process.Current (getCurrentProcessId) +import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT) #endif {- Before the assistant can be restarted, have to remove our @@ -45,14 +48,14 @@ prepRestart = do - Wait for browser to update before terminating this process. -} postRestart :: URLString -> Assistant () postRestart url = do -#ifndef mingw32_HOST_OS modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url } liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus void $ liftIO $ forkIO $ do threadDelaySeconds (Seconds 120) +#ifndef mingw32_HOST_OS signalProcess sigTERM =<< getProcessID #else - error "TODO windows postRestart" + generateConsoleCtrlEvent cTRL_C_EVENT =<< getCurrentProcessId #endif runRestart :: Assistant URLString diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs index efac701521..02b559096e 100644 --- a/Assistant/WebApp/Control.hs +++ b/Assistant/WebApp/Control.hs @@ -18,11 +18,14 @@ import Utility.LogFile import Utility.NotificationBroadcaster import Control.Concurrent -#ifndef mingw32_HOST_OS -import System.Posix (getProcessID, signalProcess, sigTERM) -#endif import qualified Data.Map as M import qualified Data.Text as T +#ifndef mingw32_HOST_OS +import System.Posix (getProcessID, signalProcess, sigTERM) +#else +import System.Win32.Process.Current (getCurrentProcessId) +import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT) +#endif getShutdownR :: Handler Html getShutdownR = page "Shutdown" Nothing $ @@ -46,14 +49,14 @@ getShutdownConfirmedR = do liftAssistant $ do modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url } liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus -#ifndef mingw32_HOST_OS {- Wait 2 seconds before shutting down, to give the web - page time to load in the browser. -} void $ liftIO $ forkIO $ do threadDelay 2000000 +#ifndef mingw32_HOST_OS signalProcess sigTERM =<< getProcessID #else - void $ liftIO exitSuccess + generateConsoleCtrlEvent cTRL_C_EVENT =<< getCurrentProcessId #endif redirect NotRunningR diff --git a/Command/Fsck.hs b/Command/Fsck.hs index d3a8b30837..2ab47b5627 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -38,7 +38,7 @@ import GitAnnex.Options hiding (fromOption) #ifndef mingw32_HOST_OS import System.Posix.Process (getProcessID) #else -import System.Random (getStdRandom, random) +import System.Win32.Process.Current (getCurrentProcessId) #endif import Data.Time.Clock.POSIX import Data.Time @@ -154,7 +154,7 @@ performRemote key file backend numcopies remote = #ifndef mingw32_HOST_OS v <- liftIO getProcessID #else - v <- liftIO (getStdRandom random :: IO Int) + v <- liftIO getCurrentProcessId #endif t <- fromRepo gitAnnexTmpDir createAnnexDirectory t diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index b96b827c63..a278fce356 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -18,17 +18,19 @@ import Utility.Metered import Utility.Percentage import Utility.QuickCheck -#ifndef mingw32_HOST_OS -import System.Posix.Types (ProcessID) -#else -import System.Win32.Process (ProcessId) -#endif import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Time import System.Locale import Control.Concurrent +#ifndef mingw32_HOST_OS +import System.Posix.Types (ProcessID) +#else +import System.Win32.Process (ProcessId) +import System.Win32.Process.Current (getCurrentProcessId) +#endif + #ifndef mingw32_HOST_OS type PID = ProcessID #else @@ -214,7 +216,11 @@ mkProgressUpdater t info = do startTransferInfo :: Maybe FilePath -> IO TransferInfo startTransferInfo file = TransferInfo <$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime) +#ifndef mingw32_HOST_OS <*> pure Nothing -- pid not stored in file, so omitted for speed +#else + <*> (Just <$> getCurrentProcessId) +#endif <*> pure Nothing -- tid ditto <*> pure Nothing -- not 0; transfer may be resuming <*> pure Nothing @@ -328,13 +334,18 @@ writeTransferInfoFile info tfile = do {- File format is a header line containing the startedTime and any - bytesComplete value. Followed by a newline and the associatedFile. - - - The transferPid is not included; instead it is obtained by looking - - at the process that locks the file. + - On unix, the transferPid is not included; instead it is obtained + - by looking at the process that locks the file. + - + - On windows, the transferPid is included, as a second line. -} writeTransferInfo :: TransferInfo -> String writeTransferInfo info = unlines [ (maybe "" show $ startedTime info) ++ (maybe "" (\b -> ' ' : show b) (bytesComplete info)) +#ifdef mingw32_HOST_OS + , maybe "" show (transferPid info) +#endif , fromMaybe "" $ associatedFile info -- comes last; arbitrary content ] @@ -347,14 +358,24 @@ readTransferInfoFile mpid tfile = catchDefaultIO Nothing $ do readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo readTransferInfo mpid s = TransferInfo <$> time +#ifdef mingw32_HOST_OS + <*> pure $ if isJust mpid then mpid else mpid' +#else <*> pure mpid +#endif <*> pure Nothing <*> pure Nothing <*> bytes <*> pure (if null filename then Nothing else Just filename) <*> pure False where +#ifdef mingw32_HOST_OS + (firstline, rem) = separate (== '\n') s + (secondline, rest) = separate (== '\n') rem + mpid' = readish secondline +#else (firstline, rest) = separate (== '\n') s +#endif filename | end rest == "\n" = beginning rest | otherwise = rest diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 627690d2bd..fd00d46740 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -23,7 +23,7 @@ import qualified Data.Map as M #ifndef mingw32_HOST_OS import System.Posix.Process (getProcessID) #else -import System.Random (getStdRandom, random) +import System.Win32.Process.Current (getCurrentProcessId) #endif import Common.Annex @@ -243,7 +243,7 @@ withRsyncScratchDir a = do #ifndef mingw32_HOST_OS v <- liftIO getProcessID #else - v <- liftIO (getStdRandom random :: IO Int) + v <- liftIO getCurrentProcessId #endif t <- fromRepo gitAnnexTmpDir createAnnexDirectory t diff --git a/git-annex.cabal b/git-annex.cabal index 789ded518c..3d1c0b2114 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -101,7 +101,7 @@ Executable git-annex GHC-Options: -O2 if (os(windows)) - Build-Depends: Win32 + Build-Depends: Win32, Win32-extras else Build-Depends: unix -- Need to list these because they're generated from .hsc files.