diff --git a/Cabal/Distribution/Simple/Flag.hs b/Cabal/Distribution/Simple/Flag.hs index 439e3cb4114..018a7288274 100644 --- a/Cabal/Distribution/Simple/Flag.hs +++ b/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 = [] diff --git a/Cabal/doc/nix-local-build.rst b/Cabal/doc/nix-local-build.rst index 1535cbb2b37..af854a94e12 100644 --- a/Cabal/doc/nix-local-build.rst +++ b/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. diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs index ba3a5f2965b..2fe38fa963b 100644 --- a/cabal-install/Distribution/Client/CmdInstall.hs +++ b/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 @@ -141,7 +142,6 @@ import System.Directory import System.FilePath ( (), (<.>), takeDirectory, takeBaseName ) - installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags , HaddockFlags, TestFlags, BenchmarkFlags , ClientInstallFlags @@ -658,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 @@ -668,8 +672,18 @@ installExes verbosity baseCtx buildCtx platform compiler where overwritePolicy = fromFlagOrDefault NeverOverwrite $ cinstOverwritePolicy clientInstallFlags - installMethod = fromFlagOrDefault InstallMethodSymlink $ - cinstInstallMethod clientInstallFlags + isWindows = buildOS == Windows + + -- This is in IO as we will make environment checks, + -- to decide which method is best + defaultMethod :: IO InstallMethod + defaultMethod + -- 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 diff --git a/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs index 868f6541eb5..8140424a78c 100644 --- a/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/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" diff --git a/cabal-install/Distribution/Client/Compat/Directory.hs b/cabal-install/Distribution/Client/Compat/Directory.hs index 0f9fc4218ed..3c0997377b8 100644 --- a/cabal-install/Distribution/Client/Compat/Directory.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs index 37ec68398ae..522f8dfc9d5 100644 --- a/cabal-install/Distribution/Client/InstallSymlink.hs +++ b/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 diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index c1a9dd7ffe3..7cade8ccf6f 100644 --- a/cabal-install/cabal-install.cabal +++ b/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 diff --git a/cabal-install/cabal-install.cabal.pp b/cabal-install/cabal-install.cabal.pp index 8e7c0b122a0..88df21625ab 100644 --- a/cabal-install/cabal-install.cabal.pp +++ b/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 diff --git a/cabal-install/changelog b/cabal-install/changelog index bc87f1035ba..ce63b4c9345 100644 --- a/cabal-install/changelog +++ b/cabal-install/changelog @@ -34,6 +34,7 @@ * Use `hackage-security-0.6` ([#6388](https://github.com/haskell/cabal/pull/6388)) * Other dependency upgrades + * On windows use copy as the default install method for executables 3.0.0.0 Mikhail Glushenkov August 2019 * `v2-haddock` fails on `haddock` failures (#5977)