{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module Distribution.Client.Win32SelfUpgrade (
possibleSelfUpgrade,
deleteOldExeFile,
) where
import Distribution.Client.Compat.Prelude hiding (log)
import Prelude ()
#ifdef mingw32_HOST_OS
import qualified System.Win32 as Win32
import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)
import Foreign.Ptr (Ptr, nullPtr)
import System.Process (runProcess)
import System.Directory (canonicalizePath)
import System.FilePath (takeBaseName, replaceBaseName, equalFilePath)
import Distribution.Verbosity as Verbosity (showForCabal)
import Distribution.Simple.Utils (debug, info)
possibleSelfUpgrade :: Verbosity
-> [FilePath]
-> IO a -> IO a
possibleSelfUpgrade verbosity newPaths action = do
dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE
newPaths' <- traverse canonicalizePath newPaths
let doingSelfUpgrade = any (equalFilePath dstPath) newPaths'
if not doingSelfUpgrade
then action
else do
info verbosity $ "cabal-install does the replace-own-exe-file dance..."
tmpPath <- moveOurExeOutOfTheWay verbosity
result <- action
scheduleOurDemise verbosity dstPath tmpPath
(\pid path -> ["win32selfupgrade", pid, path
,"--verbose=" ++ Verbosity.showForCabal verbosity])
return result
syncEventName :: String
syncEventName = "Local\\cabal-install-upgrade"
moveOurExeOutOfTheWay :: Verbosity -> IO FilePath
moveOurExeOutOfTheWay verbosity = do
ourPID <- getCurrentProcessId
dstPath <- Win32.getModuleFileName Win32.nullHANDLE
let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID)
debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath
Win32.moveFile dstPath tmpPath
return tmpPath
scheduleOurDemise :: Verbosity -> FilePath -> FilePath
-> (String -> FilePath -> [String]) -> IO ()
scheduleOurDemise verbosity dstPath tmpPath mkArgs = do
ourPID <- getCurrentProcessId
event <- createEvent syncEventName
let args = mkArgs (show ourPID) tmpPath
log $ "launching child " ++ unwords (dstPath : map show args)
_ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing
log $ "waiting for the child to start up"
waitForSingleObject event (10*1000)
log $ "child started ok"
where
log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg)
deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()
deleteOldExeFile verbosity oldPID tmpPath = do
log $ "process started. Will delete exe file of process "
++ show oldPID ++ " at path " ++ tmpPath
log $ "getting handle of parent process " ++ show oldPID
oldPHANDLE <- Win32.openProcess Win32.sYNCHRONIZE False (fromIntegral oldPID)
log $ "synchronising with parent"
event <- openEvent syncEventName
setEvent event
log $ "waiting for parent process to terminate"
waitForSingleObject oldPHANDLE Win32.iNFINITE
log $ "parent process terminated"
log $ "deleting parent's old .exe file"
Win32.deleteFile tmpPath
where
log msg = debug verbosity ("Win32Reinstall.child: " ++ msg)
#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
#define CALLCONV stdcall
#endif
foreign import CALLCONV unsafe "windows.h GetCurrentProcessId"
getCurrentProcessId :: IO DWORD
foreign import CALLCONV unsafe "windows.h WaitForSingleObject"
waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD
waitForSingleObject :: HANDLE -> DWORD -> IO ()
waitForSingleObject handle timeout =
Win32.failIf_ bad "WaitForSingleObject" $
waitForSingleObject_ handle timeout
where
bad result = not (result == 0 || result == wAIT_TIMEOUT)
wAIT_TIMEOUT = 0x00000102
foreign import CALLCONV unsafe "windows.h CreateEventW"
createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE
createEvent :: String -> IO HANDLE
createEvent name = do
Win32.failIfNull "CreateEvent" $
Win32.withTString name $
createEvent_ nullPtr False False
foreign import CALLCONV unsafe "windows.h OpenEventW"
openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE
openEvent :: String -> IO HANDLE
openEvent name = do
Win32.failIfNull "OpenEvent" $
Win32.withTString name $
openEvent_ eVENT_MODIFY_STATE False
where
eVENT_MODIFY_STATE :: DWORD
eVENT_MODIFY_STATE = 0x0002
foreign import CALLCONV unsafe "windows.h SetEvent"
setEvent_ :: HANDLE -> IO BOOL
setEvent :: HANDLE -> IO ()
setEvent handle =
Win32.failIfFalse_ "SetEvent" $
setEvent_ handle
#else
import Distribution.Simple.Utils (die')
possibleSelfUpgrade :: Verbosity
-> [FilePath]
-> IO a -> IO a
possibleSelfUpgrade :: Verbosity -> [FilePath] -> IO a -> IO a
possibleSelfUpgrade Verbosity
_ [FilePath]
_ IO a
action = IO a
action
deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()
deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()
deleteOldExeFile Verbosity
verbosity Int
_ FilePath
_ = Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"win32selfupgrade not needed except on win32"
#endif