[commit: packages/directory] master: Add isSymbolicLink (28b981d)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/28b981db6354e575e342477fd8ecd1ce1ea6cacd/directory

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

commit 28b981db6354e575e342477fd8ecd1ce1ea6cacd
Author: Phil Ruffwind <rf at rufflewind.com>
Date:   Thu Apr 14 05:33:58 2016 -0400

    Add isSymbolicLink


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

28b981db6354e575e342477fd8ecd1ce1ea6cacd
 System/Directory.hs     | 34 ++++++++++++++++++++++++++++------
 changelog.md            |  2 ++
 directory.cabal         |  1 +
 tests/IsSymbolicLink.hs | 23 +++++++++++++++++++++++
 tests/Main.hs           |  2 ++
 5 files changed, 56 insertions(+), 6 deletions(-)

diff --git a/System/Directory.hs b/System/Directory.hs
index 7e5edb1..ef97bcd 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -66,6 +66,9 @@ module System.Directory
     , doesFileExist
     , doesDirectoryExist
 
+    -- * Symbolic links
+    , isSymbolicLink
+
     -- * Permissions
 
     -- $permissions
@@ -487,12 +490,15 @@ getDirectoryType :: FilePath -> IO DirectoryType
 getDirectoryType path =
   (`ioeSetLocation` "getDirectoryType") `modifyIOError` do
 #ifdef mingw32_HOST_OS
-    classify <$> Win32.getFileAttributes path
-    where fILE_ATTRIBUTE_REPARSE_POINT = 0x400
-          classify attr
-            | attr .&. Win32.fILE_ATTRIBUTE_DIRECTORY == 0 = NotDirectory
-            | attr .&. fILE_ATTRIBUTE_REPARSE_POINT   == 0 = Directory
-            | otherwise                                    = DirectoryLink
+    isDir <- withFileStatus "getDirectoryType" name isDirectory
+    if isDir
+      then do
+        isLink <- isSymbolicLink path
+        if isLink
+          then return DirectoryLink
+          else return Directory
+      else do
+        return NotDirectory
 #else
     stat <- Posix.getSymbolicLinkStatus path
     return $ if Posix.isDirectory stat
@@ -1386,6 +1392,22 @@ doesFileExist name =
 #endif
    `catchIOError` \ _ -> return False
 
+-- | Check whether the path refers to a symbolic link.  On Windows, this tests
+-- for @FILE_ATTRIBUTE_REPARSE_POINT at .
+--
+-- @since 1.2.6.0
+isSymbolicLink :: FilePath -> IO Bool
+isSymbolicLink path =
+  (`ioeSetLocation` "getDirectoryType") `modifyIOError` do
+#ifdef mingw32_HOST_OS
+    isReparsePoint <$> Win32.getFileAttributes path
+  where
+    fILE_ATTRIBUTE_REPARSE_POINT = 0x400
+    isReparsePoint attr = attr .&. fILE_ATTRIBUTE_REPARSE_POINT /= 0
+#else
+    Posix.isSymbolicLink <$> Posix.getSymbolicLinkStatus path
+#endif
+
 #ifdef mingw32_HOST_OS
 -- | Open the handle of an existing file or directory.
 openFileHandle :: String -> Win32.AccessMode -> IO Win32.HANDLE
diff --git a/changelog.md b/changelog.md
index f917252..d047bd4 100644
--- a/changelog.md
+++ b/changelog.md
@@ -15,6 +15,8 @@ Changelog for the [`directory`][1] package
   * Improve error message of `removeDirectoryRecursive` when used on a
     directory symbolic link on Windows.
 
+  * Add `isSymbolicLink`
+
 ## 1.2.5.1 (February 2015)
 
   * Improve error message of `getCurrentDirectory` when the current working
diff --git a/directory.cabal b/directory.cabal
index 3af7a70..8fc1a40 100644
--- a/directory.cabal
+++ b/directory.cabal
@@ -100,6 +100,7 @@ test-suite test
         GetDirContents002
         GetHomeDirectory001
         GetPermissions001
+        IsSymbolicLink
         RemoveDirectoryRecursive001
         RenameFile001
         Safe
diff --git a/tests/IsSymbolicLink.hs b/tests/IsSymbolicLink.hs
new file mode 100644
index 0000000..3f39e55
--- /dev/null
+++ b/tests/IsSymbolicLink.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE CPP #-}
+module IsSymbolicLink where
+#include "util.inl"
+import System.Directory
+import Control.Monad (when)
+#ifdef mingw32_HOST_OS
+import System.IO.Error (catchIOError, isPermissionError)
+#endif
+import TestUtils
+
+main :: TestEnv -> IO ()
+main _t = do
+  success <- (createSymbolicLink "x" "y" >> return True)
+#ifdef mingw32_HOST_OS
+    -- only test if symbolic links can be created
+    -- (usually disabled on Windows by group policy)
+    `catchIOError` \ e ->
+      if isPermissionError e
+      then return False
+      else ioError e
+#endif
+  when success $
+    T(expect) () =<< isSymbolicLink "y"
diff --git a/tests/Main.hs b/tests/Main.hs
index 19c6c28..65127f6 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -15,6 +15,7 @@ import qualified GetDirContents001
 import qualified GetDirContents002
 import qualified GetHomeDirectory001
 import qualified GetPermissions001
+import qualified IsSymbolicLink
 import qualified RemoveDirectoryRecursive001
 import qualified RenameFile001
 import qualified Safe
@@ -38,6 +39,7 @@ main = T.testMain $ \ _t -> do
   T.isolatedRun _t "GetDirContents002" GetDirContents002.main
   T.isolatedRun _t "GetHomeDirectory001" GetHomeDirectory001.main
   T.isolatedRun _t "GetPermissions001" GetPermissions001.main
+  T.isolatedRun _t "IsSymbolicLink" IsSymbolicLink.main
   T.isolatedRun _t "RemoveDirectoryRecursive001" RemoveDirectoryRecursive001.main
   T.isolatedRun _t "RenameFile001" RenameFile001.main
   T.isolatedRun _t "Safe" Safe.main