Commit a3922083 authored by Tamar Christina's avatar Tamar Christina

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
parent 177aec69
......@@ -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
......
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