{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- 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
  ( Symlink (..)
  , symlinkBinaries
  , symlinkBinary
  , symlinkableBinary
  , trySymlink
  , promptRun
  ) where

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

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

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

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

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

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

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

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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just FilePath
symlinkBinDir
        | [(ConfiguredPackage UnresolvedPkgLoc, PackageDescription,
  Executable)]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ConfiguredPackage UnresolvedPkgLoc, PackageDescription,
  Executable)]
exes -> [(PackageIdentifier, UnqualComponentName, FilePath)]
-> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
forall a. a -> IO a
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 a b. (a -> b) -> IO a -> IO b
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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
                [ do
                  FilePath
privateBinDir <- PackageDescription -> UnitId -> IO FilePath
pkgBinDir PackageDescription
pkg UnitId
ipid
                  Bool
ok <-
                    Symlink -> IO Bool
symlinkBinary
                      ( OverwritePolicy
-> FilePath -> FilePath -> FilePath -> FilePath -> Symlink
Symlink
                          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 a. a -> IO a
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 a. a -> IO a
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. (?callStack::CallStack) => 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

-- | A record needed to either check if a symlink is possible or to create a
-- symlink. Also used if copying instead of symlinking.
data Symlink = Symlink
  { Symlink -> OverwritePolicy
overwritePolicy :: OverwritePolicy
  -- ^ Whether to force overwrite an existing file.
  , Symlink -> FilePath
publicBindir :: FilePath
  -- ^ The canonical path of the public bin dir eg @/home/user/bin@.
  , Symlink -> FilePath
privateBindir :: FilePath
  -- ^ The canonical path of the private bin dir eg @/home/user/.cabal/bin@.
  , Symlink -> FilePath
publicName :: FilePath
  -- ^ The name of the executable to go in the public bin dir, eg @foo@.
  , Symlink -> FilePath
privateName :: String
  -- ^ The name of the executable to in the private bin dir, eg @foo-1.0@.
  }

-- | After checking if a target is writeable given the overwrite policy,
-- dispatch to an appropriate action;
--  * @onMissing@ if the target doesn't exist
--  * @onOverwrite@ if the target exists and we are allowed to overwrite it
--  * @onNever@ if the target exists and we are never allowed to overwrite it
--  * @onPrompt@ if the target exists and we are allowed to overwrite after prompting
onSymlinkBinary
  :: IO a
  -- ^ Missing action
  -> IO a
  -- ^ Overwrite action
  -> IO a
  -- ^ Never action
  -> IO a
  -- ^ Prompt action
  -> Symlink
  -> IO a
onSymlinkBinary :: forall a. IO a -> IO a -> IO a -> IO a -> Symlink -> IO a
onSymlinkBinary IO a
onMissing IO a
onOverwrite IO a
onNever IO a
onPrompt Symlink{FilePath
OverwritePolicy
overwritePolicy :: Symlink -> OverwritePolicy
publicBindir :: Symlink -> FilePath
privateBindir :: Symlink -> FilePath
publicName :: Symlink -> FilePath
privateName :: Symlink -> FilePath
overwritePolicy :: OverwritePolicy
publicBindir :: FilePath
privateBindir :: FilePath
publicName :: FilePath
privateName :: FilePath
..} = 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 a
onMissing
    SymlinkStatus
OkToOverwrite -> IO a
onOverwrite
    SymlinkStatus
NotOurFile ->
      case OverwritePolicy
overwritePolicy of
        OverwritePolicy
NeverOverwrite -> IO a
onNever
        OverwritePolicy
AlwaysOverwrite -> IO a
onOverwrite
        OverwritePolicy
PromptOverwrite -> IO a
onPrompt

-- | Can we symlink a binary?
--
-- @True@ if creating the symlink would be succeed, being optimistic that the user will
-- agree if prompted to overwrite.
symlinkableBinary :: Symlink -> IO Bool
symlinkableBinary :: Symlink -> IO Bool
symlinkableBinary = IO Bool -> IO Bool -> IO Bool -> IO Bool -> Symlink -> IO Bool
forall a. IO a -> IO a -> IO a -> IO a -> Symlink -> IO a
onSymlinkBinary (Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) (Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) (Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

-- | Symlink binary.
--
-- The paths are take in pieces, so we can make relative link when possible.
-- @True@ 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 :: Symlink -> IO Bool
symlinkBinary :: Symlink -> IO Bool
symlinkBinary inputs :: Symlink
inputs@Symlink{FilePath
publicBindir :: Symlink -> FilePath
publicBindir :: FilePath
publicBindir, FilePath
privateBindir :: Symlink -> FilePath
privateBindir :: FilePath
privateBindir, FilePath
publicName :: Symlink -> FilePath
publicName :: FilePath
publicName, FilePath
privateName :: Symlink -> FilePath
privateName :: FilePath
privateName} = do
  IO Bool -> IO Bool -> IO Bool -> IO Bool -> Symlink -> IO Bool
forall a. IO a -> IO a -> IO a -> IO a -> Symlink -> IO a
onSymlinkBinary IO Bool
mkLink IO Bool
overwrite (Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) IO Bool
maybeOverwrite Symlink
inputs
  where
    relativeBindir :: FilePath
relativeBindir = FilePath -> FilePath -> FilePath
makeRelative (FilePath -> FilePath
normalise FilePath
publicBindir) FilePath
privateBindir

    mkLink :: IO Bool
    mkLink :: IO Bool
mkLink = Bool
True Bool -> IO () -> IO Bool
forall a b. a -> IO b -> IO a
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 a b. a -> IO b -> IO a
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 a b. IO a -> IO b -> IO b
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 <- PromptIO Bool -> IO Bool
forall a. PromptIO a -> IO a
runPromptIO (PromptIO Bool -> IO Bool) -> PromptIO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> DefaultPrompt Bool -> PromptIO 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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SymlinkStatus
OkToOverwrite
        else SymlinkStatus -> IO SymlinkStatus
forall a. a -> IO a
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 a. a -> IO a
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
  = -- | The file doesn't exist so we can make a symlink.
    NotExists
  | -- | A symlink already exists, though it is ours. We'll
    -- have to delete it first before we make a new symlink.
    OkToOverwrite
  | -- | 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).
    NotOurFile
  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
$cshowsPrec :: Int -> SymlinkStatus -> FilePath -> FilePath
showsPrec :: Int -> SymlinkStatus -> FilePath -> FilePath
$cshow :: SymlinkStatus -> FilePath
show :: SymlinkStatus -> FilePath
$cshowList :: [SymlinkStatus] -> FilePath -> FilePath
showList :: [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. (?callStack::CallStack) => 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 a. [a] -> 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False