Resolve symlinks when attempting to find GHC's lib folder on Windows
authorTamar Christina <tamar@zhox.com>
Sun, 17 Apr 2016 15:11:02 +0000 (17:11 +0200)
committerTamar Christina <tamar@zhox.com>
Sun, 17 Apr 2016 15:23:28 +0000 (17:23 +0200)
Summary:
Systools makes some pretty hard assumptions about where GHC is on Windows.
One of these is that ghc be in a folder named `bin` and that `../lib` exists.

This pattern doesn't hold for symlinks as a link `C:\ghc-bin\`
pointing to `C:\ghc\ghc-7.10.3\bin` will break this assumption.

This patch resolves symlinks by finding where they point to and uses that location
as the base for GHC.

This uses an API that's been introduced in Vista. For older systems it falls back to
the current behavior of not resolving symlinks.

Test Plan:
1) Create symlink to GHC's bin folder.
2) Run GHC from that folder.

Reviewers: austin, bgamari

Reviewed By: austin

Subscribers: #ghc_windows_task_force, thomie

Differential Revision: https://phabricator.haskell.org/D2101

GHC Trac Issues: #11759

compiler/main/SysTools.hs

index 4afb199..9423b00 100644 (file)
@@ -85,6 +85,14 @@ import qualified System.Posix.Internals
 #else /* Must be Win32 */
 import Foreign
 import Foreign.C.String
+import qualified System.Win32.Info as Info
+import Control.Exception (finally)
+import Foreign.Ptr (FunPtr, castPtrToFunPtr)
+import System.Win32.Types (DWORD, LPTSTR, HANDLE)
+import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
+import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
+import System.Win32.DLL (loadLibrary, getProcAddress)
+import Data.Bits((.|.))
 #endif
 
 import System.Process
@@ -1495,9 +1503,19 @@ getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
         ret <- c_GetModuleFileName nullPtr buf size
         case ret of
           0 -> return Nothing
-          _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
+          _ | ret < size -> do path <- peekCWString buf
+                               real <- getFinalPath path -- try to resolve symlinks paths
+                               return $ (Just . rootDir . sanitize . maybe path id) real
             | otherwise  -> try_size (size * 2)
 
+    -- getFinalPath returns paths in full raw form.
+    -- Unfortunately GHC isn't set up to handle these
+    -- So if the call succeeded, we need to drop the
+    -- \\?\ prefix.
+    sanitize s = if "\\\\?\\" `isPrefixOf` s
+                    then drop 4 s
+                    else s
+
     rootDir s = case splitFileName $ normalise s of
                 (d, ghc_exe)
                  | lower ghc_exe `elem` ["ghc.exe",
@@ -1514,6 +1532,38 @@ getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
 
 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
   c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
+
+-- Attempt to resolve symlinks in order to find the actual location GHC
+-- is located at. See Trac #11759.
+getFinalPath :: FilePath -> IO (Maybe FilePath)
+getFinalPath name = do
+    dllHwnd <- failIfNull "LoadLibray"     $ loadLibrary "kernel32.dll"
+    -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista.
+    -- This means that we can't bind directly to it since it may be missing.
+    -- Instead try to find it's address at runtime and if we don't succeed consider the
+    -- function failed.
+    addr_m  <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW")
+                  `catch` (\(_ :: SomeException) -> return Nothing)
+    case addr_m of
+      Nothing   -> return Nothing
+      Just addr -> do handle  <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile"
+                                        $ createFile name
+                                                     gENERIC_READ
+                                                     fILE_SHARE_READ
+                                                     Nothing
+                                                     oPEN_EXISTING
+                                                     (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS)
+                                                     Nothing
+                      let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr
+                      path    <- Info.try "GetFinalPathName"
+                                    (\buf len -> fnPtr handle buf len 0) 512
+                                    `finally` closeHandle handle
+                      return $ Just path
+
+type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD
+
+foreign import WINDOWS_CCONV unsafe "dynamic"
+  makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath
 #else
 getBaseDir = return Nothing
 #endif