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.
This commit is contained in:
Joey Hess 2013-12-11 00:15:10 -04:00
parent c01af6285f
commit 011b8bc7ec
6 changed files with 46 additions and 19 deletions

View file

@ -26,6 +26,9 @@ import Control.Concurrent
import System.Process (cwd) import System.Process (cwd)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import System.Posix (getProcessID, signalProcess, sigTERM) import System.Posix (getProcessID, signalProcess, sigTERM)
#else
import System.Win32.Process.Current (getCurrentProcessId)
import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT)
#endif #endif
{- Before the assistant can be restarted, have to remove our {- 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. -} - Wait for browser to update before terminating this process. -}
postRestart :: URLString -> Assistant () postRestart :: URLString -> Assistant ()
postRestart url = do postRestart url = do
#ifndef mingw32_HOST_OS
modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url } modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
void $ liftIO $ forkIO $ do void $ liftIO $ forkIO $ do
threadDelaySeconds (Seconds 120) threadDelaySeconds (Seconds 120)
#ifndef mingw32_HOST_OS
signalProcess sigTERM =<< getProcessID signalProcess sigTERM =<< getProcessID
#else #else
error "TODO windows postRestart" generateConsoleCtrlEvent cTRL_C_EVENT =<< getCurrentProcessId
#endif #endif
runRestart :: Assistant URLString runRestart :: Assistant URLString

View file

@ -18,11 +18,14 @@ import Utility.LogFile
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Control.Concurrent import Control.Concurrent
#ifndef mingw32_HOST_OS
import System.Posix (getProcessID, signalProcess, sigTERM)
#endif
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Text as T 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 :: Handler Html
getShutdownR = page "Shutdown" Nothing $ getShutdownR = page "Shutdown" Nothing $
@ -46,14 +49,14 @@ getShutdownConfirmedR = do
liftAssistant $ do liftAssistant $ do
modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url } modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
#ifndef mingw32_HOST_OS
{- Wait 2 seconds before shutting down, to give the web {- Wait 2 seconds before shutting down, to give the web
- page time to load in the browser. -} - page time to load in the browser. -}
void $ liftIO $ forkIO $ do void $ liftIO $ forkIO $ do
threadDelay 2000000 threadDelay 2000000
#ifndef mingw32_HOST_OS
signalProcess sigTERM =<< getProcessID signalProcess sigTERM =<< getProcessID
#else #else
void $ liftIO exitSuccess generateConsoleCtrlEvent cTRL_C_EVENT =<< getCurrentProcessId
#endif #endif
redirect NotRunningR redirect NotRunningR

View file

@ -38,7 +38,7 @@ import GitAnnex.Options hiding (fromOption)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import System.Posix.Process (getProcessID) import System.Posix.Process (getProcessID)
#else #else
import System.Random (getStdRandom, random) import System.Win32.Process.Current (getCurrentProcessId)
#endif #endif
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Data.Time import Data.Time
@ -154,7 +154,7 @@ performRemote key file backend numcopies remote =
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
v <- liftIO getProcessID v <- liftIO getProcessID
#else #else
v <- liftIO (getStdRandom random :: IO Int) v <- liftIO getCurrentProcessId
#endif #endif
t <- fromRepo gitAnnexTmpDir t <- fromRepo gitAnnexTmpDir
createAnnexDirectory t createAnnexDirectory t

View file

