Allow specifying default behaviour as a install-method flag input, ad…

…d documentation

Cabal/Distribution/Simple/Flag.hs

@@ -22,6 +22,7 @@ module Distribution.Simple.Flag (
   toFlag,
   fromFlag,
   fromFlagOrDefault,
+  flagElim,
   flagToMaybe,
   flagToList,
   maybeToFlag,
@@ -105,6 +106,11 @@ flagToMaybe :: Flag a -> Maybe a
 flagToMaybe (Flag x) = Just x
 flagToMaybe NoFlag   = Nothing
 
+-- | @since 3.4.0.0
+flagElim :: b -> (a -> b) -> Flag a -> b
+flagElim n _ NoFlag   = n
+flagElim _ f (Flag x) = f x
+
 flagToList :: Flag a -> [a]
 flagToList (Flag x) = [x]
 flagToList NoFlag   = []

Cabal/doc/nix-local-build.rst

@@ -559,12 +559,13 @@ repository, this command will build cabal-install HEAD and symlink the
 
     $ cabal v2-install exe:cabal
 
-Where symlinking is not possible (eg. on Windows), ``--install-method=copy``
-can be used:
+Where symlinking is not possible (eg. on some Windows versions) the ``copy``
+method is used by default. You can specify the install method
+by using ``--install-method`` flag:
 
 ::
 
-    $ cabal v2-install exe:cabal --install-method=copy --installdir=~/bin
+    $ cabal v2-install exe:cabal --install-method=copy --installdir=$HOME/bin
 
 Note that copied executables are not self-contained, since they might use
 data-files from the store.

cabal-install/Distribution/Client/CmdInstall.hs

@@ -85,10 +85,11 @@ import Distribution.Client.DistDirLayout
 import Distribution.Client.RebuildMonad
          ( runRebuild )
 import Distribution.Client.InstallSymlink
-         ( OverwritePolicy(..), symlinkBinary )
+         ( OverwritePolicy(..), symlinkBinary, trySymlink )
+import Distribution.Simple.Flag
+         ( fromFlagOrDefault, flagToMaybe, flagElim )
 import Distribution.Simple.Setup
-         ( Flag(..), HaddockFlags, TestFlags, BenchmarkFlags
-         , fromFlagOrDefault, flagToMaybe )
+         ( Flag(..), HaddockFlags, TestFlags, BenchmarkFlags )
 import Distribution.Solver.Types.SourcePackage
          ( SourcePackage(..) )
 import Distribution.Simple.Command
@@ -104,7 +105,7 @@ import Distribution.Simple.GHC
          , GhcEnvironmentFileEntry(..)
          , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )
 import Distribution.System
-         ( Platform )
+         ( Platform , buildOS, OS (Windows) )
 import Distribution.Types.UnitId
          ( UnitId )
 import Distribution.Types.UnqualComponentName
@@ -140,9 +141,6 @@ import System.Directory
          , removeFile, removeDirectory, copyFile )
 import System.FilePath
          ( (</>), (<.>), takeDirectory, takeBaseName )
-import System.Info
-         ( os )
-
 
 installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
                             , HaddockFlags, TestFlags, BenchmarkFlags
@@ -660,6 +658,10 @@ installExes verbosity baseCtx buildCtx platform compiler
                 pure <$> cinstInstalldir clientInstallFlags
   createDirectoryIfMissingVerbose verbosity False installdir
   warnIfNoExes verbosity buildCtx
+
+  installMethod <- flagElim defaultMethod return $
+    cinstInstallMethod clientInstallFlags
+
   let
     doInstall = installUnitExes
                   verbosity
@@ -670,13 +672,18 @@ installExes verbosity baseCtx buildCtx platform compiler
   where
     overwritePolicy = fromFlagOrDefault NeverOverwrite $
                       cinstOverwritePolicy clientInstallFlags
-    isWindows = System.Info.os == "mingw32"
+    isWindows = buildOS == Windows
+
+    -- This is in IO as we will make environment checks,
+    -- to decide which method is best
+    defaultMethod :: IO InstallMethod
     defaultMethod
-      -- Copy since windows doesn't support symlinks by default
-      | isWindows = InstallMethodCopy
-      | otherwise = InstallMethodSymlink
-    installMethod   = fromFlagOrDefault defaultMethod $
-                      cinstInstallMethod clientInstallFlags
+      -- Try symlinking in temporary directory, if it works default to
+      -- symlinking even on windows
+      | isWindows = do
+        symlinks <- trySymlink verbosity
+        return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
+      | otherwise = return InstallMethodSymlink
 
 -- | Install any built library by adding it to the default ghc environment
 installLibraries

cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs

@@ -81,7 +81,7 @@ clientInstallOptions _ =
     "How to install the executables."
     cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v })
     $ reqArg
-        "copy|symlink"
+        "default|copy|symlink"
         readInstallMethodFlag
         showInstallMethodFlag
   , option [] ["installdir"]
@@ -103,6 +103,7 @@ showOverwritePolicyFlag NoFlag                 = []
 
 readInstallMethodFlag :: ReadE (Flag InstallMethod)
 readInstallMethodFlag = ReadE $ \case
+  "default" -> Right $ NoFlag
   "copy"    -> Right $ Flag InstallMethodCopy
   "symlink" -> Right $ Flag InstallMethodSymlink
   method    -> Left  $ "'" <> method <> "' isn't a valid install-method"

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

