InstallSymlink.hs 10.3 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
{-# OPTIONS -cpp #-}
-- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -cpp #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp  #-}
-----------------------------------------------------------------------------
-- |
-- 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,
  ) where

#if mingw32_HOST_OS || mingw32_TARGET_OS

Duncan Coutts's avatar
Duncan Coutts committed
26
import Distribution.Package (PackageIdentifier)
27 28 29 30 31 32
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Setup (InstallFlags)
import Distribution.Simple.Setup (ConfigFlags)

symlinkBinaries :: ConfigFlags
                -> InstallFlags
Duncan Coutts's avatar
Duncan Coutts committed
33 34 35
                -> InstallPlan
                -> IO [(PackageIdentifier, String, FilePath)]
symlinkBinaries _ _ _ = return []
36 37 38 39 40 41 42

symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool
symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"

#else

import Distribution.Client.Types
43
         ( AvailablePackage(..), ConfiguredPackage(..) )
44 45 46 47 48 49
import Distribution.Client.Setup
         ( InstallFlags(installSymlinkBinDir) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)

import Distribution.Package
50
         ( PackageIdentifier, Package(packageId) )
51 52 53 54 55 56 57 58 59 60 61 62
import Distribution.Compiler
         ( CompilerId(..) )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
         ( PackageDescription )
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription )
import Distribution.Simple.Setup
         ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import qualified Distribution.Simple.InstallDirs as InstallDirs

import System.Posix.Files
63 64
         ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink
         , removeLink )
65 66 67
import System.Directory
         ( canonicalizePath )
import System.FilePath
68
         ( (</>), splitPath, joinPath, isAbsolute )
69 70 71 72
import System.IO.Error
         ( catch, isDoesNotExistError, ioError )
import Control.Exception
         ( assert )
73 74
import Data.Maybe
         ( catMaybes )
75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97

-- | 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 comprimise 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 :: ConfigFlags
                -> InstallFlags
98
                -> InstallPlan
99
                -> IO [(PackageIdentifier, String, FilePath)]
100 101
symlinkBinaries configFlags installFlags plan =
  case flagToMaybe (installSymlinkBinDir installFlags) of
102
    Nothing            -> return []
103 104 105
    Just symlinkBinDir
           | null exes -> return []
           | otherwise -> do
106
      publicBinDir  <- canonicalizePath symlinkBinDir
107 108
--    TODO: do we want to do this here? :
--      createDirectoryIfMissing True publicBinDir
109
      fmap catMaybes $ sequence
110 111 112 113 114 115 116 117 118 119
        [ do privateBinDir <- pkgBinDir pkg
             ok <- symlinkBinary
                     publicBinDir  privateBinDir
                     publicExeName privateExeName
             if ok
               then return Nothing
               else return (Just (pkgid, publicExeName,
                                  privateBinDir </> privateExeName))
        | (pkg, exe) <- exes
        , let publicExeName  = PackageDescription.exeName exe
120
              privateExeName = prefix ++ publicExeName ++ suffix
121
              pkgid  = packageId pkg
122
              prefix = substTemplate pkgid prefixTemplate
123
              suffix = substTemplate pkgid suffixTemplate ]
124
  where
125 126 127 128 129 130
    exes =
      [ (pkg, exe)
      | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan
      , let pkg   = pkgDescription cpkg
      , exe <- PackageDescription.executables pkg
      , PackageDescription.buildable (PackageDescription.buildInfo exe) ]
131 132 133 134

    pkgDescription :: ConfiguredPackage -> PackageDescription
    pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) =
      case finalizePackageDescription flags
135 136
             (const True)
             platform compilerId [] pkg of
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
        Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
        Right (desc, _) -> desc

    -- This is sadly rather complicated. We're kind of re-doing part of the
    -- configuration for the package. :-(
    pkgBinDir :: PackageDescription -> IO FilePath
    pkgBinDir pkg = do
      defaultDirs <- InstallDirs.defaultInstallDirs
                       compilerFlavor
                       (fromFlag (configUserInstall configFlags))
                       (PackageDescription.hasLibs pkg)
      let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
                           defaultDirs (configInstallDirs configFlags)
          absoluteDirs = InstallDirs.absoluteInstallDirs
                           (packageId pkg) compilerId InstallDirs.NoCopyDest
                           templateDirs
      canonicalizePath (InstallDirs.bindir absoluteDirs)

155 156 157
    substTemplate pkgid = InstallDirs.fromPathTemplate
                        . InstallDirs.substPathTemplate env
      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId
158 159 160 161

    fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
    prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)
    suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)
162
    platform         = InstallPlan.planPlatform plan
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
    compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan

symlinkBinary :: 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@
              -> String   -- ^ 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 sucessful. @False@
                          --   if there was another file there already that we
                          --   did not own. Other errors like permission errors
                          --   just propagate as exceptions.
symlinkBinary publicBindir privateBindir publicName privateName = do
178 179
  ok <- targetOkToOverwrite (publicBindir </> publicName)
                            (privateBindir </> privateName)
180 181 182 183 184 185 186 187 188 189 190 191
  case ok of
    NotOurFile    ->                     return False
    NotExists     ->           mkLink >> return True
    OkToOverwrite -> rmLink >> mkLink >> return True
  where
    relativeBindir = makeRelative publicBindir privateBindir
    mkLink = createSymbolicLink (relativeBindir </> privateName)
                                (publicBindir   </> publicName)
    rmLink = removeLink (publicBindir </> publicName)

-- | Check a filepath 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
192
-- be a symlink to our target (in which case we can assume ownership).
193 194 195
--
targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private
                                -- binary that we would like to create
196 197
                    -> FilePath -- ^ The canonical path of the private binary.
                                -- Use 'canonicalizePath' to make this.
198
                    -> IO SymlinkStatus
199
targetOkToOverwrite symlink target = handleNotExist $ do
200 201 202
  status <- getSymbolicLinkStatus symlink
  if not (isSymbolicLink status)
    then return NotOurFile
203 204 205 206 207
    else do target' <- canonicalizePath symlink
            -- This relies on canonicalizePath handling symlinks
            if target == target'
              then return OkToOverwrite
              else return NotOurFile
208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236

  where
    handleNotExist action = catch 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 bemore 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 ]
              ++ [  b'  | b' <- drop commonLen bs ]

#endif