FIX #1280: getPermissions wasn't working on Vista

It turns out that _access() in the Windows C runtime used to ignore
the X_OK flag, in Vista it now returns an error.  After browsing the C
runtime sources, I discovered that _stat() has an almost but not quite
completely bogus implementation of the st_mode field, which lets us
implement a slightly less incorrect approximation to getPermissions than does
_access().

diff --git a/System/Directory.hs b/System/Directory.hs
index 1f624a1..e7affb6 100644 (file)
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -155,6 +155,29 @@ The operation may fail with:
 getPermissions :: FilePath -> IO Permissions
 getPermissions name = do
   withCString name $ \s -> do
+#ifdef mingw32_HOST_OS
+  -- stat() does a better job of guessing the permissions on Windows
+  -- than access() does.  e.g. for execute permission, it looks at the
+  -- filename extension :-)
+  --
+  -- I tried for a while to do this properly, using the Windows security API,
+  -- and eventually gave up.  getPermissions is a flawed API anyway. -- SimonM
+  allocaBytes sizeof_stat $ \ p_stat -> do
+  throwErrnoIfMinus1_ "getPermissions" $ c_stat s p_stat
+  mode <- st_mode p_stat
+  let read   = mode .&. s_IRUSR
+  let write  = mode .&. s_IWUSR
+  let exec   = mode .&. s_IXUSR
+  let is_dir = mode .&. s_IFDIR
+  return (
+    Permissions {
+      readable   = read  /= 0,
+      writable   = write /= 0,
+      executable = is_dir == 0 && exec /= 0,
+      searchable = is_dir /= 0 && exec /= 0
+    }
+   )
+#else
   read  <- c_access s r_OK
   write <- c_access s w_OK
   exec  <- c_access s x_OK
@@ -168,6 +191,7 @@ getPermissions name = do
       searchable = is_dir && exec == 0
     }
    )
+#endif
 
 {- |The 'setPermissions' operation sets the
 permissions for the file or directory.
@@ -849,6 +873,7 @@ foreign import ccall unsafe "__hscore_X_OK" x_OK :: CInt
 foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode
 foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode
 foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode
+foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode
 
 foreign import ccall unsafe "__hscore_long_path_size"
   long_path_size :: Int

diff --git a/include/HsDirectory.h b/include/HsDirectory.h
index 7185dc8..7f33f08 100644 (file)
--- a/include/HsDirectory.h
+++ b/include/HsDirectory.h
@@ -77,6 +77,7 @@ INLINE int __hscore_X_OK() { return X_OK; }
 INLINE mode_t __hscore_S_IRUSR() { return S_IRUSR; }
 INLINE mode_t __hscore_S_IWUSR() { return S_IWUSR; }
 INLINE mode_t __hscore_S_IXUSR() { return S_IXUSR; }
+INLINE mode_t __hscore_S_IFDIR() { return S_IFDIR; }
 #endif
 
 #if defined(__MINGW32__)