cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs

   1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  Distribution.Client.Win32SelfUpgrade
   5 -- Copyright   :  (c) Duncan Coutts 2008
   6 -- License     :  BSD-like
   7 --
   8 -- Maintainer  :  cabal-devel@haskell.org
   9 -- Stability   :  provisional
  10 -- Portability :  portable
  11 --
  12 -- Support for self-upgrading executables on Windows platforms.
  13 -----------------------------------------------------------------------------
  14 module Distribution.Client.Win32SelfUpgrade (
  15 -- * Explanation
  16 --
  17 -- | Windows inherited a design choice from DOS that while initially innocuous
  18 -- has rather unfortunate consequences. It maintains the invariant that every
  19 -- open file has a corresponding name on disk. One positive consequence of this
  20 -- is that an executable can always find its own executable file. The downside
  21 -- is that a program cannot be deleted or upgraded while it is running without
  22 -- hideous workarounds. This module implements one such hideous workaround.
  23 --
  24 -- The basic idea is:
  25 --
  26 -- * Move our own exe file to a new name
  27 -- * Copy a new exe file to the previous name
  28 -- * Run the new exe file, passing our own PID and new path
  29 -- * Wait for the new process to start
  30 -- * Close the new exe file
  31 -- * Exit old process
  32 --
  33 -- Then in the new process:
  34 --
  35 -- * Inform the old process that we've started
  36 -- * Wait for the old process to die
  37 -- * Delete the old exe file
  38 -- * Exit new process
  39 --
  40
  41     possibleSelfUpgrade,
  42     deleteOldExeFile,
  43   ) where
  44
  45 import Distribution.Client.Compat.Prelude hiding (log)
  46 import Prelude ()
  47
  48 #ifdef mingw32_HOST_OS
  49
  50 import qualified System.Win32 as Win32
  51 import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)
  52 import Foreign.Ptr (Ptr, nullPtr)
  53 import System.Process (runProcess)
  54 import System.Directory (canonicalizePath)
  55 import System.FilePath (takeBaseName, replaceBaseName, equalFilePath)
  56
  57 import Distribution.Verbosity as Verbosity (showForCabal)
  58 import Distribution.Simple.Utils (debug, info)
  59
  60
  61 -- | If one of the given files is our own exe file then we arrange things such
  62 -- that the nested action can replace our own exe file.
  63 --
  64 -- We require that the new process accepts a command line invocation that
  65 -- calls 'deleteOldExeFile', passing in the PID and exe file.
  66 --
  67 possibleSelfUpgrade :: Verbosity
  68                     -> [FilePath]
  69                     -> IO a -> IO a
  70 possibleSelfUpgrade verbosity newPaths action = do
  71   dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE
  72
  73   newPaths' <- traverse canonicalizePath newPaths
  74   let doingSelfUpgrade = any (equalFilePath dstPath) newPaths'
  75
  76   if not doingSelfUpgrade
  77     then action
  78     else do
  79       info verbosity $ "cabal-install does the replace-own-exe-file dance..."
  80       tmpPath <- moveOurExeOutOfTheWay verbosity
  81       result <- action
  82       scheduleOurDemise verbosity dstPath tmpPath
  83         (\pid path -> ["win32selfupgrade", pid, path
  84                       ,"--verbose=" ++ Verbosity.showForCabal verbosity])
  85       return result
  86
  87 -- | The name of a Win32 Event object that we use to synchronise between the
  88 -- old and new processes. We need to synchronise to make sure that the old
  89 -- process has not yet terminated by the time the new one starts up and looks
  90 -- for the old process. Otherwise the old one might have already terminated
  91 -- and we could not wait on it terminating reliably (eg the PID might get
  92 -- re-used).
  93 --
  94 syncEventName :: String
  95 syncEventName = "Local\\cabal-install-upgrade"
  96
  97 -- | The first part of allowing our exe file to be replaced is to move the
  98 -- existing exe file out of the way. Although we cannot delete our exe file
  99 -- while we're still running, fortunately we can rename it, at least within
 100 -- the same directory.
 101 --
 102 moveOurExeOutOfTheWay :: Verbosity -> IO FilePath
 103 moveOurExeOutOfTheWay verbosity = do
 104   ourPID  <-       getCurrentProcessId
 105   dstPath <- Win32.getModuleFileName Win32.nullHANDLE
 106
 107   let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID)
 108
 109   debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath
 110   Win32.moveFile dstPath tmpPath
 111   return tmpPath
 112
 113 -- | Assuming we've now installed the new exe file in the right place, we
 114 -- launch it and ask it to delete our exe file when we eventually terminate.
 115 --
 116 scheduleOurDemise :: Verbosity -> FilePath -> FilePath
 117                   -> (String -> FilePath -> [String]) -> IO ()
 118 scheduleOurDemise verbosity dstPath tmpPath mkArgs = do
 119   ourPID <- getCurrentProcessId
 120   event  <- createEvent syncEventName
 121
 122   let args = mkArgs (show ourPID) tmpPath
 123   log $ "launching child " ++ unwords (dstPath : map show args)
 124   _ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing
 125
 126   log $ "waiting for the child to start up"
 127   waitForSingleObject event (10*1000) -- wait at most 10 sec
 128   log $ "child started ok"
 129
 130   where
 131     log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg)
 132
 133 -- | Assuming we're now in the new child process, we've been asked by the old
 134 -- process to wait for it to terminate and then we can remove the old exe file
 135 -- that it renamed itself to.
 136 --
 137 deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()
 138 deleteOldExeFile verbosity oldPID tmpPath = do
 139   log $ "process started. Will delete exe file of process "
 140      ++ show oldPID ++ " at path " ++ tmpPath
 141
 142   log $ "getting handle of parent process " ++ show oldPID
 143   oldPHANDLE <- Win32.openProcess Win32.sYNCHRONIZE False (fromIntegral oldPID)
 144
 145   log $ "synchronising with parent"
 146   event <- openEvent syncEventName
 147   setEvent event
 148
 149   log $ "waiting for parent process to terminate"
 150   waitForSingleObject oldPHANDLE Win32.iNFINITE
 151   log $ "parent process terminated"
 152
 153   log $ "deleting parent's old .exe file"
 154   Win32.deleteFile tmpPath
 155
 156   where
 157     log msg = debug verbosity ("Win32Reinstall.child: " ++ msg)
 158
 159 ------------------------
 160 -- Win32 foreign imports
 161 --
 162
 163 -- A bunch of functions sadly not provided by the Win32 package.
 164
 165 #ifdef x86_64_HOST_ARCH
 166 #define CALLCONV ccall
 167 #else
 168 #define CALLCONV stdcall
 169 #endif
 170
 171 foreign import CALLCONV unsafe "windows.h GetCurrentProcessId"
 172   getCurrentProcessId :: IO DWORD
 173
 174 foreign import CALLCONV unsafe "windows.h WaitForSingleObject"
 175   waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD
 176
 177 waitForSingleObject :: HANDLE -> DWORD -> IO ()
 178 waitForSingleObject handle timeout =
 179   Win32.failIf_ bad "WaitForSingleObject" $
 180     waitForSingleObject_ handle timeout
 181   where
 182     bad result   = not (result == 0 || result == wAIT_TIMEOUT)
 183     wAIT_TIMEOUT = 0x00000102
 184
 185 foreign import CALLCONV unsafe "windows.h CreateEventW"
 186   createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE
 187
 188 createEvent :: String -> IO HANDLE
 189 createEvent name = do
 190   Win32.failIfNull "CreateEvent" $
 191     Win32.withTString name $
 192       createEvent_ nullPtr False False
 193
 194 foreign import CALLCONV unsafe "windows.h OpenEventW"
 195   openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE
 196
 197 openEvent :: String -> IO HANDLE
 198 openEvent name = do
 199   Win32.failIfNull "OpenEvent" $
 200     Win32.withTString name $
 201       openEvent_ eVENT_MODIFY_STATE False
 202   where
 203     eVENT_MODIFY_STATE :: DWORD
 204     eVENT_MODIFY_STATE = 0x0002
 205
 206 foreign import CALLCONV unsafe "windows.h SetEvent"
 207   setEvent_ :: HANDLE -> IO BOOL
 208
 209 setEvent :: HANDLE -> IO ()
 210 setEvent handle =
 211   Win32.failIfFalse_ "SetEvent" $
 212     setEvent_ handle
 213
 214 #else
 215
 216 import Distribution.Simple.Utils (die')
 217
 218 possibleSelfUpgrade :: Verbosity
 219                     -> [FilePath]
 220                     -> IO a -> IO a
 221 possibleSelfUpgrade _ _ action = action
 222
 223 deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()
 224 deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32"
 225
 226 #endif