@@ -1,13 +1,58 @@
 {-# 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, getSymbolicLinkTarget, pathIsSymbolicLink)
+#elif defined(MIN_VERSION_unix)
+import System.Posix.Files (createSymbolicLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink)
+#endif
+
+-------------------------------------------------------------------------------
+-- setModificationTime
+-------------------------------------------------------------------------------
+
+#if !MIN_VERSION_directory(1,2,3)
 
 setModificationTime :: FilePath -> UTCTime -> IO ()
 setModificationTime _fp _t = return ()
 
 #endif
+
+-------------------------------------------------------------------------------
+-- Symlink
+-------------------------------------------------------------------------------
+
+#if MIN_VERSION_directory(1,3,1)
+#elif defined(MIN_VERSION_unix)
+createFileLink :: FilePath -> FilePath -> IO ()
+createFileLink = createSymbolicLink
+
+pathIsSymbolicLink :: FilePath -> IO Bool
+pathIsSymbolicLink fp = do
+    status <- getSymbolicLinkStatus fp
+    return (isSymbolicLink status)
+
+getSymbolicLinkTarget :: FilePath -> IO FilePath
+getSymbolicLinkTarget = readSymbolicLink
+
+#else
+createFileLink :: FilePath -> FilePath -> IO ()
+createFileLink _ _ = fail "Symlinking feature not available"
+
+pathIsSymbolicLink :: FilePath -> IO Bool
+pathIsSymbolicLink _ = fail "Symlinking feature not available"
+
+getSymbolicLinkTarget :: FilePath -> IO FilePath
+getSymbolicLinkTarget _ = fail "Symlinking feature not available"
+#endif

cabal-install/Distribution/Client/InstallSymlink.hs

@@ -16,47 +16,9 @@ module Distribution.Client.InstallSymlink (
     OverwritePolicy(..),
     symlinkBinaries,
     symlinkBinary,
+    trySymlink,
   ) where
 
-#ifdef mingw32_HOST_OS
-
-import Distribution.Compat.Binary
-         ( Binary )
-import Distribution.Utils.Structured
-         ( Structured )
-
-import Distribution.Package (PackageIdentifier)
-import Distribution.Types.UnqualComponentName
-import Distribution.Client.InstallPlan (InstallPlan)
-import Distribution.Client.Types (BuildOutcomes)
-import Distribution.Client.Setup (InstallFlags)
-import Distribution.Simple.Setup (ConfigFlags)
-import Distribution.Simple.Compiler
-import Distribution.System
-import GHC.Generics (Generic)
-
-data OverwritePolicy = NeverOverwrite | AlwaysOverwrite
-  deriving (Show, Eq, Generic, Bounded, Enum)
-
-instance Binary OverwritePolicy
-instance Structured OverwritePolicy
-
-symlinkBinaries :: Platform -> Compiler
-                -> OverwritePolicy
-                -> ConfigFlags
-                -> InstallFlags
-                -> InstallPlan
-                -> BuildOutcomes
-                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
-symlinkBinaries _ _ _ _ _ _ _ = return []
-
-symlinkBinary :: OverwritePolicy
-              -> FilePath -> FilePath -> FilePath -> String
-              -> IO Bool
-symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows"
-
-#else
-
 import Distribution.Compat.Binary
          ( Binary )
 import Distribution.Utils.Structured
@@ -91,12 +53,11 @@ import Distribution.System
          ( Platform )
 import Distribution.Deprecated.Text
          ( display )
+import Distribution.Verbosity  ( Verbosity )
+import Distribution.Simple.Utils ( info, withTempDirectory )
 
-import System.Posix.Files
-         ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink
-         , removeLink )
 import System.Directory
-         ( canonicalizePath )
+         ( canonicalizePath, getTemporaryDirectory, removeFile )
 import System.FilePath
          ( (</>), splitPath, joinPath, isAbsolute )
 
@@ -111,6 +72,11 @@ 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
+
 data OverwritePolicy = NeverOverwrite | AlwaysOverwrite
   deriving (Show, Eq, Generic, Bounded, Enum)
 
@@ -246,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
@@ -260,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
@@ -296,4 +261,27 @@ makeRelative a b = assert (isAbsolute a && isAbsolute b) $
    in joinPath $ [ ".." | _  <- drop commonLen as ]
               ++ drop commonLen bs
 
-#endif
+-- | Try to make a symlink in a temporary directory.
+--
+-- If this works, we can try to symlink: even on Windows.
+--
+trySymlink :: Verbosity -> IO Bool
+trySymlink verbosity = do
+  tmp <- getTemporaryDirectory
+  withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do
+    let from = tmpDirPath </> "file.txt"
+    let to   = tmpDirPath </> "file2.txt"
+
+    -- create a file
+    BS.writeFile from (BS8.pack "TEST")
+
+    -- create a symbolic link
+    let create :: IO Bool
+        create = do
+          createFileLink from to
+          info verbosity $ "Symlinking seems to work"
+          return True
+
+    create `catchIO` \exc -> do
+      info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc
+      return False

cabal-install/cabal-install.cabal

@@ -356,7 +356,8 @@ executable cabal
         build-depends: resolv      >= 0.1.1 && < 0.2
 
     if os(windows)
-      build-depends: Win32 >= 2 && < 3
+      -- newer directory for symlinks
+      build-depends: Win32 >= 2 && < 3, directory >=1.3.1.0
     else
       build-depends: unix >= 2.5 && < 2.9
 

cabal-install/cabal-install.cabal.pp

@@ -58,7 +58,8 @@
         build-depends: resolv      >= 0.1.1 && < 0.2
 
     if os(windows)
-      build-depends: Win32 >= 2 && < 3
+      -- newer directory for symlinks
+      build-depends: Win32 >= 2 && < 3, directory >=1.3.1.0
     else
       build-depends: unix >= 2.5 && < 2.9