Add full suite of symbolic link functions

  - createFileLink
  - createDirectoryLink
  - removeDirectoryLink
  - getSymbolicLinkTarget

TestUtils is now slightly simpler as a result.

Also fixed some symlink-related bugs (see changelog).

System/Directory.hs

@@ -73,7 +73,11 @@ module System.Directory
     , exeExtension
 
     -- * Symbolic links
+    , createFileLink
+    , createDirectoryLink
+    , removeDirectoryLink
     , pathIsSymbolicLink
+    , getSymbolicLinkTarget
 
     -- * Permissions
 
@@ -441,7 +445,7 @@ getDirectoryType :: FilePath -> IO DirectoryType
 getDirectoryType path =
   (`ioeAddLocation` "getDirectoryType") `modifyIOError` do
 #ifdef mingw32_HOST_OS
-    isDir <- withFileStatus "getDirectoryType" path isDirectory
+    isDir <- withSymbolicLinkStatus "getDirectoryType" path isDirectory
     if isDir
       then do
         isLink <- pathIsSymbolicLink path
@@ -1531,13 +1535,108 @@ doesFileExist name =
 #endif
    `catchIOError` \ _ -> return False
 
--- | Check whether the path refers to a symbolic link.  On Windows, this tests
--- for @FILE_ATTRIBUTE_REPARSE_POINT@.
+-- | Create a /file/ symbolic link.  The target path can be either absolute or
+-- relative and need not refer to an existing file.  The order of arguments
+-- follows the POSIX convention.
+--
+-- To remove an existing file symbolic link, use 'removeFile'.
+--
+-- Although the distinction between /file/ symbolic links and /directory/
+-- symbolic links does not exist on POSIX systems, on Windows this is an
+-- intrinsic property of every symbolic link and cannot be changed without
+-- recreating the link.  A file symbolic link that actually points to a
+-- directory will fail to dereference and vice versa.  Moreover, creating
+-- symbolic links on Windows requires privileges normally unavailable to users
+-- outside the Administrators group.  Portable programs that use symbolic
+-- links should take both into consideration.
+--
+-- On Windows, the function is implemented using @CreateSymbolicLink@ with
+-- @dwFlags@ set to zero.  On POSIX, the function uses @symlink@ and
+-- is therefore atomic.
+--
+-- Windows-specific errors: This operation may fail with 'permissionErrorType'
+-- if the user lacks the privileges to create symbolic links.  It may also
+-- fail with 'illegalOperationErrorType' if the file system does not support
+-- symbolic links.
+--
+-- @since 1.3.1.0
+createFileLink
+  :: FilePath                           -- ^ path to the target file
+  -> FilePath                           -- ^ path of the link to be created
+  -> IO ()
+createFileLink target link =
+  (`ioeAddLocation` "createFileLink") `modifyIOError` do
+#ifdef mingw32_HOST_OS
+    createSymbolicLink False target link
+#else
+    Posix.createSymbolicLink target link
+#endif
+
+-- | Create a /directory/ symbolic link.  The target path can be either
+-- absolute or relative and need not refer to an existing directory.  The
+-- order of arguments follows the POSIX convention.
+--
+-- To remove an existing directory symbolic link, use 'removeDirectoryLink'.
+--
+-- Although the distinction between /file/ symbolic links and /directory/
+-- symbolic links does not exist on POSIX systems, on Windows this is an
+-- intrinsic property of every symbolic link and cannot be changed without
+-- recreating the link.  A file symbolic link that actually points to a
+-- directory will fail to dereference and vice versa.  Moreover, creating
+-- symbolic links on Windows requires privileges normally unavailable to users
+-- outside the Administrators group.  Portable programs that use symbolic
+-- links should take both into consideration.
+--
+-- On Windows, the function is implemented using @CreateSymbolicLink@ with
+-- @dwFlags@ set to @SYMBOLIC_LINK_FLAG_DIRECTORY@.  On POSIX, this is an
+-- alias for 'createFileLink' and is therefore atomic.
+--
+-- Windows-specific errors: This operation may fail with 'permissionErrorType'
+-- if the user lacks the privileges to create symbolic links.  It may also
+-- fail with 'illegalOperationErrorType' if the file system does not support
+-- symbolic links.
+--
+-- @since 1.3.1.0
+createDirectoryLink
+  :: FilePath                           -- ^ path to the target directory
+  -> FilePath                           -- ^ path of the link to be created
+  -> IO ()
+createDirectoryLink target link =
+  (`ioeAddLocation` "createDirectoryLink") `modifyIOError` do
+#ifdef mingw32_HOST_OS
+    createSymbolicLink True target link
+#else
+    createFileLink target link
+#endif
+
+-- | Remove an existing /directory/ symbolic link.
+--
+-- On Windows, this is an alias for 'removeDirectory'.  On POSIX systems, this
+-- is an alias for 'removeFile'.
+--
+-- See also: 'removeFile', which can remove an existing /file/ symbolic link.
+--
+-- @since 1.3.1.0
+removeDirectoryLink :: FilePath -> IO ()
+removeDirectoryLink path =
+  (`ioeAddLocation` "removeDirectoryLink") `modifyIOError` do
+#ifdef mingw32_HOST_OS
+    removeDirectory path
+#else
+    removeFile path
+#endif
+
+-- | Check whether the path refers to a symbolic link.  An exception is thrown
+-- if the path does not exist or is inaccessible.
+--
+-- On Windows, this checks for @FILE_ATTRIBUTE_REPARSE_POINT@.  In addition to
+-- symbolic links, the function also returns true on junction points.  On
+-- POSIX systems, this checks for @S_IFLNK@.
 --
 -- @since 1.3.0.0
 pathIsSymbolicLink :: FilePath -> IO Bool
 pathIsSymbolicLink path =
-  (`ioeAddLocation` "getDirectoryType") `modifyIOError` do
+  (`ioeAddLocation` "pathIsSymbolicLink") `modifyIOError` do
 #ifdef mingw32_HOST_OS
     isReparsePoint <$> Win32.getFileAttributes path
   where
@@ -1550,6 +1649,28 @@ pathIsSymbolicLink path =
 isSymbolicLink :: FilePath -> IO Bool
 isSymbolicLink = pathIsSymbolicLink
 
+-- | Retrieve the target path of either a file or directory symbolic link.
+-- The returned path may not be absolute, may not exist, and may not even be a
+-- valid path.
+--
+-- On Windows systems, this calls @DeviceIoControl@ with
+-- @FSCTL_GET_REPARSE_POINT@.  In addition to symbolic links, the function
+-- also works on junction points.  On POSIX systems, this calls `readlink`.
+--
+-- Windows-specific errors: This operation may fail with
+-- 'illegalOperationErrorType' if the file system does not support symbolic
+-- links.
+--
+-- @since 1.3.1.0
+getSymbolicLinkTarget :: FilePath -> IO FilePath
+getSymbolicLinkTarget path =
+  (`ioeAddLocation` "getSymbolicLinkTarget") `modifyIOError` do
+#ifdef mingw32_HOST_OS
+    readSymbolicLink path
+#else
+    Posix.readSymbolicLink path
+#endif
+
 #ifdef mingw32_HOST_OS
 -- | Open the handle of an existing file or directory.
 openFileHandle :: String -> Win32.AccessMode -> IO Win32.HANDLE
@@ -1751,8 +1872,14 @@ posixToWindowsTime t = Win32.FILETIME $
 
 #ifdef mingw32_HOST_OS
 withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileStatus loc name f = do
-  modifyIOError (`ioeSetFileName` name) $
+withFileStatus loc name f =
+  modifyIOError (`ioeSetFileName` name) $ do
+    name' <- getFinalPathName name
+    withSymbolicLinkStatus loc name' f
+
+withSymbolicLinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
+withSymbolicLinkStatus loc name f = do
+  modifyIOError (`ioeSetFileName` name) $ do
     allocaBytes sizeof_stat $ \p ->
       withFilePath (fileNameEndClean name) $ \s -> do
         throwErrnoIfMinus1Retry_ loc (c_stat s p)

System/Directory/Internal/Windows.hsc

@@ -26,7 +26,8 @@ module System.Directory.Internal.Windows where
 #include <System/Directory/Internal/windows.h>
 import Prelude ()
 import System.Directory.Internal.Prelude
-import System.FilePath (isRelative, normalise, splitDirectories)
+import System.FilePath (isPathSeparator, isRelative, normalise,
+                        pathSeparator, splitDirectories)
 import qualified Data.List as List
 import qualified System.Win32 as Win32
 
