From c96f47e13aec9538cf517f6986aca865e59ace72 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 31 Jan 2020 15:45:40 +0200 Subject: [PATCH] Allow specifying default behaviour as a install-method flag input, add documentation --- Cabal/Distribution/Simple/Flag.hs | 6 ++ Cabal/doc/nix-local-build.rst | 7 +- .../Distribution/Client/CmdInstall.hs | 33 +++++---- .../Client/CmdInstall/ClientInstallFlags.hs | 3 +- .../Distribution/Client/InstallSymlink.hs | 72 ++++++++----------- 5 files changed, 63 insertions(+), 58 deletions(-) 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 cea3d120bc9..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 @@ -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 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/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs index 37ec68398ae..29225ade1d2 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,14 @@ 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 ) import System.FilePath ( (), splitPath, joinPath, isAbsolute ) @@ -111,6 +75,9 @@ import Data.Maybe import GHC.Generics ( Generic ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + data OverwritePolicy = NeverOverwrite | AlwaysOverwrite deriving (Show, Eq, Generic, Bounded, Enum) @@ -296,4 +263,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 + createSymbolicLink 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