InstallSymlink.hs

{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- 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 (
    OverwritePolicy(..),
    symlinkBinaries,
    symlinkBinary,
  ) where

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.BuildPaths
         ( exeExtension )
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, buildPlatform )
import Distribution.Text
         ( display )

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

import Prelude hiding (ioError)
import System.IO.Error
         ( isDoesNotExistError, ioError )
import Distribution.Compat.Exception ( catchIO )
import Control.Exception
         ( assert )
import Data.Maybe
         ( catMaybes )

data OverwritePolicy = NeverOverwrite | AlwaysOverwrite
  deriving (Show, Eq)

-- | 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 comp overwritePolicy
                configFlags installFlags
                plan buildOutcomes =
  case flagToMaybe (installSymlinkBinDir installFlags) of
    Nothing            -> return []
    Just symlinkBinDir
           | null exes -> return []
           | otherwise -> do
      publicBinDir  <- canonicalizePath symlinkBinDir
--    TODO: do we want to do this here? :
--      createDirectoryIfMissing True publicBinDir
      fmap catMaybes $ sequence
        [ do privateBinDir <- pkgBinDir pkg ipid
             ok <- symlinkBinary
                     overwritePolicy
                     publicBinDir  privateBinDir
                     publicExeName privateExeName
             if ok
               then return Nothing
               else return (Just (pkgid, publicExeName,
                                  privateBinDir </> privateExeName))
        | (rpkg, pkg, exe) <- exes
        , let pkgid  = packageId pkg
              -- This is a bit dodgy; probably won't work for Backpack packages
              ipid = installedUnitId rpkg
              publicExeName  = PackageDescription.exeName exe
              privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix
              prefix = substTemplate pkgid ipid prefixTemplate
              suffix = substTemplate pkgid ipid suffixTemplate ]
  where
    exes =
      [ (cpkg, pkg, exe)
      | InstallPlan.Configured cpkg <- InstallPlan.toList plan
      , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of
          Just (Right _success) -> True
          _                     -> False
      , let pkg :: PackageDescription
            pkg = pkgDescription cpkg
      , exe <- PackageDescription.executables pkg
      , PackageDescription.buildable (PackageDescription.buildInfo exe) ]

    pkgDescription (ConfiguredPackage _ (SourcePackage _ pkg _ _)
                                      flags stanzas _) =
      case finalizePD flags (enableStanzas stanzas)
             (const True)
             platform cinfo [] pkg of
        Left _ -> error "finalizePD ReadyPackage failed"
        Right (desc, _) -> 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 pkg ipid = do
      defaultDirs <- InstallDirs.defaultInstallDirs
                       compilerFlavor
                       (fromFlag (configUserInstall configFlags))
                       (PackageDescription.hasLibs pkg)
      let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
                           defaultDirs (configInstallDirs configFlags)
          absoluteDirs = InstallDirs.absoluteInstallDirs
                           (packageId pkg) ipid
                           cinfo InstallDirs.NoCopyDest
                           platform templateDirs
      canonicalizePath (InstallDirs.bindir absoluteDirs)

    substTemplate pkgid ipid = InstallDirs.fromPathTemplate
                             . InstallDirs.substPathTemplate env
      where env = InstallDirs.initialPathTemplateEnv pkgid ipid
                                                     cinfo platform

    fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
    prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)
    suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)
    cinfo            = compilerInfo comp
    (CompilerId compilerFlavor _) = compilerInfoId cinfo

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@
  -> UnqualComponentName -- ^ 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 publicBindir privateBindir publicName privateName = do
  ok <- targetOkToOverwrite (publicBindir </> publicName')
                            (privateBindir </> privateName')
  case ok of
    NotExists         ->           mkLink >> return True
    OkToOverwrite     -> rmLink >> mkLink >> return True
    NotOurFile ->
      case overwritePolicy of
        NeverOverwrite  ->                     return False
        AlwaysOverwrite -> rmLink >> mkLink >> return True
  where
    publicName' = display publicName <.> exeExtension buildPlatform
    privateName' = privateName <.> exeExtension buildPlatform
    relativeBindir = makeRelative publicBindir privateBindir
    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
-- 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 symlink target = handleNotExist $ do
  isLink <- pathIsSymbolicLink symlink
  if not isLink
    then return NotOurFile
    else do target' <- canonicalizePath symlink
            -- This relies on canonicalizePath handling symlinks
            if target == target'
              then return OkToOverwrite
              else return NotOurFile

  where
    handleNotExist action = catchIO action $ \ioexception ->
      -- If the target doesn't exist then there's no problem overwriting it!
      if isDoesNotExistError ioexception
        then return NotExists
        else ioError 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 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 a b = assert (isAbsolute a && isAbsolute b) $
  let as = splitPath a
      bs = splitPath b
      commonLen = length $ takeWhile id $ zipWith (==) as bs
   in joinPath $ [ ".." | _  <- drop commonLen as ]
              ++ drop commonLen bs