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