@ -18,17 +18,19 @@ import Utility.Metered
import Utility.Percentage import Utility.Percentage
import Utility.QuickCheck 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
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Data.Time import Data.Time
import System.Locale import System.Locale
import Control.Concurrent 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 #ifndef mingw32_HOST_OS
type PID = ProcessID type PID = ProcessID
#else #else
@ -214,7 +216,11 @@ mkProgressUpdater t info = do
startTransferInfo :: Maybe FilePath -> IO TransferInfo startTransferInfo :: Maybe FilePath -> IO TransferInfo
startTransferInfo file = TransferInfo startTransferInfo file = TransferInfo
<$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime) <$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime)
#ifndef mingw32_HOST_OS
<*> pure Nothing -- pid not stored in file, so omitted for speed <*> pure Nothing -- pid not stored in file, so omitted for speed
#else
<*> (Just <$> getCurrentProcessId)
#endif
<*> pure Nothing -- tid ditto <*> pure Nothing -- tid ditto
<*> pure Nothing -- not 0; transfer may be resuming <*> pure Nothing -- not 0; transfer may be resuming
<*> pure Nothing <*> pure Nothing
@ -328,13 +334,18 @@ writeTransferInfoFile info tfile = do
{- File format is a header line containing the startedTime and any {- File format is a header line containing the startedTime and any
- bytesComplete value. Followed by a newline and the associatedFile. - bytesComplete value. Followed by a newline and the associatedFile.
- -
- The transferPid is not included; instead it is obtained by looking - On unix, the transferPid is not included; instead it is obtained
- at the process that locks the file. - by looking at the process that locks the file.
-
- On windows, the transferPid is included, as a second line.
-} -}
writeTransferInfo :: TransferInfo -> String writeTransferInfo :: TransferInfo -> String
writeTransferInfo info = unlines writeTransferInfo info = unlines
[ (maybe "" show $ startedTime info) ++ [ (maybe "" show $ startedTime info) ++
(maybe "" (\b -> ' ' : show b) (bytesComplete info)) (maybe "" (\b -> ' ' : show b) (bytesComplete info))
#ifdef mingw32_HOST_OS
, maybe "" show (transferPid info)
#endif
, fromMaybe "" $ associatedFile info -- comes last; arbitrary content , fromMaybe "" $ associatedFile info -- comes last; arbitrary content
] ]
@ -347,14 +358,24 @@ readTransferInfoFile mpid tfile = catchDefaultIO Nothing $ do
readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo
readTransferInfo mpid s = TransferInfo readTransferInfo mpid s = TransferInfo
<$> time <$> time
#ifdef mingw32_HOST_OS
<*> pure $ if isJust mpid then mpid else mpid'
#else
<*> pure mpid <*> pure mpid
#endif
<*> pure Nothing <*> pure Nothing
<*> pure Nothing <*> pure Nothing
<*> bytes <*> bytes
<*> pure (if null filename then Nothing else Just filename) <*> pure (if null filename then Nothing else Just filename)
<*> pure False <*> pure False
where where
#ifdef mingw32_HOST_OS
(firstline, rem) = separate (== '\n') s
(secondline, rest) = separate (== '\n') rem
mpid' = readish secondline
#else
(firstline, rest) = separate (== '\n') s (firstline, rest) = separate (== '\n') s
#endif
filename filename
| end rest == "\n" = beginning rest | end rest == "\n" = beginning rest
| otherwise = rest | otherwise = rest

View file

@ -23,7 +23,7 @@ import qualified Data.Map as M
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import System.Posix.Process (getProcessID) import System.Posix.Process (getProcessID)
#else #else
import System.Random (getStdRandom, random) import System.Win32.Process.Current (getCurrentProcessId)
#endif #endif
import Common.Annex import Common.Annex
@ -243,7 +243,7 @@ withRsyncScratchDir a = do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
v <- liftIO getProcessID v <- liftIO getProcessID
#else #else
v <- liftIO (getStdRandom random :: IO Int) v <- liftIO getCurrentProcessId
#endif #endif
t <- fromRepo gitAnnexTmpDir t <- fromRepo gitAnnexTmpDir
createAnnexDirectory t createAnnexDirectory t

View file

@ -101,7 +101,7 @@ Executable git-annex
GHC-Options: -O2 GHC-Options: -O2
if (os(windows)) if (os(windows))
Build-Depends: Win32 Build-Depends: Win32, Win32-extras
else else
Build-Depends: unix Build-Depends: unix
-- Need to list these because they're generated from .hsc files. -- Need to list these because they're generated from .hsc files.