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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
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
|
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- 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
import Distribution.Package (PackageIdentifier)
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Setup (InstallFlags)
import Distribution.Simple.Setup (ConfigFlags)
symlinkBinaries :: ConfigFlags
-> InstallFlags
-> InstallPlan
-> IO [(PackageIdentifier, String, FilePath)]
symlinkBinaries _ _ _ = return []
symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool
symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"
#else
import Distribution.Client.Types
( SourcePackage(..), ReadyPackage(..), enableStanzas )
import Distribution.Client.Setup
( InstallFlags(installSymlinkBinDir) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Package
( PackageIdentifier, Package(packageId) )
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
( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink
, removeLink )
import System.Directory
( canonicalizePath )
import System.FilePath
( (</>), splitPath, joinPath, isAbsolute )
import Prelude hiding (ioError)
import System.IO.Error
( isDoesNotExistError, ioError )
import Distribution.Compat.Exception ( catchIO )
import Control.Exception
( assert )
import Data.Maybe
( catMaybes )
-- | 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 compromise 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
-> InstallPlan
-> IO [(PackageIdentifier, String, FilePath)]
symlinkBinaries configFlags installFlags plan =
case flagToMaybe (installSymlinkBinDir installFlags) of
Nothing -> return []
Just symlinkBinDir
| null exes -> return []
| otherwise -> do
publicBinDir <- canonicalizePath symlinkBinDir
-- TODO: do we want to do this here? :
-- createDirectoryIfMissing True publicBinDir
fmap catMaybes $ sequence
[ 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
privateExeName = prefix ++ publicExeName ++ suffix
pkgid = packageId pkg
prefix = substTemplate pkgid prefixTemplate
suffix = substTemplate pkgid suffixTemplate ]
where
exes =
[ (pkg, exe)
| InstallPlan.Installed cpkg _ <- InstallPlan.toList plan
, let pkg = pkgDescription cpkg
, exe <- PackageDescription.executables pkg
, PackageDescription.buildable (PackageDescription.buildInfo exe) ]
pkgDescription :: ReadyPackage -> PackageDescription
pkgDescription (ReadyPackage (SourcePackage _ pkg _ _) flags stanzas _) =
case finalizePackageDescription flags
(const True)
platform compilerId [] (enableStanzas stanzas pkg) of
Left _ -> error "finalizePackageDescription ReadyPackage 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
platform templateDirs
canonicalizePath (InstallDirs.bindir absoluteDirs)
substTemplate pkgid = InstallDirs.fromPathTemplate
. InstallDirs.substPathTemplate env
where env = InstallDirs.initialPathTemplateEnv pkgid compilerId platform
fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)
suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)
platform = InstallPlan.planPlatform plan
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 successful. @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
ok <- targetOkToOverwrite (publicBindir </> publicName)
(privateBindir </> privateName)
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 file path 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
-- be a symlink to our target (in which case we can assume ownership).
--
targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private
-- binary that we would like to create
-> FilePath -- ^ The canonical path of the private binary.
-- Use 'canonicalizePath' to make this.
-> IO SymlinkStatus
targetOkToOverwrite symlink target = handleNotExist $ do
status <- getSymbolicLinkStatus symlink
if not (isSymbolicLink status)
then return NotOurFile
else do target' <- canonicalizePath symlink
-- This relies on canonicalizePath handling symlinks
if target == target'
then return OkToOverwrite
else return NotOurFile
where
handleNotExist action = catchIO 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 before 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 ]
++ drop commonLen bs
#endif
|
