From 121c5dedfb19bcbe125053ac82133db76c3f49e5 Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Fri, 24 Feb 2023 11:21:20 +0100 Subject: [PATCH] Install indexed crates (#1335) * Improve Roots.Create_From_Release * Install crates directly from index --- doc/user-changes.md | 17 ++ src/alire/alire-directories.adb | 14 +- src/alire/alire-install.adb | 278 +++++++++++++++--- src/alire/alire-install.ads | 20 +- src/alire/alire-releases.adb | 3 +- src/alire/alire-releases.ads | 4 +- src/alire/alire-roots.adb | 178 ++++------- src/alire/alire-roots.ads | 31 +- src/alire/alire-solutions-containers.ads | 10 + src/alire/alire-solutions.adb | 14 + src/alire/alire-solutions.ads | 5 + src/alire/alire-solver-predefined_options.ads | 36 +++ src/alire/alire-solver.adb | 49 ++- src/alire/alire-solver.ads | 46 +-- src/alr/alr-commands-get.adb | 4 +- src/alr/alr-commands-install.adb | 20 +- .../tests/install/binary-release/test.py | 10 +- .../install/executable-dependency/test.py | 5 +- testsuite/tests/install/indexed/test.py | 29 ++ testsuite/tests/install/indexed/test.yaml | 3 + 20 files changed, 546 insertions(+), 230 deletions(-) create mode 100644 src/alire/alire-solutions-containers.ads create mode 100644 src/alire/alire-solver-predefined_options.ads create mode 100644 testsuite/tests/install/indexed/test.py create mode 100644 testsuite/tests/install/indexed/test.yaml diff --git a/doc/user-changes.md b/doc/user-changes.md index 9347ac88..dcc1e18a 100644 --- a/doc/user-changes.md +++ b/doc/user-changes.md @@ -6,6 +6,23 @@ stay on top of `alr` new features. ## Release 1.3-dev +### Installation of indexed crates + +PR [#1322](https://github.com/alire-project/alire/pull/1335) + +It is now possible to install an indexed crate directly: +``` +$ alr install hello +``` +This is roughly equivalent to +```alr get hello && cd hello* && alr install``` + +The main differences are: +- Cleanup is automatic. +- Several crates can be installed in one go, e.g.: `alr install hello hangman`. +- `alr get` will always retrieve the latest version, whereas `alr install` will +also require a complete solution to dependencies. + ### Installation of local crates PR [#1322](https://github.com/alire-project/alire/pull/1322) diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index f5a64f1d..32f6906e 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -531,7 +531,19 @@ package body Alire.Directories is Delete_File (This.Filename); elsif Kind (This.Filename) = Directory then Trace.Debug ("Deleting temporary folder " & This.Filename & "..."); - Delete_Tree (This.Filename); + + begin + -- May fail in rare circumstances, like containing + -- a softlink to a parent folder or itself. + -- GNATCOLL.VFS.Remove_Dir also fails. + Delete_Tree (This.Filename); + exception + when E : others => + Log_Exception (E); + Put_Warning + ("Unable to delete temp dir: " & This.Filename); + end; + end if; end if; diff --git a/src/alire/alire-install.adb b/src/alire/alire-install.adb index 6a92594f..7e5232a1 100644 --- a/src/alire/alire-install.adb +++ b/src/alire/alire-install.adb @@ -1,9 +1,14 @@ +with Ada.Containers; with Ada.Directories; with Alire.Dependencies.Containers; with Alire.Errors; +with Alire.Index; +with Alire.Optional; with Alire.Origins; with Alire.Platforms.Current; +with Alire.Roots; +with Alire.Solutions.Containers; with Alire.Solver; package body Alire.Install is @@ -78,14 +83,73 @@ package body Alire.Install is Directories.Force_Delete (Prefix / Rel.Base_Folder); end Install_Binary; - ----------------- - -- Add_Targets -- - ----------------- + --------------------- + -- Install_Regular -- + --------------------- - procedure Add_Targets is - use all type Origins.Kinds; + procedure Install_Regular (Rel : Releases.Release; + Sol : Solutions.Solution) + is + use type Ada.Containers.Count_Type; + Temp : Directories.Temp_File; begin - for Dep of Deps loop + Put_Info ("Starting deployment of " + & Rel.Milestone.TTY_Image + & " to fulfill " & Sol.State (Rel).As_Dependency.TTY_Image + & " with " + & (if Sol.All_Dependencies.Length <= 1 + then "no dependencies." + else "solution:")); + if Sol.All_Dependencies.Length > 1 then + -- We always depend on the root release at least + Sol.Print (Root => Rel, + Env => Platforms.Current.Properties, + Detailed => False, + Level => Info, + Prefix => " ", + Graph => False); + end if; + + Trace.Debug ("Deploying installation target " + & Rel.Milestone.TTY_Image + & " to " & Temp.Filename); + + declare + Root : Roots.Root := Roots.Create_For_Release + (This => Rel, + Parent_Folder => Temp.Filename, + Env => Platforms.Current.Properties, + Up_To => Roots.Deploy); + begin + Root.Set (Sol.Excluding (Rel.Name)); + -- We exclude the root release as the Root type will take it into + -- account and otherwise it would be as if Rel depended on itself. + + Root.Deploy_Dependencies; + Root.Install (Prefix, Print_Solution => False); + end; + end Install_Regular; + + ----------------------- + -- Compute_Solutions -- + ----------------------- + -- Look for all solutions at once. This way, if some crate is unsolvable + -- we fail early on before fetching/compiling anything. + function Compute_Solutions return Solutions.Containers.Map is + use all type Origins.Kinds; + Result : Solutions.Containers.Map; + + -------------------- + -- Compute_Binary -- + -------------------- + -- Look for a binary crate for the dependency. For installation we + -- always prefer a binary release over a source one. The user can + -- always override by giving specific versions if there were of + -- both kinds for the same crate. + function Compute_Binary (Dep : Dependencies.Dependency) + return Boolean + is + begin declare Rel : constant Releases.Release := Solver.Find (Name => Dep.Crate, @@ -94,19 +158,110 @@ package body Alire.Install is Origins => (Binary_Archive => True, others => False)); begin - Check_Conflict (Prefix, Rel); - Install_Binary (Rel); + Result.Insert (Dep.Crate, + Solutions + .Empty_Valid_Solution + .Depending_On (Dep) + .Including + (Rel, + Env => Platforms.Current.Properties, + For_Dependency => + Optional.Crate_Names.Unit (Dep.Crate))); + return True; + end; + exception + when Query_Unsuccessful => + Trace.Debug ("No binary release found for " & Dep.TTY_Image); + return False; + end Compute_Binary; + + --------------------- + -- Compute_Regular -- + --------------------- + -- Look for a regular solution to a dependency as fallback if we + -- didn't find any binary solution. + procedure Compute_Regular (Dep : Dependencies.Dependency) is + Sol : constant Solutions.Solution := Solver.Resolve (Dep); + begin + if Sol.Is_Complete then + Result.Insert (Dep.Crate, Sol); + else + Trace.Error ("Could not find a complete solution for " + & Dep.TTY_Image); + + -- If we found a release for the root dependency we can print + -- the partial solution. Otherwise nothing was solved. + + if Sol.Contains_Release (Dep.Crate) then + Trace.Error ("Best incomplete solution is:"); + Sol.Print (Root => Sol.Releases.Element (Dep.Crate), + Env => Platforms.Current.Properties, + Detailed => False, + Level => Trace.Error); + Raise_Checked_Error ("Installation cannot continue."); + elsif not Index.Exists (Dep.Crate) then + Raise_Checked_Error + ("Requested crate not found: " & Dep.Crate.TTY_Image); + else + Raise_Checked_Error + ("No solution could be computed for: " & Dep.TTY_Image); + end if; + end if; + end Compute_Regular; + + begin + Put_Info ("Computing solutions..."); + + for Dep of Deps loop + if not Compute_Binary (Dep) then + Compute_Regular (Dep); + end if; + end loop; + + Put_Success ("Installation targets fully solved"); + + return Result; + end Compute_Solutions; + + ----------------- + -- Add_Targets -- + ----------------- + + procedure Add_Targets is + -- Try to get complete solutions for everything before starting + -- deploying anything. This way, if something isn't installable, + -- we fail early on before fetching/compiling things. + Sols : constant Solutions.Containers.Map := Compute_Solutions; + begin + + -- Now install all solutions + + for I in Sols.Iterate loop + declare + use all type Origins.Kinds; + use Solutions.Containers.Maps; + Rel : constant Releases.Release := + Element (I).Releases.Element (Key (I)); + Action : constant Actions := Check_Conflicts (Prefix, Rel); + begin + if Action = Skip then + Put_Info ("Skipping already installed " + & Rel.Milestone.TTY_Image); + else + case Rel.Origin.Kind is + when Filesystem | Source_Archive | Origins.VCS_Kinds => + Install_Regular (Rel, Sols (I)); + when Binary_Archive => + Install_Binary (Rel); + when others => + Raise_Checked_Error + ("Cannot install " & Rel.Milestone.TTY_Image + & " because origin is of kind " + & Rel.Origin.Kind'Image); + end case; + end if; end; end loop; - exception - when E : Query_Unsuccessful => - Errors.New_Wrapper - .Wrap (E) - .Wrap ("Either the release does not exist or it does not " - & "have a binary archive for installation.") - .Wrap ("Only binary releases are currently supported.") - .Print; - Raise_Checked_Error ("Cannot complete installation."); end Add_Targets; Target_Deps : Dependencies.Containers.Map; @@ -130,28 +285,81 @@ package body Alire.Install is Add_Targets; end Add; - -------------------- - -- Check_Conflict -- - -------------------- + --------------------- + -- Check_Conflicts -- + --------------------- - procedure Check_Conflict (Prefix : Any_Path; Rel : Releases.Release) is - Installed : constant Installed_Milestones := Find_Installed (Prefix); + function Check_Conflicts (Prefix : Any_Path; + Rel : Releases.Release) + return Actions + is begin - if (for some M of Installed => M.Crate = Rel.Name) then - if Installed.Contains (Rel.Milestone) then - Recoverable_Error - ("Requested release " & Rel.Milestone.TTY_Image - & " is already installed"); - else - Recoverable_Error - (Errors.Wrap - ("Requested release " & Rel.Milestone.TTY_Image - & " has another version already installed: ", - To_Image_Vector (Find_Installed - (Prefix, Rel.Name)).Flatten (ASCII.LF))); + + -- Crates declaring executables can only be installed once + + if Rel.Origin.Kind in Origins.Binary_Archive + or else not Rel.Executables.Is_Empty + then + declare + Installed : constant Alire.Install.Installed_Milestones := + Alire.Install.Find_Installed + (Prefix, Rel.Name); + begin + + -- No problem if the version installed is the same one + + if Installed.Contains (Rel.Milestone) then + return Action : constant Actions := + (if Force then Reinstall else Skip) + do + Trace.Debug ("Already installed: " & Rel.Milestone.TTY_Image + & "; action: " & Action'Image); + end return; + + elsif not Installed.Is_Empty then + + -- A different version exists, here we fail unless forced + + Recoverable_Error + (Errors.New_Wrapper + ("Release " & Rel.Milestone.TTY_Image + & " has another version already installed: ") + .Wrap (To_Image_Vector (Find_Installed + (Prefix, Rel.Name)).Flatten (ASCII.LF)) + .Wrap ("Releases installing executables can be " + & "installed only once") + .Wrap ("Forcing this install will overwrite the " + & "release already installed") + .Get); + + return Replace; + + end if; + end; + else + + -- This is a library, several versions are OK but we can skip one + -- already available. Or it could be a crate with default undeclared + -- executable. In any case, we cannot be sure. Worst case, gprinstall + -- will fail later. + + if Alire.Install.Find_Installed (Prefix).Contains (Rel.Milestone) + then + return Action : constant Actions := + (if Force then Reinstall else Skip) + do + Trace.Debug ("Already installed: " & Rel.Milestone.TTY_Image + & "; action: " & Action'Image); + end return; end if; + end if; - end Check_Conflict; + + -- In any other case it shuld be safe to install + + return New_Install; + + end Check_Conflicts; -------------------- -- Find_Installed -- diff --git a/src/alire/alire-install.ads b/src/alire/alire-install.ads index cc97c1b4..b684dd09 100644 --- a/src/alire/alire-install.ads +++ b/src/alire/alire-install.ads @@ -13,13 +13,19 @@ package Alire.Install is procedure Add (Prefix : Any_Path; Deps : Dependencies.Containers.List); - -- Resolve the dependencies and install the resulting releases. If a - -- crate is given twice it will raise. - - procedure Check_Conflict (Prefix : Any_Path; Rel : Releases.Release); - -- Will cause a recoverable error if Rel is already installed, or another - -- release from the same crate is. This is regardless Rel containing - -- executables or not. + -- Resolve the dependencies and install the resulting releases. If a crate + -- is given twice it will raise. + + type Actions is ( + New_Install, -- no conflict + Reinstall, -- install same version again + Replace, -- new version of already installed executable + Skip -- skip install + ); + + function Check_Conflicts (Prefix : Any_Path; + Rel : Releases.Release) + return Actions; procedure Info (Prefix : Any_Path); -- Display information about the given prefix diff --git a/src/alire/alire-releases.adb b/src/alire/alire-releases.adb index fc478120..93bff683 100644 --- a/src/alire/alire-releases.adb +++ b/src/alire/alire-releases.adb @@ -641,7 +641,8 @@ package body Alire.Releases is ---------------- function Executables (R : Release; - P : Alire.Properties.Vector) + P : Alire.Properties.Vector := + Platforms.Current.Properties) return AAA.Strings.Vector is Exes : constant AAA.Strings.Vector := diff --git a/src/alire/alire-releases.ads b/src/alire/alire-releases.ads index ce341049..3733d6fb 100644 --- a/src/alire/alire-releases.ads +++ b/src/alire/alire-releases.ads @@ -10,6 +10,7 @@ with Alire.Interfaces; with Alire.Manifest; with Alire.Milestones; with Alire.Origins; +with Alire.Platforms.Current; with Alire.Properties.Actions; with Alire.Properties.Environment; with Alire.Properties.Labeled; @@ -205,7 +206,8 @@ package Alire.Releases is -- Retrieve env vars that are set by this release, key is the var name function Executables (R : Release; - P : Alire.Properties.Vector) + P : Alire.Properties.Vector := + Platforms.Current.Properties) return AAA.Strings.Vector; -- Only explicitly declared ones -- Under some conditions (usually current platform) diff --git a/src/alire/alire-roots.adb b/src/alire/alire-roots.adb index a2501d40..4e575064 100644 --- a/src/alire/alire-roots.adb +++ b/src/alire/alire-roots.adb @@ -9,7 +9,6 @@ with Alire.Install; with Alire.Manifest; with Alire.Origins; with Alire.OS_Lib; -with Alire.Platforms.Current; with Alire.Properties.Actions.Executor; with Alire.Roots.Optional; with Alire.Shared; @@ -231,110 +230,15 @@ package body Alire.Roots is ------------- procedure Install - (This : in out Root; - Prefix : Absolute_Path; - Build : Boolean := True; - Export_Env : Boolean := True) + (This : in out Root; + Prefix : Absolute_Path; + Build : Boolean := True; + Export_Env : Boolean := True; + Print_Solution : Boolean := True) is use AAA.Strings; use Directories.Operators; - type Actions is (Doinstall, -- no conflict - Reinstall, -- overwrite - Skip -- skip install - ); - - --------------------- - -- Check_Conflicts -- - --------------------- - - procedure Check_Conflicts (Rel : Releases.Release; - Action : out Actions) - is - begin - Action := Doinstall; -- unless we find some problem - - -- Crates declaring executables can only be installed once - - if not Rel.Executables (This.Environment).Is_Empty then - declare - Installed : constant Alire.Install.Installed_Milestones := - Alire.Install.Find_Installed - (Prefix, Rel.Name); - begin - - -- No problem if the version installed is the same one - - if Installed.Contains (Rel.Milestone) then - Action := (if Force then Reinstall else Skip); - Trace.Debug ("Already installed: " & Rel.Milestone.TTY_Image - & "; action: " & Action'Image); - return; - - elsif not Installed.Is_Empty then - - -- A different version exists, here we fail unless forced - - Recoverable_Error - (Errors.New_Wrapper - ("Release " & Rel.Milestone.TTY_Image & " conflicts " - & "with already installed " - & Alire.Install.Find_Installed - (Prefix, Rel.Name).First_Element.TTY_Image) - .Wrap ("Releases installing executables can be " - & "installed only once") - .Wrap ("Forcing this install will overwrite the " - & "release already installed") - .Get); - - Action := Reinstall; - - -- If forced to continue, we mark as uninstalled the - -- currently installed version. We are not doing cleanup - -- (yet?) so anything not overwritten will remain. - - Alire.Install.Set_Not_Installed (Prefix, Rel.Name); - end if; - end; - else - - -- This is a library, several versions are OK but we can skip one - -- already available. - - if Alire.Install.Find_Installed (Prefix).Contains (Rel.Milestone) - then - Action := (if Force then Reinstall else Skip); - Trace.Debug ("Already installed: " & Rel.Milestone.TTY_Image - & "; action: " & Action'Image); - - elsif Platforms.Current.Operating_System in Platforms.Windows - and then - not Alire.Install.Find_Installed (Prefix, Rel.Name).Is_Empty - then - - -- Several versions of the same library on Windows are a no-no. - -- Note that forcing through this will likely - - Recoverable_Error - (Errors.New_Wrapper - ("Release " & Rel.Milestone.TTY_Image & " conflicts " - & "with already installed " - & Alire.Install.Find_Installed - (Prefix, Rel.Name).First_Element.TTY_Image) - .Wrap ("Windows does not support installing multiple " - & "versions") - .Wrap ("Forcing will cause dependents on the other " - & "versions to break") - .Get); - - Alire.Install.Set_Not_Installed (Prefix, Rel.Name); - - end if; - - end if; - - end Check_Conflicts; - ------------------- -- Install_Inner -- ------------------- @@ -356,13 +260,14 @@ package body Alire.Roots is declare use all type Origins.Kinds; - Rel : constant Releases.Release := State.Release; + Rel : constant Releases.Release := State.Release; + Action : constant Alire.Install.Actions := + Alire.Install.Check_Conflicts (Prefix, Rel); begin - -- Binary crates may not include a GPR file, that we - -- would need to install its artifacts. This may be - -- common for compiler releases, so no need to be - -- exceedingly alarmist about it. + -- Binary crates may not include a GPR file, that we would need + -- to install its artifacts. This may be common for compiler + -- releases, so no need to be exceedingly alarmist about it. if Rel.Project_Files (This.Environment, With_Path => False).Is_Empty @@ -400,28 +305,34 @@ package body Alire.Roots is With_Path => True) loop declare + use all type Alire.Install.Actions; Gpr_Path : constant Any_Path := This.Release_Base (Rel.Name) / Gpr_File; - Action : Actions := Doinstall; TTY_Target : constant String := Rel.Milestone.TTY_Image & "/" & TTY.URL (Gpr_File); begin - Check_Conflicts (Rel, Action); - -- Libraries with same version already installed, - -- binaries already installed. case Action is - when Doinstall => + when New_Install => Put_Info ("Installing " & TTY_Target & "..."); when Reinstall => Put_Warning ("Reinstalling " & TTY_Target & "..."); + when Replace => + Put_Warning ("Replacing " + & Alire.Install.Find_Installed + (Prefix, Rel.Name) + .First_Element.TTY_Image + & " with " & TTY_Target & "..."); + -- When replacing, any other version must be marked as + -- uninstalled. + Alire.Install.Set_Not_Installed (Prefix, Rel.Name); when Skip => Put_Info ("Skipping already installed " & TTY_Target & "..."); end case; case Action is - when Doinstall | Reinstall => + when New_Install | Reinstall | Replace => Spawn.Gprinstall (Release => Rel, Project_File => Ada.Directories @@ -429,7 +340,8 @@ package body Alire.Roots is Prefix => Prefix, Recursive => False, Quiet => True, - Force => (Force or Action = Reinstall)); + Force => (Force or + Action in Reinstall | Replace)); -- Say something if after installing a crate it -- leaves no trace in the prefix. This is the @@ -457,11 +369,15 @@ package body Alire.Roots is -- Show some preliminary info Put_Info ("Starting installation of " - & This.Release.Element.Milestone.TTY_Image & " with " - & (if This.Solution.All_Dependencies.Is_Empty - then "no dependencies." - else "solution:")); - if not This.Solution.All_Dependencies.Is_Empty then + & This.Release.Element.Milestone.TTY_Image + & (if Print_Solution + then " with " + & (if This.Solution.All_Dependencies.Is_Empty + then "no dependencies." + else "solution:") + else "...")); + if Print_Solution and then not This.Solution.All_Dependencies.Is_Empty + then This.Solution.Print (Root => This.Release.Element, Env => This.Environment, Detailed => False, @@ -487,10 +403,10 @@ package body Alire.Roots is -- relevance to installation. -- We need to go over all projects in the solution because gprinstall - -- only installs binaries generated by the root project, even - -- when told to install recursively. So, instead we gprinstall - -- non-recursively each individual project in the solution. - -- Config projects, being abstract, need no installation. + -- only installs binaries generated by the root project, even when told + -- to install recursively. So, instead we gprinstall non-recursively + -- each individual project in the solution. Config projects, being + -- abstract, need no installation. This.Traverse (Doing => Install_Inner'Access); end Install; @@ -646,10 +562,10 @@ package body Alire.Roots is -- Create_For_Release -- ------------------------ - function Create_For_Release (This : Releases.Release; - Parent_Folder : Any_Path; - Env : Alire.Properties.Vector; - Perform_Actions : Boolean := True) + function Create_For_Release (This : Releases.Release; + Parent_Folder : Any_Path; + Env : Properties.Vector; + Up_To : Creation_Levels) return Root is use Directories; @@ -659,13 +575,13 @@ package body Alire.Roots is (Env => Env, Parent_Folder => Parent_Folder, Was_There => Unused_Was_There, - Perform_Actions => Perform_Actions, + Perform_Actions => False, -- Makes no sense until deps in place Create_Manifest => True); -- And generate its working files, if they do not exist declare - Working_Dir : Guard (Enter (This.Base_Folder)) + Working_Dir : Guard (Enter (Parent_Folder / This.Base_Folder)) with Unreferenced; Root : Alire.Roots.Root := Alire.Roots.New_Root @@ -685,6 +601,12 @@ package body Alire.Roots is then Alire.Solutions.Empty_Valid_Solution else Alire.Solutions.Empty_Invalid_Solution)); + if Up_To = Update then + Root.Update (Allowed => Allow_All_Crates, + Silent => False, + Interact => False); + end if; + return Root; end; end Create_For_Release; diff --git a/src/alire/alire-roots.ads b/src/alire/alire-roots.ads index 707ebc26..e09c601d 100644 --- a/src/alire/alire-roots.ads +++ b/src/alire/alire-roots.ads @@ -23,10 +23,17 @@ package Alire.Roots is type Root (<>) is tagged private; - function Create_For_Release (This : Releases.Release; - Parent_Folder : Any_Path; - Env : Properties.Vector; - Perform_Actions : Boolean := True) + -- When creating a root for a release, this type is used to say how many + -- post-download steps to take. Each level includes previous ones. + type Creation_Levels is + (Deploy, -- Do nothing besides fetching the root release + Update -- Solve and fetch dependencies for the solution + ); + + function Create_For_Release (This : Releases.Release; + Parent_Folder : Any_Path; + Env : Properties.Vector; + Up_To : Creation_Levels) return Root; -- Prepare a workspace with This release as the root one, with manifest and -- lock files. IOWs, does everything but deploying dependencies. Intended @@ -34,12 +41,13 @@ package Alire.Roots is -- the Root is usable. For when retrieval is with --only (e.g., in a -- platform where it is unavailable, but we want to inspect the sources), -- Perform_Actions allow disabling these operations that make no sense for - -- the Release on isolation. + -- the Release on isolation. When Solve, a best-effort solution will be + -- computed, either complete or doing a single-timeout period to have a + -- decent incomplete one. If Update, dependencies will be deployed after function Load_Root (Path : Any_Path) return Root; -- Attempt to detect a root at the given path. The root will be valid if - -- path/alire exists, path/alire/*.toml is unique and loadable as a crate - -- containing a single release. Otherwise, Checked_Error. + -- path/alire.toml exists and is a valid manifest. Otherwise Checked_Error. -- See Alire.Directories.Detect_Root_Path to use with the following @@ -233,10 +241,11 @@ package Alire.Roots is -- increasing priority from: defaults -> manifests -> explicit set via API. procedure Install - (This : in out Root; - Prefix : Absolute_Path; - Build : Boolean := True; - Export_Env : Boolean := True); + (This : in out Root; + Prefix : Absolute_Path; + Build : Boolean := True; + Export_Env : Boolean := True; + Print_Solution : Boolean := True); -- Call gprinstall on the releases in solution using --prefix=Prefix function Configuration (This : in out Root) diff --git a/src/alire/alire-solutions-containers.ads b/src/alire/alire-solutions-containers.ads new file mode 100644 index 00000000..945b541e --- /dev/null +++ b/src/alire/alire-solutions-containers.ads @@ -0,0 +1,10 @@ +with Ada.Containers.Indefinite_Ordered_Maps; + +package Alire.Solutions.Containers is + + package Maps is new Ada.Containers.Indefinite_Ordered_Maps + (Crate_Name, Solution); + + subtype Map is Maps.Map; + +end Alire.Solutions.Containers; diff --git a/src/alire/alire-solutions.adb b/src/alire/alire-solutions.adb index dd2ef6cd..df717b34 100644 --- a/src/alire/alire-solutions.adb +++ b/src/alire/alire-solutions.adb @@ -77,6 +77,20 @@ package body Alire.Solutions is is (Solution'(Solved => True, Dependencies => This.Dependencies.Merging (Dep))); + --------------- + -- Excluding -- + --------------- + + function Excluding (This : Solution; + Crate : Crate_Name) + return Solution + is + Result : Solution := This; + begin + Result.Dependencies.Exclude (Crate); + return Result; + end Excluding; + ---------------- -- Depends_On -- ---------------- diff --git a/src/alire/alire-solutions.ads b/src/alire/alire-solutions.ads index 6846a3ce..19149c4f 100644 --- a/src/alire/alire-solutions.ads +++ b/src/alire/alire-solutions.ads @@ -82,6 +82,11 @@ package Alire.Solutions is -- Add or merge a dependency without changing its state. For a new -- dependency, it will be marked as Pending and with Unknown transitivity. + function Excluding (This : Solution; + Crate : Crate_Name) + return Solution; + -- Remove a dependendency on crate, if it is present + function Hinting (This : Solution; Dep : Dependencies.Dependency) return Solution; diff --git a/src/alire/alire-solver-predefined_options.ads b/src/alire/alire-solver-predefined_options.ads new file mode 100644 index 00000000..30f6687a --- /dev/null +++ b/src/alire/alire-solver-predefined_options.ads @@ -0,0 +1,36 @@ +package Alire.Solver.Predefined_Options is + + Default_Options : Query_Options renames Solver.Default_Options; + + Default_Options_Not_Interactive : constant Query_Options := + (On_Timeout => Stop, + others => <>); + + Complete_Only : constant Query_Options := + (Exhaustive => False, -- only attempt complete ones + On_Timeout => Continue, + others => <>); + -- Only return a complete solution, but try for as long as it takes + + Complete_Or_Good_Incomplete : constant Query_Options + := (On_Timeout => Continue_While_Complete_Then_Stop, + others => <>); + -- Intended to find a complete solution, or else return an incomplete one + -- that helps with diagnosing the trouble. This one looks for incompletes + -- during one timeout period after all complete have been explored without + -- timeout. + + Exhaustive_Options : constant Query_Options := + (Completeness => All_Incomplete, + others => <>); + -- Explore the full solution space + + Find_Best_Options : constant Query_Options := + (Completeness => All_Complete, + others => <>); + -- Find all complete solutions and return the "best" one (see + -- Solutions.Is_Better). It does not yet make sense to use this setting + -- because with the current Is_Better implementation, the first complete + -- solution found is the one considered best anyway. + +end Alire.Solver.Predefined_Options; diff --git a/src/alire/alire-solver.adb b/src/alire/alire-solver.adb index cc172f17..b4660153 100644 --- a/src/alire/alire-solver.adb +++ b/src/alire/alire-solver.adb @@ -8,6 +8,7 @@ with Alire.Dependencies.States; with Alire.Errors; with Alire.Milestones; with Alire.Optional; +with Alire.Platforms.Current; with Alire.Releases.Containers; with Alire.Shared; with Alire.Root; @@ -185,6 +186,21 @@ package body Alire.Solver is -- Resolve -- ------------- + function Resolve + (Dep : Dependencies.Dependency; + Options : Query_Options := + (On_Timeout => Continue_While_Complete_Then_Stop, + others => <>)) + return Solution + is (Resolve (Deps => Conditional.New_Dependency (Dep), + Props => Platforms.Current.Properties, + Pins => Solutions.Empty_Valid_Solution, + Options => Options)); + + ------------- + -- Resolve -- + ------------- + function Resolve (Deps : Alire.Types.Abstract_Dependencies; Props : Properties.Vector; Pins : Solution; @@ -303,7 +319,11 @@ package body Alire.Solver is -- Options take precedence over any interaction yet to occur - if Options.On_Timeout = Continue then + if Options.On_Timeout = Continue + or else + (Options.On_Timeout = Continue_While_Complete_Then_Stop + and then Options.Completeness < Some_Incomplete) + then User_Answer_Continue := Always; end if; @@ -1272,7 +1292,7 @@ package body Alire.Solver is -- Warn if we foresee things taking a loong time... if Options.Completeness = All_Incomplete then - Put_Warning ("Exploring all possible solutions to dependencies," + Put_Warning ("Exploring incomplete solutions to dependencies," & " this may take some time..."); end if; @@ -1310,17 +1330,15 @@ package body Alire.Solver is -- can retry with a larger solution space. if Solutions.Is_Empty then + if Options.Completeness <= All_Complete then + Put_Warning ("Spent " & TTY.Emph (Timer.Image) & " seconds " + & "exploring complete solutions"); + end if; + if Options.Completeness < All_Incomplete + and then Options.Exhaustive and then User_Answer_Continue /= No then - if Options.Completeness <= All_Complete then - Put_Warning - ("No complete solution exists, looking for incomplete ones; " - & "this may take some time..."); - Put_Warning ("Spent " & TTY.Emph (Timer.Image) & " seconds " - & "exploring complete solutions"); - end if; - Trace.Detail ("No solution found with completeness policy of " & Options.Completeness'Image @@ -1345,15 +1363,20 @@ package body Alire.Solver is All_Incomplete, when All_Incomplete => raise Program_Error with "Unreachable code"), + Exhaustive => Options.Exhaustive, Detecting => Options.Detecting, Hinting => Options.Hinting, Sharing => Options.Sharing, Timeout => Options.Timeout, Timeout_More => Options.Timeout_More, Elapsed => Timer.Elapsed, - On_Timeout => (if User_Answer_Continue = Always - then Continue - else Options.On_Timeout)))); + On_Timeout => + (if Options.On_Timeout = + Continue_While_Complete_Then_Stop + then Stop + elsif User_Answer_Continue = Always + then Continue + else Options.On_Timeout)))); else raise Query_Unsuccessful with Errors.Set ("Solver failed to find any solution to fulfill dependencies " diff --git a/src/alire/alire-solver.ads b/src/alire/alire-solver.ads index 72c1a470..8c788bce 100644 --- a/src/alire/alire-solver.ads +++ b/src/alire/alire-solver.ads @@ -42,7 +42,9 @@ package Alire.Solver is ); -- Allow the solver to further explore incomplete solution space. Each -- value takes more time than the precedent one. All_Incomplete can take - -- a veeery long time when many crates/releases must be considered. + -- a veeery long time when many crates/releases must be considered. TODO: + -- All these policies can go away once we move from a recursive solver to + -- a non-recursive priority-based one. type Detection_Policies is (Detect, Dont_Detect); -- * Detect: externals will be detected and added to the index once needed. @@ -60,9 +62,15 @@ package Alire.Solver is -- * Only_Local: only crates in the local workspace will be used. type Timeout_Policies is - (Ask, -- Normal interaction with user - Stop, -- Abort at first timeout - Continue -- Never ask and continue searching + (Ask, -- Normal interaction with user + Stop, -- Abort at first timeout + Continue, -- Never ask and continue searching + Continue_While_Complete_Then_Stop + -- If there are complete solutions unexplored, continue searching. + -- Once complete are exhausted, the timeout timer will be reset and the + -- policy downgraded to Stop. This is intended to abort as soon as we + -- know there aren't complete solutions, but also to be able to provide + -- a decent incomplete solution so the problem can be diagnosed. ); subtype Pin_Map is User_Pins.Maps.Map; @@ -121,6 +129,9 @@ package Alire.Solver is type Query_Options is record Age : Age_Policies := Newest; Completeness : Completeness_Policies := First_Complete; + Exhaustive : Boolean := True; + -- When Exhaustive, Completeness is progressively downgraded. Otherwise + -- only the given Completeness is used. Detecting : Detection_Policies := Detect; Hinting : Hinting_Policies := Hint; Sharing : Sharing_Policies := Allow_Shared; @@ -142,22 +153,17 @@ package Alire.Solver is -- A reasonable combo that will return the first complete solution found, -- or otherwise consider a subset of incomplete solutions. - Default_Options_Not_Interactive : constant Query_Options := - (On_Timeout => Stop, - others => <>); - - Exhaustive_Options : constant Query_Options := - (Completeness => All_Incomplete, - others => <>); - -- Explore the full solution space - - Find_Best_Options : constant Query_Options := - (Completeness => All_Complete, - others => <>); - -- Find all complete solutions and return the "best" one (see - -- Solutions.Is_Better). It does not yet make sense to use this setting - -- because with the current Is_Better implementation, the first complete - -- solution found is the one considered better anyway. + -- See child package Predefined_Options for more. + + function Resolve + (Dep : Dependencies.Dependency; + Options : Query_Options := + (On_Timeout => Continue_While_Complete_Then_Stop, + others => <>)) + return Solution; + -- For when we only know the root crate without a precise version and want + -- either a complete solution or a reasonable idea of what's preventing it. + -- E.g., in `alr get` and `alr install`. function Resolve (Deps : Alire.Types.Abstract_Dependencies; Props : Properties.Vector; diff --git a/src/alr/alr-commands-get.adb b/src/alr/alr-commands-get.adb index 9ea04159..9e7f582e 100644 --- a/src/alr/alr-commands-get.adb +++ b/src/alr/alr-commands-get.adb @@ -133,7 +133,7 @@ package body Alr.Commands.Get is (Rel, Ada.Directories.Current_Directory, Platform.Properties, - Perform_Actions => False)); + Up_To => Alire.Roots.Deploy)); -- Set the initial solution we just found @@ -188,7 +188,7 @@ package body Alr.Commands.Get is -- The complete build environment has been set up already by -- Deploy_Dependencies, so we must not do it again. Build_OK := Cmd.Root.Build - (Cmd_Args => AAA.Strings.Empty_Vector, + (Cmd_Args => AAA.Strings.Empty_Vector, Saved_Profiles => False, Export_Build_Env => False); end if; diff --git a/src/alr/alr-commands-install.adb b/src/alr/alr-commands-install.adb index 6bc82d89..83c2311e 100644 --- a/src/alr/alr-commands-install.adb +++ b/src/alr/alr-commands-install.adb @@ -36,6 +36,8 @@ package body Alr.Commands.Install is procedure Execute (Cmd : in out Command; Args : AAA.Strings.Vector) is + use all type Alire.Install.Actions; + Prefix : constant Alire.Absolute_Path := Adirs.Full_Name (if Cmd.Prefix.all /= "" @@ -54,11 +56,16 @@ package body Alr.Commands.Install is elsif Args.Is_Empty then - -- Install local crate first if requested - - Alire.Install.Check_Conflict (Prefix, Cmd.Root.Release); - Cmd.Root.Install (Prefix => Prefix, - Export_Env => True); + case Alire.Install.Check_Conflicts (Prefix, Cmd.Root.Release) is + when Skip => + Trace.Info + (Cmd.Root.Release.Milestone.TTY_Image + & " is already installed, use " & TTY.Terminal ("--force") + & " to reinstall"); + when New_Install | Reinstall | Replace => + Cmd.Root.Install (Prefix => Prefix, + Export_Env => True); + end case; else @@ -110,6 +117,9 @@ package body Alr.Commands.Install is & "), as well as crates initialized with `alr` using default " & "templates, should be able to coexist in a same installation prefix" & " without issue.") + .New_Line + .Append ("You can use the --force to reinstall already installed " + & "releases.") ); -------------------- diff --git a/testsuite/tests/install/binary-release/test.py b/testsuite/tests/install/binary-release/test.py index 27999557..c1f4707b 100644 --- a/testsuite/tests/install/binary-release/test.py +++ b/testsuite/tests/install/binary-release/test.py @@ -25,7 +25,9 @@ assert_match("There is no installation at prefix .*", # Install the binary crate p = run_alr("install", PREFIX_ARG, "crate", quiet=False) -assert_match("""Note: Deploying crate=1.0.0... +assert_match("""Note: Computing solutions... +Success: Installation targets fully solved +Note: Deploying crate=1.0.0... Note: Installing crate=1.0.0... Success: Install to .* finished successfully in .* seconds. """, @@ -38,12 +40,12 @@ assert p.returncode == 0, \ assert_eq("Bin crate OK\n", p.stdout.decode()) # Verify release cannot be reinstalled -assert_match(".*Requested release crate=1.0.0 is already installed.*", +assert_match(".*Skipping already installed crate=1.0.0.*", run_alr("install", PREFIX_ARG, "crate", - quiet=False, complain_on_error=False).out) + quiet=False).out) # Verify another version cannot be installed -assert_match(".*Requested release crate=0.1.0 has another version already installed:\n" +assert_match(".*Release crate=0.1.0 has another version already installed:\n" ".* crate=1.0.0.*", run_alr("install", PREFIX_ARG, "crate=0.1.0", quiet=False, complain_on_error=False).out) diff --git a/testsuite/tests/install/executable-dependency/test.py b/testsuite/tests/install/executable-dependency/test.py index 7fe338a7..353023ce 100644 --- a/testsuite/tests/install/executable-dependency/test.py +++ b/testsuite/tests/install/executable-dependency/test.py @@ -30,7 +30,7 @@ ext = (".exe" if on_windows() else "") # Check actual executables in place os.chdir(os.path.join("..", "install", "bin")) # simplifies paths in check -assert_contents(".", +assert_contents(".", [f"./dep{ext}", f"./xxx{ext}"]) @@ -44,7 +44,8 @@ replace_in_file(os.path.join("xxx", "dep", alr_manifest()), init_local_crate(name="yyy") alr_with("dep", path="../xxx/dep") p = run_alr("install", PREFIX_ARG, complain_on_error=False) -assert_match(".*Release dep=0.2.0 conflicts with already installed dep=0.1.0-dev.*", +assert_match(".*Release dep=0.2.0 has another version already installed.*" + "dep=0.1.0-dev.*", p.out) print("SUCCESS") \ No newline at end of file diff --git a/testsuite/tests/install/indexed/test.py b/testsuite/tests/install/indexed/test.py new file mode 100644 index 00000000..5e4e0829 --- /dev/null +++ b/testsuite/tests/install/indexed/test.py @@ -0,0 +1,29 @@ +""" +Test installation of an indexed crate +""" + +from drivers.alr import run_alr +from drivers.asserts import assert_installed, assert_match + +import os + +prefix = os.path.join(os.getcwd(), "prefix") +prefix_arg = f"--prefix={prefix}" + +run_alr("install", prefix_arg, "noop=1.0.0-multi") +assert_installed(prefix, ["noop=1.0.0-multi"]) + +# Check that reinstallation detects already installed +p = run_alr("install", prefix_arg, "noop=1.0.0-multi", quiet=False) +assert_match(".*Skipping already installed noop=1.0.0-multi.*", p.out) + +# Check that trying to install a different version doesn't fly +p = run_alr("install", prefix_arg, "noop=1.0.0-nondef", complain_on_error=False) +assert_match(".*Release noop=1.0.0-nondef has another version already installed.*", p.out) + +# Check that we can force and the new version is installed, and the old one is gone +p = run_alr("install", prefix_arg, "noop=1.0.0-nondef", force=True, quiet=False) +assert_installed(prefix, ["noop=1.0.0-nondef"]) + + +print('SUCCESS') diff --git a/testsuite/tests/install/indexed/test.yaml b/testsuite/tests/install/indexed/test.yaml new file mode 100644 index 00000000..da16bb1b --- /dev/null +++ b/testsuite/tests/install/indexed/test.yaml @@ -0,0 +1,3 @@ +driver: python-script +indexes: + run_index: {} -- 2.39.5