Commit 2a9534a2 authored by Oleg Grenrus's avatar Oleg Grenrus

Allow specifying default behaviour as a install-method flag input, add documentation

parent 5f3f15f1
......@@ -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 = []
......
......@@ -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.
......
......@@ -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
......
......@@ -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"
......
{-# 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
......@@ -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
......@@ -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
......
......@@ -58,7 +58,8 @@ Version: 3.3.0.0
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment