[commit: ghc] ghc-8.0: Resolve symlinks when attempting to find GHC's lib folder on Windows (6c840d9)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/6c840d97b7997f08ca15cc9b31a6ad0f08cd3fbc/ghc

>---------------------------------------------------------------

commit 6c840d97b7997f08ca15cc9b31a6ad0f08cd3fbc
Author: Tamar Christina <tamar at zhox.com>
Date:   Sun Apr 17 17:11:02 2016 +0200

    Resolve symlinks when attempting to find GHC's lib folder on Windows
    
    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
    
    (cherry picked from commit a3922083e8f41fc236972564dc2978f2a2d4ec13)


>---------------------------------------------------------------

6c840d97b7997f08ca15cc9b31a6ad0f08cd3fbc
 compiler/main/SysTools.hs | 52 ++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 51 insertions(+), 1 deletion(-)

diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 4afb199..9423b00 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -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