Commit 1fc051e4 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Allow cabal-install to re-install itself on Windows

This is a fairly heavyweight solution, but then it's quite
a nasty problem. What we do is when we notice that we're
about to install something in place of our own .exe file,
we move our exe file out of the way (but in the same dir).
Then after we've installed the new exe we call it and ask
it to delete the old file (so we do not litter the bin dir
with lots of old versions). That requires synchronising
between the old and new programs and for the new program
to understand a command to do the syncing and deleting of
the old program. Lots of Win32 FFI imports. :-(
On the plus side it seems to work and is transparent to
the user and the rest of cabal-install. In particular the
actual file-installation code (which is burried deep
within Cabal) does not need to know about the special case
of installing over our own exe file.
parent 82322e78
......@@ -57,12 +57,14 @@ import qualified Distribution.Client.BuildReports.Storage as BuildReports
( storeAnonymous, storeLocal, fromInstallPlan )
import qualified Distribution.Client.InstallSymlink as InstallSymlink
( symlinkBinaries )
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Paths_cabal_install (getBinDir)
import Distribution.Simple.Compiler
( CompilerId, Compiler(compilerId), PackageDB(..) )
( CompilerId(..), Compiler(compilerId), PackageDB(..) )
import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)
import Distribution.Simple.Configure (getInstalledPackages)
import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Simple.Setup as Cabal
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
......@@ -75,7 +77,8 @@ import Distribution.Simple.InstallDirs
, initialPathTemplateEnv, substPathTemplate )
import Distribution.Package
( PackageIdentifier(..), Package(..), thisPackageVersion )
import Distribution.PackageDescription as PackageDescription
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription, readPackageDescription )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
......@@ -86,7 +89,7 @@ import Distribution.Version
import Distribution.Simple.Utils as Utils
( notice, info, warn, die, intercalate )
import Distribution.System
( OS, buildOS, Arch, buildArch )
( OS(Windows), buildOS, Arch, buildArch )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
......@@ -167,7 +170,7 @@ installWithPlanner planner verbosity packageDB repos comp conf configFlags insta
installAvailablePackage verbosity (packageId pkg) src $ \mpath ->
installUnpackedPackage verbosity (setupScriptOptions installed)
miscOptions configFlags' installFlags
pkg mpath (useLogFile logsDir)
compid pkg mpath (useLogFile logsDir)
let buildReports = BuildReports.fromInstallPlan installPlan'
BuildReports.storeAnonymous buildReports
......@@ -403,13 +406,14 @@ installUnpackedPackage :: Verbosity
-> InstallMisc
-> Cabal.ConfigFlags
-> InstallFlags
-> CompilerId
-> PackageDescription
-> Maybe FilePath -- ^ Directory to change to before starting the installation.
-> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)
-> IO BuildResult
installUnpackedPackage verbosity scriptOptions miscOptions
configFlags installConfigFlags
pkg workingDir useLogFile =
compid pkg workingDir useLogFile =
-- Configure phase
onFailure ConfigureFailed $ do
......@@ -430,11 +434,12 @@ installUnpackedPackage verbosity scriptOptions miscOptions
testsResult <- return TestsNotTried --TODO: add optional tests
-- Install phase
onFailure InstallFailed $ do
case rootCmd miscOptions of
(Just cmd) -> reexec cmd
Nothing -> setup Cabal.installCommand installFlags
return (Right (BuildOk docsResult testsResult))
onFailure InstallFailed $
withWin32SelfUpgrade verbosity configFlags compid pkg $ do
case rootCmd miscOptions of
(Just cmd) -> reexec cmd
Nothing -> setup Cabal.installCommand installFlags
return (Right (BuildOk docsResult testsResult))
where
configureFlags = filterConfigureFlags configFlags {
......@@ -488,3 +493,43 @@ installUnpackedPackage verbosity scriptOptions miscOptions
-- helper
onFailure :: (Exception -> BuildFailure) -> IO BuildResult -> IO BuildResult
onFailure result = Exception.handle (return . Left . result)
withWin32SelfUpgrade :: Verbosity
-> Cabal.ConfigFlags
-> CompilerId
-> PackageDescription
-> IO a -> IO a
withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action
withWin32SelfUpgrade verbosity configFlags compid pkg action = do
defaultDirs <- InstallDirs.defaultInstallDirs
compilerFlavor
(Cabal.fromFlag (Cabal.configUserInstall configFlags))
(PackageDescription.hasLibs pkg)
Win32SelfUpgrade.possibleSelfUpgrade verbosity
(exeInstallPaths defaultDirs) action
where
pkgid = packageId pkg
(CompilerId compilerFlavor _) = compid
exeInstallPaths defaultDirs =
[ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension
| exe <- PackageDescription.executables pkg
, PackageDescription.buildable (PackageDescription.buildInfo exe)
, let exeName = prefix ++ PackageDescription.exeName exe ++ suffix
prefix = substTemplate prefixTemplate
suffix = substTemplate suffixTemplate ]
where
fromFlagTemplate = Cabal.fromFlagOrDefault (InstallDirs.toPathTemplate "")
prefixTemplate = fromFlagTemplate (Cabal.configProgPrefix configFlags)
suffixTemplate = fromFlagTemplate (Cabal.configProgSuffix configFlags)
templateDirs = InstallDirs.combineInstallDirs Cabal.fromFlagOrDefault
defaultDirs (Cabal.configInstallDirs configFlags)
absoluteDirs = InstallDirs.absoluteInstallDirs
pkgid compid InstallDirs.NoCopyDest templateDirs
substTemplate = InstallDirs.fromPathTemplate
. InstallDirs.substPathTemplate env
where env = InstallDirs.initialPathTemplateEnv pkgid compid
{-# OPTIONS -cpp -fffi #-}
-- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# OPTIONS_GHC -cpp -fffi #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp -fffi #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Win32SelfUpgrade
-- Copyright : (c) Duncan Coutts 2008
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- Support for self-upgrading executables on Windows platforms.
-----------------------------------------------------------------------------
module Distribution.Client.Win32SelfUpgrade (
-- * Explanation
--
-- | Windows inherited a design choice from DOS that while initially innocuous
-- has rather unfortunate consequences. It maintains the invariant that every
-- open file has a corresponding name on disk. One positive consequence of this
-- is that an executable can always find it's own executable file. The downside
-- is that a program cannot be deleted or upgraded while it is running without
-- hideous workarounds. This module implements one such hideous workaround.
--
-- The basic idea is:
--
-- * Move our own exe file to a new name
-- * Copy a new exe file to the previous name
-- * Run the new exe file, passing our own pid and new path
-- * Wait for the new process to start
-- * Close the new exe file
-- * Exit old process
--
-- Then in the new process:
--
-- * Inform the old process that we've started
-- * Wait for the old process to die
-- * Delete the old exe file
-- * Exit new process
--
possibleSelfUpgrade,
deleteOldExeFile,
) where
#if mingw32_HOST_OS || mingw32_TARGET_OS
import qualified System.Win32 as Win32
import qualified System.Win32.DLL 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 (Verbosity, showForCabal)
import Distribution.Simple.Utils (debug, info)
import Prelude hiding (log)
-- | If one of the given files is our own exe file then we arrange things such
-- that the nested action can replace our own exe file.
--
-- We require that the new process accepts a command line invocation that
-- calls 'deleteOldExeFile', passing in the pid and exe file.
--
possibleSelfUpgrade :: Verbosity
-> [FilePath]
-> IO a -> IO a
possibleSelfUpgrade verbosity newPaths action = do
dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE
newPaths' <- mapM 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
-- | The name of a Win32 Event object that we use to synchronise between the
-- old and new processes. We need to synchronise to make sure that the old
-- process has not yet terminated by the time the new one starts up and looks
-- for the old process. Otherwise the old one might have already terminated
-- and we could not wait on it terminating reliably (eg the pid might get
-- re-used).
--
syncEventName :: String
syncEventName = "Local\\cabal-install-upgrade"
-- | The first part of allowing our exe file to be replaced is to move the
-- existing exe file out of the way. Although we cannot delete our exe file
-- while we're still running, fortunately we can rename it, at least within
-- the same directory.
--
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
-- | Assuming we've now installed the new exe file in the right place, we
-- launch it and ask it to delete our exe file when we eventually terminate.
--
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 (tmpPath : map show args)
runProcess dstPath args Nothing Nothing Nothing Nothing Nothing
log $ "waiting for the child to start up"
waitForSingleObject event (10*1000) -- wait at most 10 sec
log $ "child started ok"
where
log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg)
-- | Assuming we're now in the new child process, we've been asked by the old
-- process to wait for it to terminate and then we can remove the old exe file
-- that it renamted itself to.
--
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.sYNCHORNIZE 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)
------------------------
-- Win32 foreign imports
--
-- A bunch of functions sadly not provided by the Win32 package.
foreign import stdcall unsafe "windows.h GetCurrentProcessId"
getCurrentProcessId :: IO DWORD
foreign import stdcall unsafe "windows.h WaitForSingleObject"
waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD
waitForSingleObject :: HANDLE -> DWORD -> IO ()
waitForSingleObject handle timeout =
Win32.failIf_ (/=0) "WaitForSingleObject" $
waitForSingleObject_ handle timeout
foreign import stdcall 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 stdcall 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 stdcall unsafe "windows.h SetEvent"
setEvent_ :: HANDLE -> IO BOOL
setEvent :: HANDLE -> IO ()
setEvent handle =
Win32.failIfFalse_ "SetEvent" $
setEvent_ handle
#else
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.Utils (die)
possibleSelfUpgrade :: Verbosity
-> [FilePath]
-> IO a -> IO a
possibleSelfUpgrade _ _ action = action
deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()
deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32"
#endif
......@@ -41,8 +41,10 @@ import Distribution.Client.Check as Check (check)
--import Distribution.Client.Clean (clean)
import Distribution.Client.Upload as Upload (upload, check, report)
import Distribution.Client.SrcDist (sdist)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Verbosity (Verbosity, normal)
import Distribution.Verbosity as Verbosity
( Verbosity, normal, intToVerbosity )
import qualified Paths_cabal_install (version)
import System.Environment (getArgs, getProgName)
......@@ -50,6 +52,7 @@ import System.Exit (exitFailure)
import System.FilePath (splitExtension, takeExtension)
import System.Directory (doesFileExist)
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(..))
import Control.Monad (unless)
......@@ -59,7 +62,8 @@ main :: IO ()
main = getArgs >>= mainWorker
mainWorker :: [String] -> IO ()
mainWorker args =
mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args
mainWorker args =
case commandsRun globalCommand commands args of
CommandHelp help -> printHelp help
CommandList opts -> printOptionsList opts
......@@ -283,3 +287,13 @@ reportAction verbosityFlag extraArgs = do
config <- loadConfig verbosity configFile
Upload.report verbosity (configRepos config)
win32SelfUpgradeAction :: [String] -> IO ()
win32SelfUpgradeAction (pid:path:rest) =
Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path
where
verbosity = case rest of
(['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9']
-> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n]))
_ -> Verbosity.normal
win32SelfUpgradeAction _ = return ()
......@@ -65,6 +65,7 @@ Executable cabal
Distribution.Client.Update
Distribution.Client.Upload
Distribution.Client.Utils
Distribution.Client.Win32SelfUpgrade
build-depends: Cabal >= 1.4 && < 1.5,
filepath >= 1.0,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment