Skip to content

Commit ab43fa3

Browse files
fgazfgaz
committed
Add a new-install command
Add the first part of the new-install command: nonlocal exes. See haskell#4558 for the design concept. This part of the command installs executables from outside of a project (ie from hackage) in the store and then symlinks them in the cabal bin directory. This is done by creating a dummy project and adding the targets as extra packages.
1 parent e002ad4 commit ab43fa3

File tree

4 files changed

+340
-0
lines changed

4 files changed

+340
-0
lines changed

‎cabal-install/Distribution/Client/CmdInstall.hs

Lines changed: 336 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,336 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
2+
{-# LANGUAGE ViewPatterns #-}
3+
4+
-- | cabal-install CLI command: build
5+
--
6+
module Distribution.Client.CmdInstall (
7+
-- * The @build@ CLI and action
8+
installCommand,
9+
installAction,
10+
11+
-- * Internals exposed for testing
12+
TargetProblem(..),
13+
selectPackageTargets,
14+
selectComponentTarget
15+
) where
16+
17+
import Prelude ()
18+
import Distribution.Client.Compat.Prelude
19+
20+
import Distribution.Client.ProjectOrchestration
21+
import Distribution.Client.CmdErrorMessages
22+
23+
import Distribution.Client.Setup
24+
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags
25+
, applyFlagDefaults )
26+
import qualified Distribution.Client.Setup as Client
27+
import Distribution.Client.Types
28+
( PackageSpecifier(NamedPackage), UnresolvedSourcePackage )
29+
import Distribution.Client.ProjectPlanning.Types
30+
( pkgConfigCompiler )
31+
import Distribution.Client.ProjectConfig.Types
32+
( ProjectConfig, ProjectConfigBuildOnly(..)
33+
, projectConfigLogsDir, projectConfigStoreDir, projectConfigShared
34+
, projectConfigBuildOnly, projectConfigDistDir
35+
, projectConfigConfigFile )
36+
import Distribution.Client.Config
37+
( defaultCabalDir )
38+
import Distribution.Client.ProjectConfig
39+
( readGlobalConfig, resolveBuildTimeSettings )
40+
import Distribution.Client.DistDirLayout
41+
( defaultDistDirLayout, distDirectory, mkCabalDirLayout
42+
, ProjectRoot(ProjectRootImplicit), distProjectCacheDirectory
43+
, storePackageDirectory, cabalStoreDirLayout )
44+
import Distribution.Client.RebuildMonad
45+
( runRebuild )
46+
import Distribution.Client.InstallSymlink
47+
( symlinkBinary )
48+
import Distribution.Simple.Setup
49+
( HaddockFlags, fromFlagOrDefault, flagToMaybe )
50+
import Distribution.Simple.Command
51+
( CommandUI(..), usageAlternatives )
52+
import Distribution.Simple.Compiler
53+
( compilerId )
54+
import Distribution.Types.PackageName
55+
( mkPackageName )
56+
import Distribution.Types.UnitId
57+
( UnitId )
58+
import Distribution.Types.UnqualComponentName
59+
( UnqualComponentName, unUnqualComponentName )
60+
import Distribution.Verbosity
61+
( Verbosity, normal )
62+
import Distribution.Simple.Utils
63+
( wrapText, die', withTempDirectory, createDirectoryIfMissingVerbose )
64+
65+
import qualified Data.Map as Map
66+
import System.Directory ( getTemporaryDirectory, makeAbsolute )
67+
import System.FilePath ( (</>) )
68+
69+
import qualified Distribution.Client.CmdBuild as CmdBuild
70+
71+
installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
72+
installCommand = CommandUI
73+
{ commandName = "new-install"
74+
, commandSynopsis = "Install packages."
75+
, commandUsage = usageAlternatives "new-install" [ "[TARGETS] [FLAGS]" ]
76+
, commandDescription = Just $ \_ -> wrapText $
77+
"Installs one or more packages. This is done by installing them "
78+
++ "in the store and symlinking the executables in the directory "
79+
++ "specified by the --symlink-bindir flag (`~/.cabal/bin/` by default). "
80+
++ "If you want the installed executables to be available globally, "
81+
++ "make sure that the PATH environment variable contains that directory. "
82+
++ "\n\n"
83+
++ "If TARGET is a library, it will be added to the global environment. "
84+
++ "When doing this, cabal will try to build a plan that includes all "
85+
++ "the previously installed libraries. This is currently not implemented."
86+
, commandNotes = Just $ \pname ->
87+
"Examples:\n"
88+
++ " " ++ pname ++ " new-install\n"
89+
++ " Install the package in the current directory\n"
90+
++ " " ++ pname ++ " new-install pkgname\n"
91+
++ " Install the package named pkgname (fetching it from hackage if necessary)\n"
92+
++ " " ++ pname ++ " new-install ./pkgfoo\n"
93+
++ " Install the package in the ./pkgfoo directory\n"
94+
95+
++ cmdCommonHelpTextNewBuildBeta
96+
, commandOptions = commandOptions CmdBuild.buildCommand
97+
, commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand
98+
}
99+
100+
101+
-- | The @install@ command actually serves four different needs. It installs:
102+
-- * Nonlocal exes:
103+
-- For example a program from hackage. The behavior is similar to the old
104+
-- install command, except that now conflicts between separate runs of the
105+
-- command are impossible thanks to the store.
106+
-- Exes are installed in the store like a normal dependency, then they are
107+
-- symlinked uin the directory specified by --symlink-bindir.
108+
-- To do this we need a dummy projectBaseContext containing the targets as
109+
-- estra packages and using a temporary dist directory.
110+
-- * Nonlocal libraries (TODO see #4558)
111+
-- * Local exes (TODO see #4558)
112+
-- * Local libraries (TODO see #4558)
113+
--
114+
-- For more details on how this works, see the module
115+
-- "Distribution.Client.ProjectOrchestration"
116+
--
117+
installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
118+
-> [String] -> GlobalFlags -> IO ()
119+
installAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))
120+
targetStrings globalFlags = do
121+
-- We need a place to put a temporary dist directory
122+
globalTmp <- getTemporaryDirectory
123+
withTempDirectory
124+
verbosity
125+
globalTmp
126+
"cabal-install."
127+
$ \tmpDir -> do
128+
129+
let packageNames = mkPackageName <$> targetStrings
130+
packageSpecifiers =
131+
(\pname -> NamedPackage pname []) <$> packageNames
132+
133+
baseCtx <- establishDummyProjectBaseContext
134+
verbosity
135+
cliConfig
136+
tmpDir
137+
packageSpecifiers
138+
139+
let targetSelectors = TargetPackageName <$> packageNames
140+
141+
buildCtx <-
142+
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
143+
144+
-- Interpret the targets on the command line as build targets
145+
targets <- either (reportTargetProblems verbosity) return
146+
$ resolveTargets
147+
selectPackageTargets
148+
selectComponentTarget
149+
TargetProblemCommon
150+
elaboratedPlan
151+
targetSelectors
152+
153+
let elaboratedPlan' = pruneInstallPlanToTargets
154+
TargetActionBuild
155+
targets
156+
elaboratedPlan
157+
elaboratedPlan'' <-
158+
if buildSettingOnlyDeps (buildSettings baseCtx)
159+
then either (reportCannotPruneDependencies verbosity) return $
160+
pruneInstallPlanToDependencies (Map.keysSet targets)
161+
elaboratedPlan'
162+
else return elaboratedPlan'
163+
164+
return (elaboratedPlan'', targets)
165+
166+
printPlan verbosity baseCtx buildCtx
167+
168+
buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
169+
170+
let compiler = pkgConfigCompiler $ elaboratedShared buildCtx
171+
let mkPkgBinDir = (</> "bin") .
172+
storePackageDirectory
173+
(cabalStoreDirLayout $ cabalDirLayout baseCtx)
174+
(compilerId compiler)
175+
176+
-- If there are exes, symlink them
177+
let defaultSymlinkBindir = error "TODO: how do I get the default ~/.cabal (or ~/.local) directory? (use --symlink-bindir explicitly for now)" </> "bin"
178+
symlinkBindir <- makeAbsolute $ fromFlagOrDefault defaultSymlinkBindir (Client.installSymlinkBinDir installFlags)
179+
traverse_ (symlinkBuiltPackage mkPkgBinDir symlinkBindir)
180+
$ Map.toList $ targetsMap buildCtx
181+
runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
182+
where
183+
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
184+
cliConfig = commandLineFlagsToProjectConfig
185+
globalFlags configFlags configExFlags
186+
installFlags haddockFlags
187+
188+
189+
-- | Symlink every exe from a package from the store to a given location
190+
symlinkBuiltPackage :: (UnitId -> FilePath) -- ^ A function to get an UnitId's
191+
-- store directory
192+
-> FilePath -- ^ Where to put the symlink
193+
-> ( UnitId
194+
, [(ComponentTarget, [TargetSelector PackageId])] )
195+
-> IO ()
196+
symlinkBuiltPackage mkSourceBinDir destDir (pkg, components) =
197+
traverse_ (symlinkBuiltExe (mkSourceBinDir pkg) destDir) exes
198+
where
199+
exes = catMaybes $ (exeMaybe . fst) <$> components
200+
exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
201+
exeMaybe _ = Nothing
202+
203+
-- | Symlink a specific exe.
204+
symlinkBuiltExe :: FilePath -> FilePath -> UnqualComponentName -> IO Bool
205+
symlinkBuiltExe sourceDir destDir exe =
206+
symlinkBinary
207+
destDir
208+
sourceDir
209+
exe
210+
$ unUnqualComponentName exe
211+
212+
-- | Create a dummy project context, without a .cabal or a .cabal.project file
213+
-- (a place where to put a temporary dist directory is still needed)
214+
establishDummyProjectBaseContext :: Verbosity
215+
-> ProjectConfig
216+
-> FilePath -- ^ Where to put the dist directory
217+
-> [PackageSpecifier UnresolvedSourcePackage] -- ^ The packages to be included in the project
218+
-> IO ProjectBaseContext
219+
establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do
220+
221+
cabalDir <- defaultCabalDir
222+
223+
-- Create the dist directories
224+
createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
225+
createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout
226+
227+
globalConfig <- runRebuild ""
228+
$ readGlobalConfig verbosity
229+
$ projectConfigConfigFile
230+
$ projectConfigShared cliConfig
231+
let projectConfig = globalConfig <> cliConfig
232+
233+
let ProjectConfigBuildOnly {
234+
projectConfigLogsDir,
235+
projectConfigStoreDir
236+
} = projectConfigBuildOnly projectConfig
237+
238+
mlogsDir = flagToMaybe projectConfigLogsDir
239+
mstoreDir = flagToMaybe projectConfigStoreDir
240+
cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir
241+
242+
buildSettings = resolveBuildTimeSettings
243+
verbosity cabalDirLayout
244+
projectConfig
245+
246+
return ProjectBaseContext {
247+
distDirLayout,
248+
cabalDirLayout,
249+
projectConfig,
250+
localPackages,
251+
buildSettings
252+
}
253+
where
254+
mdistDirectory = flagToMaybe
255+
$ projectConfigDistDir
256+
$ projectConfigShared cliConfig
257+
projectRoot = ProjectRootImplicit tmpDir
258+
distDirLayout = defaultDistDirLayout projectRoot
259+
mdistDirectory
260+
261+
-- | This defines what a 'TargetSelector' means for the @bench@ command.
262+
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
263+
-- or otherwise classifies the problem.
264+
--
265+
-- For the @build@ command select all components except non-buildable and disabled
266+
-- tests\/benchmarks, fail if there are no such components
267+
--
268+
selectPackageTargets :: TargetSelector PackageId
269+
-> [AvailableTarget k] -> Either TargetProblem [k]
270+
selectPackageTargets targetSelector targets
271+
272+
-- If there are any buildable targets then we select those
273+
| not (null targetsBuildable)
274+
= Right targetsBuildable
275+
276+
-- If there are targets but none are buildable then we report those
277+
| not (null targets)
278+
= Left (TargetProblemNoneEnabled targetSelector targets')
279+
280+
-- If there are no targets at all then we report that
281+
| otherwise
282+
= Left (TargetProblemNoTargets targetSelector)
283+
where
284+
targets' = forgetTargetsDetail targets
285+
targetsBuildable = selectBuildableTargetsWith
286+
(buildable targetSelector)
287+
targets
288+
289+
-- When there's a target filter like "pkg:tests" then we do select tests,
290+
-- but if it's just a target like "pkg" then we don't build tests unless
291+
-- they are requested by default (i.e. by using --enable-tests)
292+
buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
293+
buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
294+
buildable _ _ = True
295+
296+
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
297+
-- selected.
298+
--
299+
-- For the @build@ command we just need the basic checks on being buildable etc.
300+
--
301+
selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget
302+
-> AvailableTarget k -> Either TargetProblem k
303+
selectComponentTarget pkgid cname subtarget =
304+
either (Left . TargetProblemCommon) Right
305+
. selectComponentTargetBasic pkgid cname subtarget
306+
307+
308+
-- | The various error conditions that can occur when matching a
309+
-- 'TargetSelector' against 'AvailableTarget's for the @build@ command.
310+
--
311+
data TargetProblem =
312+
TargetProblemCommon TargetProblemCommon
313+
314+
-- | The 'TargetSelector' matches targets but none are buildable
315+
| TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()]
316+
317+
-- | There are no targets at all
318+
| TargetProblemNoTargets (TargetSelector PackageId)
319+
deriving (Eq, Show)
320+
321+
reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a
322+
reportTargetProblems verbosity =
323+
die' verbosity . unlines . map renderTargetProblem
324+
325+
renderTargetProblem :: TargetProblem -> String
326+
renderTargetProblem (TargetProblemCommon problem) =
327+
renderTargetProblemCommon "build" problem
328+
renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =
329+
renderTargetProblemNoneEnabled "build" targetSelector targets
330+
renderTargetProblem(TargetProblemNoTargets targetSelector) =
331+
renderTargetProblemNoTargets "build" targetSelector
332+
333+
reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
334+
reportCannotPruneDependencies verbosity =
335+
die' verbosity . renderCannotPruneDependencies
336+

‎cabal-install/Distribution/Client/ProjectConfig.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ module Distribution.Client.ProjectConfig (
2020

2121
-- * Project config files
2222
readProjectConfig,
23+
readGlobalConfig,
2324
readProjectLocalFreezeConfig,
2425
writeProjectLocalExtraConfig,
2526
writeProjectLocalFreezeConfig,

‎cabal-install/cabal-install.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -157,6 +157,7 @@ library
157157
Distribution.Client.CmdErrorMessages
158158
Distribution.Client.CmdFreeze
159159
Distribution.Client.CmdHaddock
160+
Distribution.Client.CmdInstall
160161
Distribution.Client.CmdRepl
161162
Distribution.Client.CmdRun
162163
Distribution.Client.CmdTest

‎cabal-install/main/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -80,6 +80,7 @@ import qualified Distribution.Client.CmdBuild as CmdBuild
8080
import qualified Distribution.Client.CmdRepl as CmdRepl
8181
import qualified Distribution.Client.CmdFreeze as CmdFreeze
8282
import qualified Distribution.Client.CmdHaddock as CmdHaddock
83+
import qualified Distribution.Client.CmdInstall as CmdInstall
8384
import qualified Distribution.Client.CmdRun as CmdRun
8485
import qualified Distribution.Client.CmdTest as CmdTest
8586
import qualified Distribution.Client.CmdBench as CmdBench
@@ -314,6 +315,7 @@ mainWorker args = topHandler $
314315
, regularCmd CmdRepl.replCommand CmdRepl.replAction
315316
, regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction
316317
, regularCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction
318+
, regularCmd CmdInstall.installCommand CmdInstall.installAction
317319
, regularCmd CmdRun.runCommand CmdRun.runAction
318320
, regularCmd CmdTest.testCommand CmdTest.testAction
319321
, regularCmd CmdBench.benchCommand CmdBench.benchAction

0 commit comments

Comments
 (0)