{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.InstallSymlink
-- Copyright   :  (c) Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Managing installing binaries with symlinks.
-----------------------------------------------------------------------------
module Distribution.Client.InstallSymlink (
    symlinkBinaries,
    symlinkBinary,
    trySymlink,
    promptRun
  ) where

import Distribution.Client.Compat.Prelude hiding (ioError)
import Prelude ()

import Distribution.Client.Types
         ( ConfiguredPackage(..), BuildOutcomes )
import Distribution.Client.Setup
         ( InstallFlags(installSymlinkBinDir) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)

import Distribution.Solver.Types.SourcePackage
import Distribution.Solver.Types.OptionalStanza

import Distribution.Package
         ( PackageIdentifier, Package(packageId), UnitId, installedUnitId )
import Distribution.Types.UnqualComponentName
import Distribution.Compiler
         ( CompilerId(..) )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
         ( PackageDescription )
import Distribution.PackageDescription.Configuration
         ( finalizePD )
import Distribution.Simple.Setup
         ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.Compiler
         ( Compiler, compilerInfo, CompilerInfo(..) )
import Distribution.System
         ( Platform )
import Distribution.Simple.Utils ( info, withTempDirectory )

import System.Directory
         ( canonicalizePath, getTemporaryDirectory, removeFile )
import System.FilePath
         ( (</>), splitPath, joinPath, isAbsolute )

import System.IO.Error
         ( isDoesNotExistError, ioError )
import Control.Exception
         ( assert )

import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink )
import Distribution.Client.Types.OverwritePolicy
import Distribution.Client.Init.Types ( DefaultPrompt(MandatoryPrompt) )
import Distribution.Client.Init.Prompt ( promptYesNo )

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8

-- | We would like by default to install binaries into some location that is on
-- the user's PATH. For per-user installations on Unix systems that basically
-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@
-- directory will be on the user's PATH. However some people are a bit nervous
-- about letting a package manager install programs into @~/bin/@.
--
-- A compromise solution is that instead of installing binaries directly into
-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@
-- and then create symlinks in @~/bin/@. We can be careful when setting up the
-- symlinks that we do not overwrite any binary that the user installed. We can
-- check if it was a symlink we made because it would point to the private dir
-- where we install our binaries. This means we can install normally without
-- worrying and in a later phase set up symlinks, and if that fails then we
-- report it to the user, but even in this case the package is still in an OK
-- installed state.
--
-- This is an optional feature that users can choose to use or not. It is
-- controlled from the config file. Of course it only works on POSIX systems
-- with symlinks so is not available to Windows users.
--
symlinkBinaries :: Platform -> Compiler
                -> OverwritePolicy
                -> ConfigFlags
                -> InstallFlags
                -> InstallPlan
                -> BuildOutcomes
                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
symlinkBinaries :: Platform
-> Compiler
-> OverwritePolicy
-> ConfigFlags
-> InstallFlags
-> InstallPlan
-> BuildOutcomes
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
symlinkBinaries Platform
platform Compiler
comp OverwritePolicy
overwritePolicy
                ConfigFlags
configFlags InstallFlags
installFlags
                InstallPlan
plan BuildOutcomes
buildOutcomes =
  case Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (InstallFlags -> Flag FilePath
installSymlinkBinDir InstallFlags
installFlags) of
    Maybe FilePath
Nothing            -> [(PackageIdentifier, UnqualComponentName, FilePath)]
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just FilePath
symlinkBinDir
           | [(ConfiguredPackage UnresolvedPkgLoc, PackageDescription,
  Executable)]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ConfiguredPackage UnresolvedPkgLoc, PackageDescription,
  Executable)]
exes -> [(PackageIdentifier, UnqualComponentName, FilePath)]
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
           | Bool
otherwise -> do
      FilePath
