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

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