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

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