[commit: ghc] ghc-8.2: Fix decomposition error on Windows (625bea0)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/625bea009ed72b8a1ce981acd031799d32e4a944/ghc

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

commit 625bea009ed72b8a1ce981acd031799d32e4a944
Author: Tamar Christina <tamar at zhox.com>
Date:   Tue Aug 29 22:59:38 2017 +0100

    Fix decomposition error on Windows
    
    Summary:
    Fix the path decomposition error that occurs when the Symlink resolver
    fails. `Win32.try` throws an exception, so catch it and assume the path
    isn't a symlink to use the old behavior.
    
    Test Plan: ./validate
    
    Reviewers: austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie
    
    GHC Trac Issues: #14159
    
    Differential Revision: https://phabricator.haskell.org/D3891
    
    (cherry picked from commit 3c6b2fc3b5ca11a5410405664e4640767ef941dd)


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

625bea009ed72b8a1ce981acd031799d32e4a944
 compiler/main/SysTools.hs | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 5601e2a..eaeb856 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -1529,9 +1529,18 @@ getFinalPath name = do
                                                      (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS)
                                                      Nothing
                       let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr
-                      path    <- Win32.try "GetFinalPathName"
+                      -- First try to resolve the path to get the actual path
+                      -- of any symlinks or other file system redirections that
+                      -- may be in place. However this function can fail, and in
+                      -- the event it does fail, we need to try using the
+                      -- original path and see if we can decompose that.
+                      -- If the call fails Win32.try will raise an exception
+                      -- that needs to be caught. See #14159
+                      path    <- (Win32.try "GetFinalPathName"
                                     (\buf len -> fnPtr handle buf len 0) 512
-                                    `finally` closeHandle handle
+                                    `finally` closeHandle handle)
+                                `catch`
+                                 (\(_ :: IOException) -> return name)
                       return $ Just path
 
 type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD