cabal-install/src/Distribution/Client/InstallSymlink.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  Distribution.Client.InstallSymlink
   6 -- Copyright   :  (c) Duncan Coutts 2008
   7 -- License     :  BSD-like
   8 --
   9 -- Maintainer  :  cabal-devel@haskell.org
  10 -- Stability   :  provisional
  11 -- Portability :  portable
  12 --
  13 -- Managing installing binaries with symlinks.
  14 -----------------------------------------------------------------------------
  15 module Distribution.Client.InstallSymlink (
  16     symlinkBinaries,
  17     symlinkBinary,
  18     trySymlink,
  19     promptRun
  20   ) where
  21
  22 import Distribution.Client.Compat.Prelude hiding (ioError)
  23 import Prelude ()
  24
  25 import Distribution.Client.Types
  26          ( ConfiguredPackage(..), BuildOutcomes )
  27 import Distribution.Client.Setup
  28          ( InstallFlags(installSymlinkBinDir) )
  29 import qualified Distribution.Client.InstallPlan as InstallPlan
  30 import Distribution.Client.InstallPlan (InstallPlan)
  31
  32 import Distribution.Solver.Types.SourcePackage
  33 import Distribution.Solver.Types.OptionalStanza
  34
  35 import Distribution.Package
  36          ( PackageIdentifier, Package(packageId), UnitId, installedUnitId )
  37 import Distribution.Types.UnqualComponentName
  38 import Distribution.Compiler
  39          ( CompilerId(..) )
  40 import qualified Distribution.PackageDescription as PackageDescription
  41 import Distribution.PackageDescription
  42          ( PackageDescription )
  43 import Distribution.PackageDescription.Configuration
  44          ( finalizePD )
  45 import Distribution.Simple.Setup
  46          ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )
  47 import qualified Distribution.Simple.InstallDirs as InstallDirs
  48 import Distribution.Simple.Compiler
  49          ( Compiler, compilerInfo, CompilerInfo(..) )
  50 import Distribution.System
  51          ( Platform )
  52 import Distribution.Simple.Utils ( info, withTempDirectory )
  53
  54 import System.Directory
  55          ( canonicalizePath, getTemporaryDirectory, removeFile )
  56 import System.FilePath
  57          ( (</>), splitPath, joinPath, isAbsolute )
  58
  59 import System.IO.Error
  60          ( isDoesNotExistError, ioError )
  61 import Control.Exception
  62          ( assert )
  63
  64 import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink )
  65 import Distribution.Client.Types.OverwritePolicy
  66 import Distribution.Client.Init.Types ( DefaultPrompt(MandatoryPrompt) )
  67 import Distribution.Client.Init.Prompt ( promptYesNo )
  68
  69 import qualified Data.ByteString as BS
  70 import qualified Data.ByteString.Char8 as BS8
  71
  72 -- | We would like by default to install binaries into some location that is on
  73 -- the user's PATH. For per-user installations on Unix systems that basically
  74 -- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@
  75 -- directory will be on the user's PATH. However some people are a bit nervous
  76 -- about letting a package manager install programs into @~/bin/@.
  77 --
  78 -- A compromise solution is that instead of installing binaries directly into
  79 -- @~/bin/@, we could install them in a private location under @~/.cabal/bin@
  80 -- and then create symlinks in @~/bin/@. We can be careful when setting up the
  81 -- symlinks that we do not overwrite any binary that the user installed. We can
  82 -- check if it was a symlink we made because it would point to the private dir
  83 -- where we install our binaries. This means we can install normally without
  84 -- worrying and in a later phase set up symlinks, and if that fails then we
  85 -- report it to the user, but even in this case the package is still in an OK
  86 -- installed state.
  87 --
  88 -- This is an optional feature that users can choose to use or not. It is
  89 -- controlled from the config file. Of course it only works on POSIX systems
  90 -- with symlinks so is not available to Windows users.
  91 --
  92 symlinkBinaries :: Platform -> Compiler
  93                 -> OverwritePolicy
  94                 -> ConfigFlags
  95                 -> InstallFlags
  96                 -> InstallPlan
  97                 -> BuildOutcomes
  98                 -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
  99 symlinkBinaries platform comp overwritePolicy
 100                 configFlags installFlags
 101                 plan buildOutcomes =
 102   case flagToMaybe (installSymlinkBinDir installFlags) of
 103     Nothing            -> return []
 104     Just symlinkBinDir
 105            | null exes -> return []
 106            | otherwise -> do
 107       publicBinDir  <- canonicalizePath symlinkBinDir
 108 --    TODO: do we want to do this here? :
 109 --      createDirectoryIfMissing True publicBinDir
 110       fmap catMaybes $ sequenceA
 111         [ do privateBinDir <- pkgBinDir pkg ipid
 112              ok <- symlinkBinary
 113                      overwritePolicy
 114                      publicBinDir  privateBinDir
 115                      (prettyShow publicExeName) privateExeName
 116              if ok
 117                then return Nothing
 118                else return (Just (pkgid, publicExeName,
 119                                   privateBinDir </> privateExeName))
 120         | (rpkg, pkg, exe) <- exes
 121         , let pkgid  = packageId pkg
 122               -- This is a bit dodgy; probably won't work for Backpack packages
 123               ipid = installedUnitId rpkg
 124               publicExeName  = PackageDescription.exeName exe
 125               privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix
 126               prefix = substTemplate pkgid ipid prefixTemplate
 127               suffix = substTemplate pkgid ipid suffixTemplate ]
 128   where
 129     exes =
 130       [ (cpkg, pkg, exe)
 131       | InstallPlan.Configured cpkg <- InstallPlan.toList plan
 132       , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of
 133           Just (Right _success) -> True
 134           _                     -> False
 135       , let pkg :: PackageDescription
 136             pkg = pkgDescription cpkg
 137       , exe <- PackageDescription.executables pkg
 138       , PackageDescription.buildable (PackageDescription.buildInfo exe) ]
 139
 140     pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _)
 141                                       flags stanzas _) =
 142       case finalizePD flags (enableStanzas stanzas)
 143              (const True)
 144              platform cinfo [] gpd of
 145         Left _ -> error "finalizePD ReadyPackage failed"
 146         Right (desc, _) -> desc
 147
 148     -- This is sadly rather complicated. We're kind of re-doing part of the
 149     -- configuration for the package. :-(
 150     pkgBinDir :: PackageDescription -> UnitId -> IO FilePath
 151     pkgBinDir pkg ipid = do
 152       defaultDirs <- InstallDirs.defaultInstallDirs
 153                        compilerFlavor
 154                        (fromFlag (configUserInstall configFlags))
 155                        (PackageDescription.hasLibs pkg)
 156       let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
 157                            defaultDirs (configInstallDirs configFlags)
 158           absoluteDirs = InstallDirs.absoluteInstallDirs
 159                            (packageId pkg) ipid
 160                            cinfo InstallDirs.NoCopyDest
 161                            platform templateDirs
 162       canonicalizePath (InstallDirs.bindir absoluteDirs)
 163
 164     substTemplate pkgid ipid = InstallDirs.fromPathTemplate
 165                              . InstallDirs.substPathTemplate env
 166       where env = InstallDirs.initialPathTemplateEnv pkgid ipid
 167                                                      cinfo platform
 168
 169     fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
 170     prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)
 171     suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)
 172     cinfo            = compilerInfo comp
 173     (CompilerId compilerFlavor _) = compilerInfoId cinfo
 174
 175 -- | Symlink binary.
 176 --
 177 -- The paths are take in pieces, so we can make relative link when possible.
 178 --
 179 symlinkBinary ::
 180   OverwritePolicy        -- ^ Whether to force overwrite an existing file
 181   -> FilePath            -- ^ The canonical path of the public bin dir eg
 182                          --   @/home/user/bin@
 183   -> FilePath            -- ^ The canonical path of the private bin dir eg
 184                          --   @/home/user/.cabal/bin@
 185   -> FilePath            -- ^ The name of the executable to go in the public bin
 186                          --   dir, eg @foo@
 187   -> String              -- ^ The name of the executable to in the private bin
 188                          --   dir, eg @foo-1.0@
 189   -> IO Bool             -- ^ If creating the symlink was successful. @False@ if
 190                          --   there was another file there already that we did
 191                          --   not own. Other errors like permission errors just
 192                          --   propagate as exceptions.
 193 symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do
 194   ok <- targetOkToOverwrite (publicBindir </> publicName)
 195                             (privateBindir </> privateName)
 196   case ok of
 197     NotExists         -> mkLink
 198     OkToOverwrite     -> overwrite
 199     NotOurFile ->
 200       case overwritePolicy of
 201         NeverOverwrite  -> return False
 202         AlwaysOverwrite -> overwrite
 203         PromptOverwrite -> maybeOverwrite
 204   where
 205     relativeBindir = makeRelative publicBindir privateBindir
 206     mkLink :: IO Bool
 207     mkLink = True <$ createFileLink (relativeBindir </> privateName) (publicBindir </> publicName)
 208     rmLink :: IO Bool
 209     rmLink = True <$ removeFile (publicBindir </> publicName)
 210     overwrite :: IO Bool
 211     overwrite = rmLink *> mkLink
 212     maybeOverwrite :: IO Bool
 213     maybeOverwrite
 214       = promptRun
 215         "Existing file found while installing symlink. Do you want to overwrite that file? (y/n)"
 216         overwrite
 217
 218 promptRun :: String -> IO Bool -> IO Bool
 219 promptRun s m = do
 220   a <- promptYesNo s MandatoryPrompt
 221   if a then m else pure a
 222
 223 -- | Check a file path of a symlink that we would like to create to see if it
 224 -- is OK. For it to be OK to overwrite it must either not already exist yet or
 225 -- be a symlink to our target (in which case we can assume ownership).
 226 --
 227 targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private
 228                                 -- binary that we would like to create
 229                     -> FilePath -- ^ The canonical path of the private binary.
 230                                 -- Use 'canonicalizePath' to make this.
 231                     -> IO SymlinkStatus
 232 targetOkToOverwrite symlink target = handleNotExist $ do
 233   isLink <- pathIsSymbolicLink symlink
 234   if not isLink
 235     then return NotOurFile
 236     else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink
 237             -- This partially relies on canonicalizePath handling symlinks
 238             if target == target'
 239               then return OkToOverwrite
 240               else return NotOurFile
 241
 242   where
 243     handleNotExist action = catchIO action $ \ioexception ->
 244       -- If the target doesn't exist then there's no problem overwriting it!
 245       if isDoesNotExistError ioexception
 246         then return NotExists
 247         else ioError ioexception
 248
 249 data SymlinkStatus
 250    = NotExists     -- ^ The file doesn't exist so we can make a symlink.
 251    | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll
 252                    -- have to delete it first before we make a new symlink.
 253    | NotOurFile    -- ^ A file already exists and it is not one of our existing
 254                    -- symlinks (either because it is not a symlink or because
 255                    -- it points somewhere other than our managed space).
 256   deriving Show
 257
 258 -- | Take two canonical paths and produce a relative path to get from the first
 259 -- to the second, even if it means adding @..@ path components.
 260 --
 261 makeRelative :: FilePath -> FilePath -> FilePath
 262 makeRelative a b = assert (isAbsolute a && isAbsolute b) $
 263   let as = splitPath a
 264       bs = splitPath b
 265       commonLen = length $ takeWhile id $ zipWith (==) as bs
 266    in joinPath $ [ ".." | _  <- drop commonLen as ]
 267               ++ drop commonLen bs
 268
 269 -- | Try to make a symlink in a temporary directory.
 270 --
 271 -- If this works, we can try to symlink: even on Windows.
 272 --
 273 trySymlink :: Verbosity -> IO Bool
 274 trySymlink verbosity = do
 275   tmp <- getTemporaryDirectory
 276   withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do
 277     let from = tmpDirPath </> "file.txt"
 278     let to   = tmpDirPath </> "file2.txt"
 279
 280     -- create a file
 281     BS.writeFile from (BS8.pack "TEST")
 282
 283     -- create a symbolic link
 284     let create :: IO Bool
 285         create = do
 286           createFileLink from to
 287           info verbosity $ "Symlinking seems to work"
 288           return True
 289
 290     create `catchIO` \exc -> do
 291       info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc
 292       return False