WIP

cabal-install/Distribution/Client/Compat/Directory.hs

@@ -1,13 +1,36 @@
 {-# LANGUAGE CPP #-}
-module Distribution.Client.Compat.Directory (setModificationTime) where
+module Distribution.Client.Compat.Directory (
+    setModificationTime,
+    createFileLink,
+    pathIsSymbolicLink,
+    getSymbolicLinkTarget,
+    ) where
 
 #if MIN_VERSION_directory(1,2,3)
 import System.Directory (setModificationTime)
 #else
-
 import Data.Time.Clock (UTCTime)
+#endif
+
+#if MIN_VERSION_directory(1,3,1)
+import System.Directory (createFileLink, pathIsSymbolicLink, getSymbolicLinkTarget)
+#else
+import System.Posix.Files (getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink, removeLink)
+#endif
+
+-------------------------------------------------------------------------------
+-- setModificationTime
+-------------------------------------------------------------------------------
+
+#if !MIN_VERSION_directory(1,2,3)
 
 setModificationTime :: FilePath -> UTCTime -> IO ()
 setModificationTime _fp _t = return ()
 
 #endif
+
+-------------------------------------------------------------------------------
+-- Symlink
+-------------------------------------------------------------------------------
+
+-- TODO

cabal-install/Distribution/Client/InstallSymlink.hs

@@ -56,11 +56,8 @@ import Distribution.Deprecated.Text
 import Distribution.Verbosity  ( Verbosity )
 import Distribution.Simple.Utils ( info, withTempDirectory )
 
-import System.Posix.Files
-         ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink
-         , removeLink )
 import System.Directory
-         ( canonicalizePath, getTemporaryDirectory )
+         ( canonicalizePath, getTemporaryDirectory, removeFile )
 import System.FilePath
          ( (</>), splitPath, joinPath, isAbsolute )
 
@@ -75,6 +72,8 @@ import Data.Maybe
 import GHC.Generics
          ( Generic )
 
+import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink )
+
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS8
 
@@ -213,9 +212,8 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName
         AlwaysOverwrite -> rmLink >> mkLink >> return True
   where
     relativeBindir = makeRelative publicBindir privateBindir
-    mkLink = createSymbolicLink (relativeBindir </> privateName)
-                                (publicBindir   </> publicName)
-    rmLink = removeLink (publicBindir </> publicName)
+    mkLink = createFileLink (relativeBindir </> privateName) (publicBindir   </> publicName)
+    rmLink = removeFile (publicBindir </> publicName)
 
 -- | Check a file path of a symlink that we would like to create to see if it
 -- is OK. For it to be OK to overwrite it must either not already exist yet or
@@ -227,11 +225,11 @@ targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private
                                 -- Use 'canonicalizePath' to make this.
                     -> IO SymlinkStatus
 targetOkToOverwrite symlink target = handleNotExist $ do
-  status <- getSymbolicLinkStatus symlink
-  if not (isSymbolicLink status)
+  isLink <- pathIsSymbolicLink symlink
+  if not isLink
     then return NotOurFile
-    else do target' <- canonicalizePath symlink
-            -- This relies on canonicalizePath handling symlinks
+    else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink
+            -- This partially relies on canonicalizePath handling symlinks
             if target == target'
               then return OkToOverwrite
               else return NotOurFile
@@ -280,7 +278,7 @@ trySymlink verbosity = do
     -- create a symbolic link
     let create :: IO Bool
         create = do
-          createSymbolicLink from to
+          createFileLink from to
           info verbosity $ "Symlinking seems to work"
           return True