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