@@ -258,6 +259,14 @@ readSymbolicLink path = modifyIOError (`ioeSetFileName` path) $ do
       Win32.fILE_SHARE_WRITE
     strip sn = fromMaybe sn (List.stripPrefix "\\??\\" sn)
 
+-- | Normalise the path separators and prepend the @"\\\\?\\"@ prefix if
+-- necessary or possible.
+normaliseSeparators :: FilePath -> FilePath
+normaliseSeparators path
+  | isRelative path = normaliseSep <$> path
+  | otherwise = toExtendedLengthPath path
+  where normaliseSep c = if isPathSeparator c then pathSeparator else c
+
 -- | Add the @"\\\\?\\"@ prefix if necessary or possible.
 -- The path remains unchanged if the prefix is not added.
 toExtendedLengthPath :: FilePath -> FilePath
@@ -309,9 +318,59 @@ getPathNameWith cFunc = do
       r' <- getPathNameWithLen len
       case r' of
         Right s -> pure s
-        Left _ -> ioError (mkIOError OtherError "" Nothing Nothing
+        Left _ -> throwIO (mkIOError OtherError "" Nothing Nothing
                            `ioeSetErrorString` "path changed unexpectedly")
 
+win32_createSymbolicLink :: String -> String -> Bool -> IO ()
+win32_createSymbolicLink link _target _isDir =
+#ifdef HAVE_CREATESYMBOLICLINKW
+  withCWString link $ \ pLink ->
+  withCWString _target $ \ pTarget -> do
+    let flags = if _isDir then win32_sYMBOLIC_LINK_FLAG_DIRECTORY else 0
+    status <- c_CreateSymbolicLink pLink pTarget flags
+    if status == 0
+      then do
+        e <- Win32.getLastError
+        case () of
+          _ | e == win32_eRROR_INVALID_FUNCTION -> do
+                let msg = "Incorrect function. The underlying file system " <>
+                          "might not support symbolic links."
+                throwIO (mkIOError illegalOperationErrorType
+                                   "CreateSymbolicLink" Nothing (Just link)
+                         `ioeSetErrorString` msg)
+            | e == win32_eRROR_PRIVILEGE_NOT_HELD -> do
+                let msg = "A required privilege is not held by the client. " <>
+                          "Creating symbolic links usually requires " <>
+                          "administrative rights."
+                throwIO (mkIOError permissionErrorType "CreateSymbolicLink"
+                                   Nothing (Just link)
+                         `ioeSetErrorString` msg)
+            | otherwise -> Win32.failWith "CreateSymbolicLink" e
+      else return ()
+  where
+
+win32_eRROR_PRIVILEGE_NOT_HELD :: Win32.ErrCode
+win32_eRROR_PRIVILEGE_NOT_HELD = 0x522
+
+win32_sYMBOLIC_LINK_FLAG_DIRECTORY :: Win32.DWORD
+win32_sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1
+
+foreign import WINAPI unsafe "windows.h CreateSymbolicLinkW"
+  c_CreateSymbolicLink
+    :: Ptr CWchar -> Ptr CWchar -> Win32.DWORD -> IO Win32.BYTE
+
+#else
+  throwIO . (`ioeSetErrorString` unsupportedErrorMsg) $
+               mkIOError UnsupportedOperation "CreateSymbolicLink"
+                         Nothing (Just link)
+  where unsupportedErrorMsg = "Not supported on Windows XP or older"
+#endif
+
+createSymbolicLink :: Bool -> String -> String -> IO ()
+createSymbolicLink isDir target link = do
+  -- toExtendedLengthPath ensures the target gets normalised properly
+  win32_createSymbolicLink link (normaliseSeparators target) isDir
+
 foreign import ccall unsafe "_wchmod"
   c_wchmod :: CWString -> CMode -> IO CInt
 

appveyor.yml

@@ -13,7 +13,8 @@ environment:
     STACK: stack --skip-msys --resolver lts-5
   - DEPS: Win32-2.3.0.1
     STACK: stack --skip-msys --resolver lts-2
-    PREBUILD: sed -i.bak /GetFinalPathNameByHandleW/d configure.ac
+    PREBUILD: sed -i.bak -e /CreateSymbolicLinkW/d
+                         -e /GetFinalPathNameByHandleW/d configure.ac
 cache:
 - "%STACK_ROOT%"
 install:

changelog.md

@@ -1,13 +1,29 @@
 Changelog for the [`directory`][1] package
 ==========================================
 
-## 1.3.0.3 (March 2017)
+## 1.3.1.0 (March 2017)
 
   * `findFile` (and similar functions): when an absolute path is given, the
     list of search directories is now completely ignored.  Previously, if the
     list was empty, `findFile` would always fail.
     ([#72](https://github.com/haskell/directory/issues/72))
 
+  * For symbolic links on Windows, the following functions had previously
+    interpreted paths as referring to the links themselves rather than their
+    targets.  This was inconsistent with other platforms and has been fixed.
+      * `getFileSize`
+      * `doesPathExist`
+      * `doesDirectoryExist`
+      * `doesFileExist`
+
+  * Fix incorrect location info in errors from `pathIsSymbolicLink`.
+
+  * Add functions for symbolic link manipulation:
+      * `createFileLink`
+      * `createDirectoryLink`
+      * `removeDirectoryLink`
+      * `getSymbolicLinkTarget`
+
 ## 1.3.0.2 (February 2017)
 
   * [optimization] Increase internal buffer size of `copyFile`

configure.ac

@@ -31,6 +31,7 @@ AC_PROG_CC()
 AC_CHECK_HEADERS([fcntl.h limits.h sys/types.h sys/stat.h time.h])
 
 AC_CHECK_FUNCS([utimensat])
+AC_CHECK_FUNCS([CreateSymbolicLinkW])
 AC_CHECK_FUNCS([GetFinalPathNameByHandleW])
 
 # EXTEXT is defined automatically by AC_PROG_CC;

directory.cabal

@@ -1,5 +1,5 @@
 name:           directory
-version:        1.3.0.3
+version:        1.3.1.0
 -- NOTE: Don't forget to update ./changelog.md
 license:        BSD3
 license-file:   LICENSE

tests/CanonicalizePath.hs

@@ -4,10 +4,6 @@ module CanonicalizePath where
 import System.FilePath ((</>), dropFileName, dropTrailingPathSeparator,
                         normalise, takeFileName)
 import TestUtils
-#ifdef mingw32_HOST_OS
-import System.Directory.Internal (win32_getFinalPathNameByHandle)
-import qualified System.Win32 as Win32
-#endif
 
 main :: TestEnv -> IO ()
 main _t = do
@@ -68,38 +64,18 @@ main _t = do
   T(expectEq) () fooNon fooNon7
   T(expectEq) () fooNon fooNon8
 
-  supportsSymbolicLinks <- do
-#ifdef mingw32_HOST_OS
-    hasSymbolicLinkPrivileges <-
-      (True <$ createSymbolicLink "_symlinktest_src" "_symlinktest_dst")
-        -- only test if symbolic links can be created
-        -- (usually disabled on Windows by group policy)
-        `catchIOError` \ e ->
-          if isPermissionError e
-          then pure False
-          else ioError e
-
-    supportsGetFinalPathNameByHandle <-
-      (True <$ win32_getFinalPathNameByHandle Win32.nullHANDLE 0)
-        `catchIOError` \ e ->
-          case ioeGetErrorType e of
-            UnsupportedOperation -> pure False
-            _ -> pure True
-
-    pure (hasSymbolicLinkPrivileges && supportsGetFinalPathNameByHandle)
-#else
-    pure True
-#endif
-
+  supportsSymbolicLinks <- supportsSymlinks
   when supportsSymbolicLinks $ do
 
     let barQux = dot </> "bar" </> "qux"
 
-    createSymbolicLink "../bar" "foo/bar"
+    -- note: this also checks that "../bar" gets normalized to "..\\bar"
+    --       since Windows does not like "/" in symbolic links targets
+    createFileLink "../bar" "foo/bar"
     T(expectEq) () bar =<< canonicalizePath "foo/bar"
     T(expectEq) () barQux =<< canonicalizePath "foo/bar/qux"
 
-    createSymbolicLink "foo" "lfoo"
+    createDirectoryLink "foo" "lfoo"
     T(expectEq) () foo =<< canonicalizePath "lfoo"
     T(expectEq) () foo =<< canonicalizePath "lfoo/"
     T(expectEq) () bar =<< canonicalizePath "lfoo/bar"