publicBinDir  <- FilePath -> IO FilePath
canonicalizePath FilePath
symlinkBinDir
--    TODO: do we want to do this here? :
--      createDirectoryIfMissing True publicBinDir
      ([Maybe (PackageIdentifier, UnqualComponentName, FilePath)]
 -> [(PackageIdentifier, UnqualComponentName, FilePath)])
-> IO [Maybe (PackageIdentifier, UnqualComponentName, FilePath)]
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (PackageIdentifier, UnqualComponentName, FilePath)]
-> [(PackageIdentifier, UnqualComponentName, FilePath)]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (PackageIdentifier, UnqualComponentName, FilePath)]
 -> IO [(PackageIdentifier, UnqualComponentName, FilePath)])
-> IO [Maybe (PackageIdentifier, UnqualComponentName, FilePath)]
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
forall a b. (a -> b) -> a -> b
$ [IO (Maybe (PackageIdentifier, UnqualComponentName, FilePath))]
-> IO [Maybe (PackageIdentifier, UnqualComponentName, FilePath)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        [ do FilePath
privateBinDir <- PackageDescription -> UnitId -> IO FilePath
pkgBinDir PackageDescription
pkg UnitId
ipid
             Bool
ok <- OverwritePolicy
-> FilePath -> FilePath -> FilePath -> FilePath -> IO Bool
symlinkBinary
                     OverwritePolicy
overwritePolicy
                     FilePath
publicBinDir  FilePath
privateBinDir
                     (UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
publicExeName) FilePath
privateExeName
             if Bool
ok
               then Maybe (PackageIdentifier, UnqualComponentName, FilePath)
-> IO (Maybe (PackageIdentifier, UnqualComponentName, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (PackageIdentifier, UnqualComponentName, FilePath)
forall a. Maybe a
Nothing
               else Maybe (PackageIdentifier, UnqualComponentName, FilePath)
-> IO (Maybe (PackageIdentifier, UnqualComponentName, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return ((PackageIdentifier, UnqualComponentName, FilePath)
-> Maybe (PackageIdentifier, UnqualComponentName, FilePath)
forall a. a -> Maybe a
Just (PackageIdentifier
pkgid, UnqualComponentName
publicExeName,
                                  FilePath
privateBinDir FilePath -> FilePath -> FilePath
</> FilePath
privateExeName))
        | (ConfiguredPackage UnresolvedPkgLoc
rpkg, PackageDescription
pkg, Executable
exe) <- [(ConfiguredPackage UnresolvedPkgLoc, PackageDescription,
  Executable)]
exes
        , let pkgid :: PackageIdentifier
pkgid  = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
              -- This is a bit dodgy; probably won't work for Backpack packages
              ipid :: UnitId
ipid = ConfiguredPackage UnresolvedPkgLoc -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ConfiguredPackage UnresolvedPkgLoc
rpkg
              publicExeName :: UnqualComponentName
publicExeName  = Executable -> UnqualComponentName
PackageDescription.exeName Executable
exe
              privateExeName :: FilePath
privateExeName = FilePath
prefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
publicExeName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
suffix
              prefix :: FilePath
prefix = PackageIdentifier -> UnitId -> PathTemplate -> FilePath
substTemplate PackageIdentifier
pkgid UnitId
ipid PathTemplate
prefixTemplate
              suffix :: FilePath
suffix = PackageIdentifier -> UnitId -> PathTemplate -> FilePath
substTemplate PackageIdentifier
pkgid UnitId
ipid PathTemplate
suffixTemplate ]
  where
    exes :: [(ConfiguredPackage UnresolvedPkgLoc, PackageDescription,
  Executable)]
exes =
      [ (ConfiguredPackage UnresolvedPkgLoc
cpkg, PackageDescription
pkg, Executable
exe)
      | InstallPlan.Configured ConfiguredPackage UnresolvedPkgLoc
cpkg <- InstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList InstallPlan
plan
      , case ConfiguredPackage UnresolvedPkgLoc
-> BuildOutcomes -> Maybe (Either BuildFailure BuildResult)
forall pkg failure result.
HasUnitId pkg =>
pkg
-> BuildOutcomes failure result -> Maybe (Either failure result)
InstallPlan.lookupBuildOutcome ConfiguredPackage UnresolvedPkgLoc
cpkg BuildOutcomes
buildOutcomes of
          Just (Right BuildResult
_success) -> Bool
True
          Maybe (Either BuildFailure BuildResult)
_                     -> Bool
False
      , let pkg :: PackageDescription
            pkg :: PackageDescription
pkg = ConfiguredPackage UnresolvedPkgLoc -> PackageDescription
forall loc. ConfiguredPackage loc -> PackageDescription
pkgDescription ConfiguredPackage UnresolvedPkgLoc
cpkg
      , Executable
exe <- PackageDescription -> [Executable]
PackageDescription.executables PackageDescription
pkg
      , BuildInfo -> Bool
PackageDescription.buildable (Executable -> BuildInfo
PackageDescription.buildInfo Executable
exe) ]

    pkgDescription :: ConfiguredPackage loc -> PackageDescription
pkgDescription (ConfiguredPackage InstalledPackageId
_ (SourcePackage PackageIdentifier
_ GenericPackageDescription
gpd loc
_ PackageDescriptionOverride
_)
                                      FlagAssignment
flags OptionalStanzaSet
stanzas ComponentDeps [ConfiguredId]
_) =
      case FlagAssignment
-> ComponentRequestedSpec
-> (Dependency -> Bool)
-> Platform
-> CompilerInfo
-> [PackageVersionConstraint]
-> GenericPackageDescription
-> Either [Dependency] (PackageDescription, FlagAssignment)
finalizePD FlagAssignment
flags (OptionalStanzaSet -> ComponentRequestedSpec
enableStanzas OptionalStanzaSet
stanzas)
             (Bool -> Dependency -> Bool
forall a b. a -> b -> a
const Bool
True)
             Platform
platform CompilerInfo
cinfo [] GenericPackageDescription
gpd of
        Left [Dependency]
_ -> FilePath -> PackageDescription
forall a. HasCallStack => FilePath -> a
error FilePath
"finalizePD ReadyPackage failed"
        Right (PackageDescription
desc, FlagAssignment
_) -> PackageDescription
desc

    -- This is sadly rather complicated. We're kind of re-doing part of the
    -- configuration for the package. :-(
    pkgBinDir :: PackageDescription -> UnitId -> IO FilePath
    pkgBinDir :: PackageDescription -> UnitId -> IO FilePath
pkgBinDir PackageDescription
pkg UnitId
ipid = do
      InstallDirTemplates
defaultDirs <- CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
InstallDirs.defaultInstallDirs
                       CompilerFlavor
compilerFlavor
                       (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ConfigFlags -> Flag Bool
configUserInstall ConfigFlags
configFlags))
                       (PackageDescription -> Bool
PackageDescription.hasLibs PackageDescription
pkg)
      let templateDirs :: InstallDirTemplates
templateDirs = (PathTemplate -> Flag PathTemplate -> PathTemplate)
-> InstallDirTemplates
-> InstallDirs (Flag PathTemplate)
-> InstallDirTemplates
forall a b c.
(a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c
InstallDirs.combineInstallDirs PathTemplate -> Flag PathTemplate -> PathTemplate
forall a. a -> Flag a -> a
fromFlagOrDefault
                           InstallDirTemplates
defaultDirs (ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs ConfigFlags
configFlags)
          absoluteDirs :: InstallDirs FilePath
absoluteDirs = PackageIdentifier
-> UnitId
-> CompilerInfo
-> CopyDest
-> Platform
-> InstallDirTemplates
-> InstallDirs FilePath
InstallDirs.absoluteInstallDirs
                           (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) UnitId
ipid
                           CompilerInfo
cinfo CopyDest
InstallDirs.NoCopyDest
                           Platform
platform InstallDirTemplates
templateDirs
      FilePath -> IO FilePath
canonicalizePath (InstallDirs FilePath -> FilePath
forall dir. InstallDirs dir -> dir
InstallDirs.bindir InstallDirs FilePath
absoluteDirs)

    substTemplate :: PackageIdentifier -> UnitId -> PathTemplate -> FilePath
substTemplate PackageIdentifier
pkgid UnitId
ipid = PathTemplate -> FilePath
InstallDirs.fromPathTemplate
                             (PathTemplate -> FilePath)
-> (PathTemplate -> PathTemplate) -> PathTemplate -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplateEnv -> PathTemplate -> PathTemplate
InstallDirs.substPathTemplate PathTemplateEnv
env
      where env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
InstallDirs.initialPathTemplateEnv PackageIdentifier
pkgid UnitId
ipid
                                                     CompilerInfo
cinfo Platform
platform

    fromFlagTemplate :: Flag PathTemplate -> PathTemplate
fromFlagTemplate = PathTemplate -> Flag PathTemplate -> PathTemplate
forall a. a -> Flag a -> a
fromFlagOrDefault (FilePath -> PathTemplate
InstallDirs.toPathTemplate FilePath
"")
    prefixTemplate :: PathTemplate
prefixTemplate   = Flag PathTemplate -> PathTemplate
fromFlagTemplate (ConfigFlags -> Flag PathTemplate
configProgPrefix ConfigFlags
configFlags)
    suffixTemplate :: PathTemplate
suffixTemplate   = Flag PathTemplate -> PathTemplate
fromFlagTemplate (ConfigFlags -> Flag PathTemplate
configProgSuffix ConfigFlags
configFlags)
    cinfo :: CompilerInfo
cinfo            = Compiler -> CompilerInfo
compilerInfo Compiler
comp
    (CompilerId CompilerFlavor
compilerFlavor Version
_) = CompilerInfo -> CompilerId
compilerInfoId CompilerInfo
cinfo

-- | Symlink binary.
--
-- The paths are take in pieces, so we can make relative link when possible.
--
symlinkBinary ::
  OverwritePolicy        -- ^ Whether to force overwrite an existing file
  -> FilePath            -- ^ The canonical path of the public bin dir eg
                         --   @/home/user/bin@
  -> FilePath            -- ^ The canonical path of the private bin dir eg
                         --   @/home/user/.cabal/bin@
  -> FilePath            -- ^ The name of the executable to go in the public bin
                         --   dir, eg @foo@
  -> String              -- ^ The name of the executable to in the private bin
                         --   dir, eg @foo-1.0@
  -> IO Bool             -- ^ If creating the symlink was successful. @False@ if
                         --   there was another file there already that we did
                         --   not own. Other errors like permission errors just
                         --   propagate as exceptions.
symlinkBinary :: OverwritePolicy
-> FilePath -> FilePath -> FilePath -> FilePath -> IO Bool
symlinkBinary OverwritePolicy
overwritePolicy FilePath
publicBindir FilePath
privateBindir FilePath
publicName FilePath
privateName = do
  SymlinkStatus
ok <- FilePath -> FilePath -> IO SymlinkStatus
targetOkToOverwrite (FilePath
publicBindir FilePath -> FilePath -> FilePath
</> FilePath
publicName)
                            (FilePath
privateBindir FilePath -> FilePath -> FilePath
</> FilePath
privateName)
  case SymlinkStatus
ok of
    SymlinkStatus
NotExists         -> IO Bool
mkLink
    SymlinkStatus
OkToOverwrite     -> IO Bool
overwrite
    SymlinkStatus
NotOurFile ->
      case OverwritePolicy
overwritePolicy of
        OverwritePolicy
NeverOverwrite  -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        OverwritePolicy
AlwaysOverwrite -> IO Bool
overwrite
        OverwritePolicy
PromptOverwrite -> IO Bool
maybeOverwrite
  where
    relativeBindir :: FilePath
relativeBindir = FilePath -> FilePath -> FilePath
makeRelative FilePath
publicBindir FilePath
privateBindir
    mkLink :: IO Bool
    mkLink :: IO Bool
mkLink = Bool
True Bool -> IO () -> IO Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FilePath -> FilePath -> IO ()
createFileLink (FilePath
relativeBindir FilePath -> FilePath -> FilePath
</> FilePath
privateName) (FilePath
publicBindir FilePath -> FilePath -> FilePath
</> FilePath
publicName)
    rmLink :: IO Bool
    rmLink :: IO Bool
rmLink = Bool
True Bool -> IO () -> IO Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FilePath -> IO ()
removeFile (FilePath
publicBindir FilePath -> FilePath -> FilePath
</> FilePath
publicName)
    overwrite :: IO Bool
    overwrite :: IO Bool
overwrite = IO Bool
rmLink IO Bool -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO Bool
mkLink
    maybeOverwrite :: IO Bool
    maybeOverwrite :: IO Bool
maybeOverwrite
      = FilePath -> IO Bool -> IO Bool
promptRun
        FilePath
"Existing file found while installing symlink. Do you want to overwrite that file? (y/n)"
        IO Bool
overwrite

promptRun :: String -> IO Bool -> IO Bool
promptRun :: FilePath -> IO Bool -> IO Bool
promptRun FilePath
s IO Bool
m = do
  Bool
a <- FilePath -> DefaultPrompt Bool -> IO Bool
forall (m :: * -> *).
Interactive m =>
FilePath -> DefaultPrompt Bool -> m Bool
promptYesNo FilePath
s DefaultPrompt Bool
forall t. DefaultPrompt t
MandatoryPrompt
  if Bool
a then IO Bool
m else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
a

-- | 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
-- be a symlink to our target (in which case we can assume ownership).
--
targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private
                                -- binary that we would like to create
                    -> FilePath -- ^ The canonical path of the private binary.
                                -- Use 'canonicalizePath' to make this.
                    -> IO SymlinkStatus
targetOkToOverwrite :: FilePath -> FilePath -> IO SymlinkStatus
targetOkToOverwrite FilePath
symlink FilePath
target = IO SymlinkStatus -> IO SymlinkStatus
handleNotExist (IO SymlinkStatus -> IO SymlinkStatus)
-> IO SymlinkStatus -> IO SymlinkStatus
forall a b. (a -> b) -> a -> b
$ do
  Bool
isLink <- FilePath -> IO Bool
pathIsSymbolicLink FilePath
symlink
  if Bool -> Bool
not Bool
isLink
    then SymlinkStatus -> IO SymlinkStatus
forall (m :: * -> *) a. Monad m => a -> m a
return SymlinkStatus
NotOurFile
    else do FilePath
target' <- FilePath -> IO FilePath
canonicalizePath (FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
getSymbolicLinkTarget FilePath
symlink
            -- This partially relies on canonicalizePath handling symlinks
            if FilePath
target FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
target'
              then SymlinkStatus -> IO SymlinkStatus
forall (m :: * -> *) a. Monad m => a -> m a
return SymlinkStatus
OkToOverwrite
              else SymlinkStatus -> IO SymlinkStatus
forall (m :: * -> *) a. Monad m => a -> m a
return SymlinkStatus
NotOurFile

  where
    handleNotExist :: IO SymlinkStatus -> IO SymlinkStatus
handleNotExist IO SymlinkStatus
action = IO SymlinkStatus
-> (IOException -> IO SymlinkStatus) -> IO SymlinkStatus
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO SymlinkStatus
action ((IOException -> IO SymlinkStatus) -> IO SymlinkStatus)
-> (IOException -> IO SymlinkStatus) -> IO SymlinkStatus
forall a b. (a -> b) -> a -> b
$ \IOException
ioexception ->
      -- If the target doesn't exist then there's no problem overwriting it!
      if IOException -> Bool
isDoesNotExistError IOException
ioexception
        then SymlinkStatus -> IO SymlinkStatus
forall (m :: * -> *) a. Monad m => a -> m a
return SymlinkStatus
NotExists
        else IOException -> IO SymlinkStatus
forall a. IOException -> IO a
ioError IOException
ioexception

data SymlinkStatus
   = NotExists     -- ^ The file doesn't exist so we can make a symlink.
   | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll
                   -- have to delete it first before we make a new symlink.
   | NotOurFile    -- ^ A file already exists and it is not one of our existing
                   -- symlinks (either because it is not a symlink or because
                   -- it points somewhere other than our managed space).
  deriving Int -> SymlinkStatus -> FilePath -> FilePath
[SymlinkStatus] -> FilePath -> FilePath
SymlinkStatus -> FilePath
(Int -> SymlinkStatus -> FilePath -> FilePath)
-> (SymlinkStatus -> FilePath)
-> ([SymlinkStatus] -> FilePath -> FilePath)
-> Show SymlinkStatus
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [SymlinkStatus] -> FilePath -> FilePath
$cshowList :: [SymlinkStatus] -> FilePath -> FilePath
show :: SymlinkStatus -> FilePath
$cshow :: SymlinkStatus -> FilePath
showsPrec :: Int -> SymlinkStatus -> FilePath -> FilePath
$cshowsPrec :: Int -> SymlinkStatus -> FilePath -> FilePath
Show

-- | Take two canonical paths and produce a relative path to get from the first
-- to the second, even if it means adding @..@ path components.
--
makeRelative :: FilePath -> FilePath -> FilePath
makeRelative :: FilePath -> FilePath -> FilePath
makeRelative FilePath
a FilePath
b = Bool -> FilePath -> FilePath
forall a. HasCallStack => Bool -> a -> a
assert (FilePath -> Bool
isAbsolute FilePath
a Bool -> Bool -> Bool
&& FilePath -> Bool
isAbsolute FilePath
b) (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
  let as :: [FilePath]
as = FilePath -> [FilePath]
splitPath FilePath
a
      bs :: [FilePath]
bs = FilePath -> [FilePath]
splitPath FilePath
b
      commonLen :: Int
commonLen = [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Bool] -> Int) -> [Bool] -> Int
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Bool -> Bool
forall a. a -> a
id ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath -> Bool)
-> [FilePath] -> [FilePath] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
(==) [FilePath]
as [FilePath]
bs
   in [FilePath] -> FilePath
joinPath ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [ FilePath
".." | FilePath
_  <- Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop Int
commonLen [FilePath]
as ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop Int
commonLen [FilePath]
bs

-- | 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 -> IO Bool
trySymlink Verbosity
verbosity = do
  FilePath
tmp <- IO FilePath
getTemporaryDirectory
  Verbosity
-> FilePath -> FilePath -> (FilePath -> IO Bool) -> IO Bool
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
tmp FilePath
"cabal-symlink-test" ((FilePath -> IO Bool) -> IO Bool)
-> (FilePath -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDirPath -> do
    let from :: FilePath
from = FilePath
tmpDirPath FilePath -> FilePath -> FilePath
</> FilePath
"file.txt"
    let to :: FilePath
to   = FilePath
tmpDirPath FilePath -> FilePath -> FilePath
</> FilePath
"file2.txt"

    -- create a file
    FilePath -> ByteString -> IO ()
BS.writeFile FilePath
from (FilePath -> ByteString
BS8.pack FilePath
"TEST")

    -- create a symbolic link
    let create :: IO Bool
        create :: IO Bool
create = do
          FilePath -> FilePath -> IO ()
createFileLink FilePath
from FilePath
to
          Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Symlinking seems to work"
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    IO Bool
create IO Bool -> (IOException -> IO Bool) -> IO Bool
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
exc -> do
      Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Symlinking doesn't seem to be working: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
exc
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False