From fcc48191b0bbb52e0670075b77a85b95bb80b628 Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Thu, 2 Feb 2023 16:56:00 +0100 Subject: [PATCH] `alr install`: Installation of binary crates (#1302) * Installation of binary releases * Basic prevention of conflicting installs * Self-review and cleanup * Add test and related fixes * gprbuild tests wrt library placement and artifacts --- .gitattributes | 1 + doc/AEPs/aep-0003.md | 237 ++++++++++++++++++ doc/user-changes.md | 45 ++++ scripts/alr-completion.bash | 2 +- src/alire/alire-directories.adb | 116 ++++++++- src/alire/alire-directories.ads | 15 +- src/alire/alire-errors.adb | 15 +- src/alire/alire-errors.ads | 63 +++++ src/alire/alire-install.adb | 227 +++++++++++++++++ src/alire/alire-install.ads | 39 +++ src/alire/alire-milestones-containers.ads | 4 + src/alire/alire-platforms-common.ads | 11 +- src/alire/alire-platforms-folders.ads | 3 + src/alire/alire-releases.adb | 5 +- src/alire/alire-vfs.ads | 4 + src/alire/alire.adb | 10 + src/alire/alire.ads | 3 + .../alire-platforms-folders__linux.adb | 6 + .../alire-platforms-folders__macos.adb | 6 + .../alire-platforms-folders__windows.adb | 6 +- src/alr/alr-commands-install.adb | 106 ++++++++ src/alr/alr-commands-install.ads | 45 ++++ src/alr/alr-commands.adb | 2 + .../my_index/crates/crate/crate.tgz | Bin 0 -> 10240 bytes .../my_index/index/cr/crate/crate-0.1.0.toml | 10 + .../my_index/index/cr/crate/crate-1.0.0.toml | 10 + .../binary-release/my_index/index/index.toml | 1 + .../tests/install/binary-release/test.py | 64 +++++ .../tests/install/binary-release/test.yaml | 4 + 29 files changed, 1049 insertions(+), 11 deletions(-) create mode 100644 doc/AEPs/aep-0003.md create mode 100644 src/alire/alire-install.adb create mode 100644 src/alire/alire-install.ads create mode 100644 src/alr/alr-commands-install.adb create mode 100644 src/alr/alr-commands-install.ads create mode 100644 testsuite/tests/install/binary-release/my_index/crates/crate/crate.tgz create mode 100644 testsuite/tests/install/binary-release/my_index/index/cr/crate/crate-0.1.0.toml create mode 100644 testsuite/tests/install/binary-release/my_index/index/cr/crate/crate-1.0.0.toml create mode 100644 testsuite/tests/install/binary-release/my_index/index/index.toml create mode 100644 testsuite/tests/install/binary-release/test.py create mode 100644 testsuite/tests/install/binary-release/test.yaml diff --git a/.gitattributes b/.gitattributes index 40f4e814..86ec7aad 100644 --- a/.gitattributes +++ b/.gitattributes @@ -10,3 +10,4 @@ # Mark some misidentified files as always binaries *.pdf -text *.png -text +*.tgz -text diff --git a/doc/AEPs/aep-0003.md b/doc/AEPs/aep-0003.md new file mode 100644 index 00000000..76a69c56 --- /dev/null +++ b/doc/AEPs/aep-0003.md @@ -0,0 +1,237 @@ + AEP: 3 + Title: Command `alr install` information + Author: Alejandro R. Mosteo + Status: Draft + Created: 2022-01-19 + +Abstract +======== + +Information gathered about the operation of `gprinstall`, relevant to our +purposes of how to work with static/dynamic libraries and with different +versions of the same library/compilers. + +Information +=========== + +By using different names during installation, several versions of the same lib +can be made to coexist, with some caveats. + +For example, after having installed libhello 1.0.0 (static) and libhello 1.0.1 +(dynamic) and hello 1.0.2 (dynamic), we obtain this tree: + +``` +prefix/ +├── bin +│   └── hello +├── include +│   ├── hello=1.0.2 +│   │   └── hello +│   │   ├── hello.adb +│   │   └── hello_config.ads +│   ├── libhello=1.0.0 +│   │   └── libhello +│   │   ├── libhello.adb +│   │   └── libhello.ads +│   └── libhello=1.0.1 +│   └── libhello +│   ├── libhello.adb +│   ├── libhello.ads +│   └── libhello_config.ads +├── lib +│   ├── libhello=1.0.0 +│   │   └── libhello +│   │   ├── libhello.a +│   │   └── libhello.ali +│   ├── libhello=1.0.1 +│   │   └── libhello +│   │   ├── libhello.ali +│   │   ├── libhello_config.ali +│   │   ├── Libhello.so.1.0.1 +│   │   └── libLibhello.so -> ../libhello/Libhello.so.1.0.1 +│   ├── Libhello.so.1.0.1 -> ../lib/libhello=1.0.1/libhello/Libhello.so.1.0.1 +│   └── libLibhello.so -> ../lib/libhello=1.0.1/libhello/libLibhello.so +└── share + └── gpr + ├── hello.gpr + ├── libhello.gpr + └── manifests + ├── hello=1.0.2 + ├── libhello=1.0.0 + └── libhello=1.0.1 +``` + +First caveat is that `gprinstall` clobbers `prefix/share/gpr/libhello.gpr` +without warning, even if `-f` was not used. This means that an installation +with the purpose of development cannot have several versions installed. + +Still, it seems we could rely on such a prefix for executables depending on +different versions of the same dynamic library, as ldd shows the proper +dependency: + +``` +$ ldd prefix/bin/hello + linux-vdso.so.1 (0x00007fffa772f000) + Libhello.so.1.0.1 => not found + libgnat-12.so => /path/to/compiler/.../libgnat-12.so (0x00007fda1ca0e000) + libgcc_s.so.1 => /path/to/compiler/.../libgcc_s.so.1 (0x00007fda1c7ef000) + libc.so.6 => /lib/x86_64-linux-gnu/libc.so.6 (0x00007fda1c5c5000) + libdl.so.2 => /lib/x86_64-linux-gnu/libdl.so.2 (0x00007fda1c5c0000) + libm.so.6 => /lib/x86_64-linux-gnu/libm.so.6 (0x00007fda1c4d9000) + /lib64/ld-linux-x86-64.so.2 (0x00007fda1d0b4000) +``` + +By using `--mode=usage`, there is no ali, gpr or source files installed. So +going with this mode, unneeded conflicting files are not even installed. + +Uninstalling two versions will remove the gpr file after the first uninstall. +However, the second uninstall will not fail, silently removing the rest of +files. + +For uninstallation we need to supply the project file, which can come from the +original build folder or from the installed share/gpr location. + +However, when installing in usage mode, there will be no gpr file installed, +forcing to preserve the original project file. + +In usage mode, static libraries are not installed, and no manifest is created +if nothing gets installed. Uninstalling will then complain about lack of manifest. + +It seems that, at least for basic code, an executable build with a compiler and +a dynamic library build with another are compatible. + +Executables depend on properly versioned `.so.x.x.x` files, so the extra `.so` +file clobbered by several installs is not important. + +## Test to relocate lib files + +Running + +``` +$ rm -rf ../prefix/ ; alr exec -- gprinstall --install-name=hello=1.0.2 --link-lib-subdir=bin hello.gpr --prefix=../prefix -p --mode=usage -XLIBRARY_TYPE=relocatable -r +$ tree ../prefix/ -F +../prefix/ +├── bin/ +│   ├── hello* +│   ├── Libhello.so.1.0.1 -> ../lib/hello=1.0.2/libhello/Libhello.so.1.0.1* +│   └── libLibhello.so -> ../lib/hello=1.0.2/libhello/libLibhello.so* +├── lib/ +│   └── hello=1.0.2/ +│   └── libhello/ +│   ├── Libhello.so.1.0.1* +│   └── libLibhello.so -> ../libhello/Libhello.so.1.0.1* +└── share/ + └── gpr/ + └── manifests/ + └── hello=1.0.2 +``` + +we can see that the softlinks are placed with the binaries. However, this does +not really help as + +``` +PATH+=:../prefix/bin hello +hello: error while loading shared libraries: Libhello.so.1.0.1: cannot open shared object file: No such file or directory +``` + +still fails (going into the `bin` directory and launching from there works). + +Probably on Windows it will do help, as DLLs are looked for in the PATH. + +For Linux, we could instruct users to set `LD_LIBRARY_PATH`, or perhaps add an +`alr install --printenv` that can be added to `.bashrc`. + +## Test of artifacts + +The following sequence shows artifacts being placed in the expected location: + +``` +$ alr init --bin hello +$ cd hello +$ touch share/hello/hello-artifact +$ alr build +$ rm -rf ../prefix/ ; alr exec -- gprinstall --install-name=hello=0.1.0-dev --link-lib-subdir=bin hello.gpr --prefix=../prefix -p --mode=usage -XLIBRARY_TYPE=relocatable -r +$ tree ../prefix/ -F +../prefix/ +├── bin/ +│   └── hello* +└── share/ + ├── gpr/ + │   └── manifests/ + │   └── hello=0.1.0-dev + └── hello/ + └── hello-artifact +``` + +Summary of findings +=================== + +- Several dynamic versions of a library are possible, for executables. + - Development with several versions is not possible. + - `LD_LIBRARY_PATH` seems necessary in any case +- Dependencies on libraries from the compiler also appear. + - It would then be better to use a compiler from within the prefix. +- Uninstall of several versions requires preserving the original project file. + - When uninstalling only one version, the installed gpr file suffices. +- Compiler consistency between dynamic libraries is not mandatory. +- Executables link against the properly versioned dynamic library. + +Proposal +======== + +Given these findings, and the primary need of using `alr install` to make binaries +available, and not to make development libraries available, we can abandon this +latter notion for good. Sharing of large dependencies, if ever implemented will use +a different mechanism. + +For installing executables, each installation can be performed on its own: we need +not track crates (as we can check the gprinstall manifests) nor consider +incompatibilities, as there are none. Worst case, two releases from the same crate +would be detected by their manifests, and two different crates clobbering each other +would be detected during `gprinstall`. + +For uninstallation, we may redeploy sources to have access to the original project +files. + +For (un)installation of local crates, there's also no issue: they will use the local +version, and we have the gpr file available too for both. + +We could consider caching build directories for faster installs of related crates +sharing several dependencies, and faster uninstallation. This would incur some disk +usage penalty so we may want to make this optional. + +We may want to track dependencies to prevent uninstallation of libraries which are +depended upon. This would be a final enhancement. Uninstallation doesn't seem to be +a pressing matter, as prefixes will be fast to recreate. + +Tracking of dependencies isn't trivial as we can't use a single root (there will be +"incompatible" (in solution sense) crates installed quite often, if only because of +forced compilers). + +Roadmap +======= + +Wanted and simple to implement: + +- Installation of binary releases + - Un-uninstallable if there is no project file +- Installation of local releases +- Installation of indexed releases + +Optional or low priority: + +- Uninstallation relying on project file (local/indexed releases) +- Uninstallation of binary releases without a project file + - Using our own-created manifest during installation +- Tracking of dependencies + - To prevent uninstalls with dependents + - Or to also uninstall dependents + +Out of scope: + +- Installation for development (users can manually do this via alr exec -- gprinstall) + +Copyright +========= + +This document has been placed in the public domain. \ No newline at end of file diff --git a/doc/user-changes.md b/doc/user-changes.md index 8ada3bb4..337a3a62 100644 --- a/doc/user-changes.md +++ b/doc/user-changes.md @@ -6,6 +6,51 @@ stay on top of `alr` new features. ## Release 1.3-dev +### New subcommand `alr install + +PR [#1302](https://github.com/alire-project/alire/pull/1302) + +A new subcommand `alr install` allows the installation of binaries to a location +intended to be added to the user's PATH. The default install location is +`$HOME/.alire`, with binaries going into `$HOME/.alire/bin`. + +This is a experimental feature that will see improvements and tweaks in further +PRs and as we gather feedback on its usage. + +At present, only binary releases can be installed (e.g., compilers, `gprbuild`, +`gnatprove`, `gnatstudio`). There is no ability to uninstall releases either +(but reinstallation can be forced). + +Only one version per executable can be installed, meaning that, for example, +only one toolchain version can exist in an installation prefix. So, this +feature is intended to make the user's preferred version of a crate generally +available in the system for use outside of Alire, but not to replace e.g. the +ability of Alire to use several compilers, or to reuse compiled libraries as +dependencies in several workspaces. + +Examples: + +``` +$ alr install gnatprove +ⓘ Installing gnatprove=12.1.1... +ⓘ Installation complete. + +$ alr install +Installation prefix found at /home/jano/.alire +Contents: + gnatprove=12.1.1 + +$ PATH+=:$HOME/.alire/bin gnatprove --version +Usage: gnatprove -Pproj [switches] [-cargs switches] +... + +$ alr install gnatprove^11 +error: Requested release gnatprove=11.2.3 has another version already +installed: gnatprove=12.1.1. (This error can be overridden with --force.) + +$ alr --force install gnatprove^11 # Downgrade installation +``` + ### Find dependents of a release with `alr show --dependents PR [#1170](https://github.com/alire-project/alire/pull/1170) diff --git a/scripts/alr-completion.bash b/scripts/alr-completion.bash index bc86f91f..d9a97cef 100755 --- a/scripts/alr-completion.bash +++ b/scripts/alr-completion.bash @@ -46,7 +46,7 @@ function _alr_completion() { # Command-specific completions $found &&\ case $cmd in - get | show | toolchain) + get | install | show | toolchain) # Suggest crate names COMPREPLY+=($(compgen -W "$_alr_crates" -- $curr)) ;; diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index 627671fb..f5a64f1d 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -8,6 +8,7 @@ with Alire.Errors; with Alire.OS_Lib.Subprocess; with Alire.Paths; with Alire.Platforms.Current; +with Alire.VFS; with GNATCOLL.VFS; @@ -419,6 +420,13 @@ package body Alire.Directories is Exception_Information (E)); end Finalize; + ------------------ + -- Is_Directory -- + ------------------ + + function Is_Directory (Path : Any_Path) return Boolean + is (Adirs.Exists (Path) and then Adirs.Kind (Path) in Adirs.Directory); + ---------------- -- TEMP FILES -- ---------------- @@ -542,11 +550,117 @@ package body Alire.Directories is raise; end Finalize; + -------------------- + -- Merge_Contents -- + -------------------- + + procedure Merge_Contents (Src, Dst : Any_Path; + Skip_Top_Level_Files : Boolean; + Fail_On_Existing_File : Boolean) + is + + Base : constant Absolute_Path := Adirs.Full_Name (Src); + Target : constant Absolute_Path := Adirs.Full_Name (Dst); + + ----------- + -- Merge -- + ----------- + + procedure Merge + (Item : Ada.Directories.Directory_Entry_Type; + Stop : in out Boolean) + is + use all type Adirs.File_Kind; + + Rel_Path : constant Relative_Path := + Find_Relative_Path (Base, Adirs.Full_Name (Item)); + -- If this proves to be too slow, we should do our own recursion, + -- building the relative path along the way, as this is recomputing + -- it for every file needlessly. + + Dst : constant Absolute_Path := Target / Rel_Path; + Src : constant Absolute_Path := Adirs.Full_Name (Item); + begin + Stop := False; + + -- Check if we must skip (we delete source file) + + if Adirs.Kind (Item) = Ordinary_File + and then Skip_Top_Level_Files + and then Base = Parent (Src) + then + Trace.Debug (" Merge: Not merging top-level file " & Src); + Adirs.Delete_File (Src); + return; + end if; + + -- Create a new dir if necessary + + if Adirs.Kind (Item) = Directory then + if not Is_Directory (Dst) then + Trace.Debug (" Merge: Creating destination dir " & Dst); + Adirs.Create_Directory (Dst); + end if; + + return; + -- Nothing else to do for a directory. If we controlled the + -- recursion we could more efficiently rename now into place. + end if; + + -- Move a file into place + + Trace.Debug (" Merge: Moving " & Adirs.Full_Name (Item) + & " into " & Dst); + if Adirs.Exists (Dst) then + if Fail_On_Existing_File then + Recoverable_Error ("Cannot move " & TTY.URL (Src) + & " into place, file already exists: " + & TTY.URL (Dst)); + elsif Adirs.Kind (Dst) /= Ordinary_File then + Raise_Checked_Error ("Cannot replace " & TTY.URL (Dst) + & " as it is not a regular file"); + else + Trace.Debug (" Merge: Deleting in preparation to replace: " + & Dst); + Adirs.Delete_File (Dst); + end if; + end if; + + -- We use GNATCOLL.VFS here as some binary packages contain softlinks + -- to .so libs that we must copy too, and these are troublesome + -- with regular Ada.Directories (that has no concept of softlink). + -- Also, some of these softlinks are broken and although they are + -- presumably safe to discard, let's just go for an identical copy. + + declare + VF : constant VFS.Virtual_File := + VFS.New_Virtual_File (VFS.From_FS (Src)); + OK : Boolean := False; + begin + if VF.Is_Symbolic_Link then + VF.Rename (VFS.New_Virtual_File (Dst), OK); + if not OK then + Raise_Checked_Error ("Failed to move softlink: " + & TTY.URL (Src)); + end if; + else + Adirs.Rename (Old_Name => Src, + New_Name => Dst); + end if; + end; + end Merge; + + begin + Traverse_Tree (Start => Src, + Doing => Merge'Access, + Recurse => True); + end Merge_Contents; + ------------------- -- Traverse_Tree -- ------------------- - procedure Traverse_Tree (Start : Relative_Path; + procedure Traverse_Tree (Start : Any_Path; Doing : access procedure (Item : Ada.Directories.Directory_Entry_Type; Stop : in out Boolean); diff --git a/src/alire/alire-directories.ads b/src/alire/alire-directories.ads index e099f838..70a6d2dd 100644 --- a/src/alire/alire-directories.ads +++ b/src/alire/alire-directories.ads @@ -73,11 +73,24 @@ package Alire.Directories is -- Finds a single file in a folder with the given extension and return its -- absolute path. If more than one, or none, returns "". + function Is_Directory (Path : Any_Path) return Boolean; + -- Returns false for non-existing paths too + + procedure Merge_Contents (Src, Dst : Any_Path; + Skip_Top_Level_Files : Boolean; + Fail_On_Existing_File : Boolean); + -- Move all contents from Src into Dst, recursively. Dirs already existing + -- on Dst tree will be merged. For existing regular files, either log + -- at debug level or fail. If Skip, discard files at the Src top-level. + -- This is what we want when manually unpacking binary releases, as + -- the top-level only contains "doinstall", "README" and so on that + -- are unusable and would be confusing in a binary prefix. + procedure Touch (File : File_Path); -- If the file exists, update last edition time; otherwise create it. If -- File denotes anything else than a regular file, raise. - procedure Traverse_Tree (Start : Relative_Path; + procedure Traverse_Tree (Start : Any_Path; Doing : access procedure (Item : Ada.Directories.Directory_Entry_Type; Stop : in out Boolean); diff --git a/src/alire/alire-errors.adb b/src/alire/alire-errors.adb index 0f7a833c..34d5f244 100644 --- a/src/alire/alire-errors.adb +++ b/src/alire/alire-errors.adb @@ -131,8 +131,10 @@ package body Alire.Errors is Trace.Error ((if I > Lines.First_Index then " " else "") -- Indentation - & Line - -- The error proper + & (if I < Lines.Last_Index and Line (Line'Last) = '.' + then Line (Line'First .. Line'Last - 1) + else Line) + -- The error proper, trimming unwanted final '.' & (if I < Lines.Last_Index and then Line (Line'Last) /= ':' @@ -151,6 +153,15 @@ package body Alire.Errors is function Wrap (Upper, Lower : String) return String is (Upper & ASCII.LF & Lower); + ----------- + -- Print -- + ----------- + + procedure Print (This : Wrapper) is + begin + Pretty_Print (This.Text); + end Print; + -------------------- -- ERROR STACKING -- -------------------- diff --git a/src/alire/alire-errors.ads b/src/alire/alire-errors.ads index fef57697..5bea9ed2 100644 --- a/src/alire/alire-errors.ads +++ b/src/alire/alire-errors.ads @@ -72,6 +72,31 @@ package Alire.Errors with Preelaborate is -- Convenience to concatenate two error messages: a new wrapping text and -- an existing error within a exception being wrapped. + type Wrapper (<>) is tagged private; + -- Convenience to chain calls to Wrap in their natural order. Just a + -- wrapper over the previous calls. + + function New_Wrapper return Wrapper; + -- Start an empty error message sequence + + function New_Wrapper (Text : String) return Wrapper; + -- Start error sequence with its top unindented message + + function Wrap (This : Wrapper; Text : String) return Wrapper; + -- Add an indented detail error msg to the current wrapping chain, unless + -- the wrapper is empty in which case the message will be top level. + + function Wrap (This : Wrapper; Ex : Ada.Exceptions.Exception_Occurrence) + return Wrapper; + -- Add an exception message instead of a given text, at top or nested level + + procedure Print (This : Wrapper); + -- Complete the chain of errors and log it at error level + + function Set (This : Wrapper) return String; + -- Store the msgs in This and return an Id for use as exception message + -- (see Set above). + ----------- -- Scope -- ----------- @@ -110,4 +135,42 @@ private (Str'Length > Id_Marker'Length and then Str (Str'First .. Str'First + Id_Marker'Length - 1) = Id_Marker); + ------------- + -- Wrapper -- + ------------- + + type Wrapper (Length : Natural) is tagged record + Text : String (1 .. Length); + end record; + + function New_Wrapper return Wrapper is (Length => 0, Text => ""); + + ----------------- + -- New_Wrapper -- + ----------------- + + function New_Wrapper (Text : String) return Wrapper + is (Length => Text'Length, Text => Text); + + ---------- + -- Wrap -- + ---------- + + function Wrap (This : Wrapper; Text : String) return Wrapper + is (if This.Text /= "" + then New_Wrapper (Wrap (This.Text, Text)) + else New_Wrapper (Text)); + + function Wrap (This : Wrapper; Ex : Ada.Exceptions.Exception_Occurrence) + return Wrapper + is (This.Wrap (Get (Ex))); + -- Start a chain with an exception message instead of a given text + + --------- + -- Set -- + --------- + + function Set (This : Wrapper) return String + is (Set (This.Text)); + end Alire.Errors; diff --git a/src/alire/alire-install.adb b/src/alire/alire-install.adb new file mode 100644 index 00000000..eedb831c --- /dev/null +++ b/src/alire/alire-install.adb @@ -0,0 +1,227 @@ +with Ada.Directories; + +with Alire.Dependencies.Containers; +with Alire.Errors; +with Alire.Origins; +with Alire.Platforms.Current; +with Alire.Releases; +with Alire.Solver; + +with Semantic_Versioning; + +package body Alire.Install is + + package Adirs renames Ada.Directories; + + --------- + -- Add -- + --------- + + procedure Add (Prefix : Any_Path; + Deps : Dependencies.Containers.List) + is + + -------------------- + -- Install_Binary -- + -------------------- + + procedure Install_Binary (Rel : Releases.Release) is + Was_There : Boolean := False; + begin + + -- Use or regular deployment facilities, in case there are any + -- actions to perform. + + Rel.Deploy (Env => Platforms.Current.Properties, + Parent_Folder => Prefix, + Was_There => Was_There); + + if not Rel.Project_Files (Platforms.Current.Properties, + With_Path => False).Is_Empty + then + -- This would require using gprinstall, trusting there are + -- Artifacts in the project file. Unimplemented for now, and not + -- dealt with in this branch anyway (once there are project files, + -- we would install in the context of a proper Root.) + Put_Warning ("Ignoring project files for binary release " + & Rel.Milestone.TTY_Image); + end if; + + -- Now move into the proper place + + Put_Info ("Installing " & Rel.Milestone.TTY_Image & "..."); + Directories.Merge_Contents + (Src => Prefix / Rel.Base_Folder, + Dst => Prefix, + Skip_Top_Level_Files => True, + Fail_On_Existing_File => not Alire.Force); + + -- Keep track that this was installed + + Set_Not_Installed (Prefix, Rel.Name); + Set_Installed (Prefix, Rel.Milestone); + + -- Remove unwanted remains, if any + + Directories.Force_Delete (Prefix / Rel.Base_Folder); + end Install_Binary; + + -------------------- + -- Check_Conflict -- + -------------------- + + procedure Check_Conflict (Rel : Releases.Release) is + use type Semantic_Versioning.Version; + Installed : constant Installed_Milestones := Find_Installed (Prefix); + begin + if Installed.Contains (Rel.Name) then + if Installed (Rel.Name).Version = Rel.Version then + Recoverable_Error + ("Requested release " & Rel.Milestone.TTY_Image + & " is already installed"); + else + Recoverable_Error + ("Requested release " & Rel.Milestone.TTY_Image + & " has another version already installed: " + & Installed (Rel.Name).TTY_Image); + end if; + end if; + end Check_Conflict; + + ----------------- + -- Add_Targets -- + ----------------- + + procedure Add_Targets is + use all type Origins.Kinds; + begin + for Dep of Deps loop + declare + Rel : constant Releases.Release + := Solver.Find (Name => Dep.Crate, + Allowed => Dep.Versions, + Policy => Solver.Newest, + Origins => (Binary_Archive => True, + others => False)); + begin + Check_Conflict (Rel); + Install_Binary (Rel); + 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; + + begin + -- Ensure no duplicates + + for Dep of Deps loop + if Target_Deps.Contains (Dep.Crate) then + Raise_Checked_Error ("Crate given twice for simultaneous install: " + & Target_Deps (Dep.Crate).TTY_Image & " and " + & Dep.TTY_Image); + else + Target_Deps.Insert (Dep.Crate, Dep); + end if; + end loop; + + Directories.Create_Tree (Prefix / Metadata_Dir_In_Prefix); + -- Ensure destination exists + + Add_Targets; + + Put_Info ("Installation complete."); + end Add; + + -------------------- + -- Find_Installed -- + -------------------- + + function Find_Installed (Prefix : Any_Path) + return Milestones.Containers.Maps.Map + is + Result : Milestones.Containers.Maps.Map; + + procedure Find + (Item : Ada.Directories.Directory_Entry_Type; + Stop : in out Boolean) + is + Name : constant String := Adirs.Simple_Name (Item); + begin + Stop := False; + + if (for some Char of Name => Char = '=') then + declare + Milestone : constant Milestones.Milestone := + Milestones.New_Milestone (Name); + begin + Result.Insert (Milestone.Crate, Milestone); + end; + end if; + end Find; + + begin + if Adirs.Exists (Prefix / Metadata_Dir_In_Prefix) then + Directories.Traverse_Tree (Start => Prefix / Metadata_Dir_In_Prefix, + Doing => Find'Access, + Recurse => False); + end if; + + return Result; + end Find_Installed; + + ---------- + -- Info -- + ---------- + + procedure Info (Prefix : Any_Path) is + begin + -- gprinstall stores metadata about each install in share/gpr/manifests. + -- For binary "just-copy" installs we just track the milestone. + + if not Ada.Directories.Exists (Prefix / Metadata_Dir_In_Prefix) then + Trace.Info ("There is no installation at prefix " & TTY.URL (Prefix)); + else + Trace.Info ("Installation prefix found at " & TTY.URL (Prefix)); + Trace.Info ("Contents:"); + for Milestone of Find_Installed (Prefix) loop + Trace.Info (" " & Milestone.TTY_Image); + end loop; + end if; + + end Info; + + ------------------- + -- Set_Installed -- + ------------------- + + procedure Set_Installed (Prefix : Any_Path; Mil : Milestones.Milestone) is + begin + Directories.Touch (Prefix + / Metadata_Dir_In_Prefix + / Mil.Image); + end Set_Installed; + + ----------------------- + -- Set_Not_Installed -- + ----------------------- + + procedure Set_Not_Installed (Prefix : Any_Path; Crate : Crate_Name) is + begin + for Mil of Find_Installed (Prefix) loop + if Mil.Crate = Crate then + Adirs.Delete_File (Prefix / Metadata_Dir_In_Prefix / Mil.Image); + end if; + end loop; + end Set_Not_Installed; + +end Alire.Install; diff --git a/src/alire/alire-install.ads b/src/alire/alire-install.ads new file mode 100644 index 00000000..8357bc60 --- /dev/null +++ b/src/alire/alire-install.ads @@ -0,0 +1,39 @@ +limited with Alire.Dependencies.Containers; +with Alire.Directories; use Alire.Directories.Operators; +private with Alire.Milestones.Containers; +with Alire.Platforms.Folders; + +package Alire.Install is + + -- Support for installation prefixes + + Default_Prefix : constant Absolute_Path + := Platforms.Folders.Home / ".alire"; + + 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 Info (Prefix : Any_Path); + -- Display information about the given prefix + +private + + Metadata_Dir_In_Prefix : constant Relative_Path + := "share" / "gpr" / "manifests"; + -- This is used by gprinstall and we will reuse it for our "fake" binary + -- installs. + + subtype Installed_Milestones is Milestones.Containers.Maps.Map; + + function Find_Installed (Prefix : Any_Path) + return Installed_Milestones; + -- Identify installed releases in the prefix + + procedure Set_Installed (Prefix : Any_Path; Mil : Milestones.Milestone); + + procedure Set_Not_Installed (Prefix : Any_Path; Crate : Crate_Name); + -- Any and all versions will be marked as not installed + +end Alire.Install; diff --git a/src/alire/alire-milestones-containers.ads b/src/alire/alire-milestones-containers.ads index 1e1c95e4..805203d0 100644 --- a/src/alire/alire-milestones-containers.ads +++ b/src/alire/alire-milestones-containers.ads @@ -1,4 +1,5 @@ with Ada.Containers.Indefinite_Doubly_Linked_Lists; +with Ada.Containers.Indefinite_Ordered_Maps; with Ada.Containers.Indefinite_Ordered_Sets; package Alire.Milestones.Containers with Preelaborate is @@ -6,6 +7,9 @@ package Alire.Milestones.Containers with Preelaborate is package Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists (Milestones.Milestone); + package Maps is new + Ada.Containers.Indefinite_Ordered_Maps (Crate_Name, Milestone); + package Sets is new Ada.Containers.Indefinite_Ordered_Sets (Milestones.Milestone); diff --git a/src/alire/alire-platforms-common.ads b/src/alire/alire-platforms-common.ads index 210be837..6b544ebb 100644 --- a/src/alire/alire-platforms-common.ads +++ b/src/alire/alire-platforms-common.ads @@ -15,6 +15,13 @@ private package Alire.Platforms.Common is function On_Windows return Boolean; -- Says if we are on Windows + --------------------- + -- Unix_Home_Folder -- + --------------------- + + function Unix_Home_Folder return String + is (OS_Lib.Getenv ("HOME", Default => "/tmp")); + ---------------------- -- XDG_Cache_Folder -- ---------------------- @@ -22,7 +29,7 @@ private package Alire.Platforms.Common is function XDG_Cache_Folder return String is (OS_Lib.Getenv ("XDG_CACHE_HOME", - Default => OS_Lib.Getenv ("HOME") / ".cache") + Default => Unix_Home_Folder / ".cache") / "alire"); ----------------------- @@ -32,7 +39,7 @@ private package Alire.Platforms.Common is function XDG_Config_Folder return String is (OS_Lib.Getenv ("XDG_CONFIG_HOME", - Default => OS_Lib.Getenv ("HOME", Default => "/tmp") / ".config") + Default => Unix_Home_Folder / ".config") / "alire"); private diff --git a/src/alire/alire-platforms-folders.ads b/src/alire/alire-platforms-folders.ads index 1192b90a..1cd1a3f1 100644 --- a/src/alire/alire-platforms-folders.ads +++ b/src/alire/alire-platforms-folders.ads @@ -15,4 +15,7 @@ package Alire.Platforms.Folders is -- On Linux/macOS it is ${XDG_CACHE_HOME:-$HOME/.cache}/alire -- On Windows it is $Homedrive:$Homepath\.cache\alire + function Home return Absolute_Path; + -- $HOME (Linux/macOS) or $Homedrive:$Homepath (Windows) + end Alire.Platforms.Folders; diff --git a/src/alire/alire-releases.adb b/src/alire/alire-releases.adb index dde91b55..fc478120 100644 --- a/src/alire/alire-releases.adb +++ b/src/alire/alire-releases.adb @@ -670,6 +670,7 @@ package body Alire.Releases is return AAA.Strings.Vector is use AAA.Strings; + use all type Origins.Kinds; With_Paths : AAA.Strings.Vector := Props_To_Strings (R.All_Properties (P), Project_File); @@ -677,10 +678,10 @@ package body Alire.Releases is begin if With_Paths.Is_Empty and then - R.Origin.Kind not in Origins.External | Origins.System + R.Origin.Kind not in Binary_Archive | External | System then -- Default project file if no one is specified by the crate. Only if - -- the create is not external nor system. + -- the create is not binary, external nor system. With_Paths.Append (String'((+R.Name) & ".gpr")); end if; diff --git a/src/alire/alire-vfs.ads b/src/alire/alire-vfs.ads index 41344d8b..2f406f9c 100644 --- a/src/alire/alire-vfs.ads +++ b/src/alire/alire-vfs.ads @@ -52,6 +52,10 @@ package Alire.VFS is -- A virtual file is the portable wrapper over file/dir names, that may -- then exists or not on disk. + function New_Virtual_File (Path : Any_Path) return Virtual_File + is (New_Virtual_File (From_FS (Path))); + -- Just a shortcut + -- Name retrieval function Simple_Name (File : Virtual_File) return Filesystem_String with diff --git a/src/alire/alire.adb b/src/alire/alire.adb index 292d3b96..f8c332d4 100644 --- a/src/alire/alire.adb +++ b/src/alire/alire.adb @@ -47,6 +47,16 @@ package body Alire is Put_Line (Standard_Error, "stderr: " & S); end Err_Log; + --------- + -- Log -- + --------- + + function Log (Text : String; Level : Trace.Levels := Info) return String is + begin + Trace.Log (Text, Level); + return Text; + end Log; + ------------------- -- Log_Exception -- ------------------- diff --git a/src/alire/alire.ads b/src/alire/alire.ads index 79966aeb..b41bd75e 100644 --- a/src/alire/alire.ads +++ b/src/alire/alire.ads @@ -283,6 +283,9 @@ package Alire with Preelaborate is -- the opposite of Put_Success when it makes sense to continue, albeit -- briefly, without emitting a final error with Raise_Checked_Error. + function Log (Text : String; Level : Trace.Levels := Info) return String; + -- A convenience to be able to log inside declarative blocks. Returns Text. + --------------- -- Constants -- --------------- diff --git a/src/alire/os_linux/alire-platforms-folders__linux.adb b/src/alire/os_linux/alire-platforms-folders__linux.adb index fdff8061..0f9147c4 100644 --- a/src/alire/os_linux/alire-platforms-folders__linux.adb +++ b/src/alire/os_linux/alire-platforms-folders__linux.adb @@ -16,4 +16,10 @@ package body Alire.Platforms.Folders is function Config return String is (Common.XDG_Config_Folder); + ---------- + -- Home -- + ---------- + + function Home return Absolute_Path is (Common.Unix_Home_Folder); + end Alire.Platforms.Folders; diff --git a/src/alire/os_macos/alire-platforms-folders__macos.adb b/src/alire/os_macos/alire-platforms-folders__macos.adb index d359c8f8..ecd30f6b 100644 --- a/src/alire/os_macos/alire-platforms-folders__macos.adb +++ b/src/alire/os_macos/alire-platforms-folders__macos.adb @@ -16,4 +16,10 @@ package body Alire.Platforms.Folders is function Config return String is (Common.XDG_Config_Folder); + ---------- + -- Home -- + ---------- + + function Home return Absolute_Path is (Common.Unix_Home_Folder); + end Alire.Platforms.Folders; diff --git a/src/alire/os_windows/alire-platforms-folders__windows.adb b/src/alire/os_windows/alire-platforms-folders__windows.adb index 56d65b7e..f7b66a29 100644 --- a/src/alire/os_windows/alire-platforms-folders__windows.adb +++ b/src/alire/os_windows/alire-platforms-folders__windows.adb @@ -1,12 +1,14 @@ -with Alire.OS_Lib; use Alire.OS_Lib; +with Alire.OS_Lib; package body Alire.Platforms.Folders is + use OS_Lib.Operators; + ---------- -- Home -- ---------- - function Home return String + function Home return Absolute_Path is (OS_Lib.Getenv ("HOMEDRIVE") & OS_Lib.Getenv ("HOMEPATH")); ----------- diff --git a/src/alr/alr-commands-install.adb b/src/alr/alr-commands-install.adb new file mode 100644 index 00000000..a5fbf7c5 --- /dev/null +++ b/src/alr/alr-commands-install.adb @@ -0,0 +1,106 @@ +with Ada.Directories; + +with Alire.Dependencies.Containers; +with Alire.Install; + +package body Alr.Commands.Install is + + package Adirs renames Ada.Directories; + + -------------- + -- Validate -- + -------------- + + procedure Validate (Cmd : Command) is null; + -- Nothing to validate for now + + ------------- + -- Execute -- + ------------- + + overriding + procedure Execute (Cmd : in out Command; + Args : AAA.Strings.Vector) + is + Global_Prefix : constant Alire.Absolute_Path := + Adirs.Full_Name + (if Cmd.Prefix.all /= "" + then Cmd.Prefix.all + else Alire.Install.Default_Prefix); + begin + + Cmd.Validate; + + if Args.Is_Empty then + + -- Display info on default/given prefix. + + Alire.Install.Info (Global_Prefix); + + else + + -- Install every given dependency + + declare + Deps : Alire.Dependencies.Containers.List; + begin + for Img of Args loop + Deps.Append (Alire.Dependencies.From_String (Img)); + end loop; + + Alire.Install.Add (Global_Prefix, Deps); + end; + + end if; + end Execute; + + ---------------------- + -- Long_Description -- + ---------------------- + + Binaries : constant String := "gnat, gnatprove, gprbuild, gnatstudio"; + + overriding + function Long_Description (Cmd : Command) + return AAA.Strings.Vector + is (AAA.Strings.Empty_Vector + .Append ("Manages installations of releases to a common prefix.") + .Append ("The default install location is " + & TTY.URL (Alire.Install.Default_Prefix)) + .New_Line + .Append ("Installation prefixes are intended to make binaries or " + & "dynamic libraries available outside of the Alire environment, " + & "normally by adding the " & TTY.URL ("/bin") + & " folder to the user's path.") + .New_Line + .Append ("Although Alire will vet trivially detectable conflicts " + & "(e.g., trying to install two executable release with different " + & "versions), Alire is not aware of the exact binary artifacts " + & "produced by compiled crates. Thus, you are ""on your own"" in " + & "regard to the final consistency of installations.") + .New_Line + .Append ("That said, binary crates from the Alire project (" & Binaries + & "), as well as crates initialized with `alr` using default " + & "templates, should be able to coexist in a same installation prefix" + & " without issue.") + ); + + -------------------- + -- Setup_Switches -- + -------------------- + + overriding + procedure Setup_Switches + (Cmd : in out Command; + Config : in out CLIC.Subcommand.Switches_Configuration) + is + use CLIC.Subcommand; + begin + Define_Switch (Config, + Cmd.Prefix'Access, + "", "--prefix=", + "Override installation prefix (default is " + & TTY.URL ("${CRATE_ROOT}/alire/prefix)") & ")"); + end Setup_Switches; + +end Alr.Commands.Install; diff --git a/src/alr/alr-commands-install.ads b/src/alr/alr-commands-install.ads new file mode 100644 index 00000000..29c4041f --- /dev/null +++ b/src/alr/alr-commands-install.ads @@ -0,0 +1,45 @@ +with AAA.Strings; + +private with GNAT.Strings; + +package Alr.Commands.Install is + + type Command is new Commands.Command with private; + + overriding + function Name (Cmd : Command) return CLIC.Subcommand.Identifier + is ("install"); + + overriding + function Switch_Parsing (This : Command) + return CLIC.Subcommand.Switch_Parsing_Kind + is (CLIC.Subcommand.Parse_All); + -- For this command we want the args after -- to pass them to gprinstall + + overriding + procedure Execute (Cmd : in out Command; + Args : AAA.Strings.Vector); + + overriding + function Long_Description (Cmd : Command) + return AAA.Strings.Vector; + + overriding + procedure Setup_Switches + (Cmd : in out Command; + Config : in out CLIC.Subcommand.Switches_Configuration); + + overriding + function Short_Description (Cmd : Command) return String + is ("Manage installation prefixes"); + + overriding + function Usage_Custom_Parameters (Cmd : Command) return String + is ("[switches] [crate[versions]]..."); + +private + type Command is new Commands.Command with record + Target : aliased GNAT.Strings.String_Access; -- Crate[version] to install + Prefix : aliased GNAT.Strings.String_Access; -- Prefix for gprinstall + end record; +end Alr.Commands.Install; diff --git a/src/alr/alr-commands.adb b/src/alr/alr-commands.adb index e1da00e5..da4b0dd0 100644 --- a/src/alr/alr-commands.adb +++ b/src/alr/alr-commands.adb @@ -28,6 +28,7 @@ with Alr.Commands.Exec; with Alr.Commands.Get; with Alr.Commands.Index; with Alr.Commands.Init; +with Alr.Commands.Install; with Alr.Commands.Pin; with Alr.Commands.Printenv; with Alr.Commands.Publish; @@ -560,6 +561,7 @@ begin -- Commands -- Sub_Cmd.Register ("General", new Sub_Cmd.Builtin_Help); Sub_Cmd.Register ("General", new Config.Command); + Sub_Cmd.Register ("General", new Install.Command); Sub_Cmd.Register ("General", new Toolchain.Command); Sub_Cmd.Register ("General", new Version.Command); diff --git a/testsuite/tests/install/binary-release/my_index/crates/crate/crate.tgz b/testsuite/tests/install/binary-release/my_index/crates/crate/crate.tgz new file mode 100644 index 0000000000000000000000000000000000000000..a8623c93b8abbc9765a6635232e4a54b7c7ccc6e GIT binary patch literal 10240 zcmeH}%Wi`(5JkP_E8KKn#xK0@wu^oPK@=QSAOZRR+R&ybivUTiR_*ly8_ffAE@P(X z@}W#w)Iok&W0;?WH8h`tDGVmG%9ON}Y40Z}lNsYC>aISMANwKiIA@2vX)ir*$$lyJ z7u$+a|EJ0gu4>w@jIq@qaHjQK_pk3Dn23})>2FAS{bfd)af-2-^PK-&|Fqp7(j?ux z#$WSy*Oh)Q+UCtwX>!gA_kWJSRR4XQd*NffTqyCi=l@jy!b-yVA4`vU-nstMdTzbX zdb|FL1pfc`fxnPt(mWjh3ywFKSL?6HNag!OA$&84`o97B>dXz@GUBkyufxo`&&;ee{6>%T{0w4eaAOHd&00JNY c0w4eaAOHd&00JNY0w4eaAOHd&@KXdn0PT*9F#rGn literal 0 HcmV?d00001 diff --git a/testsuite/tests/install/binary-release/my_index/index/cr/crate/crate-0.1.0.toml b/testsuite/tests/install/binary-release/my_index/index/cr/crate/crate-0.1.0.toml new file mode 100644 index 00000000..ae06716d --- /dev/null +++ b/testsuite/tests/install/binary-release/my_index/index/cr/crate/crate-0.1.0.toml @@ -0,0 +1,10 @@ +description = "Sample crate" +name = "crate" +version = "0.1.0" +licenses = [] +maintainers = ["any@bo.dy"] +maintainers-logins = ["someone"] + +[origin."case(os)"."linux"."case(word-size)".bits-64] +url = "file:../../../crates/crate/crate.tgz" +hashes = ["sha256:d35efed8325f646652f533fa4094d580cf28bccc9cc1d85751738b446bbed37a"] \ No newline at end of file diff --git a/testsuite/tests/install/binary-release/my_index/index/cr/crate/crate-1.0.0.toml b/testsuite/tests/install/binary-release/my_index/index/cr/crate/crate-1.0.0.toml new file mode 100644 index 00000000..cad1d115 --- /dev/null +++ b/testsuite/tests/install/binary-release/my_index/index/cr/crate/crate-1.0.0.toml @@ -0,0 +1,10 @@ +description = "Sample crate" +name = "crate" +version = "1.0.0" +licenses = [] +maintainers = ["any@bo.dy"] +maintainers-logins = ["someone"] + +[origin."case(os)"."linux"."case(word-size)".bits-64] +url = "file:../../../crates/crate/crate.tgz" +hashes = ["sha256:d35efed8325f646652f533fa4094d580cf28bccc9cc1d85751738b446bbed37a"] \ No newline at end of file diff --git a/testsuite/tests/install/binary-release/my_index/index/index.toml b/testsuite/tests/install/binary-release/my_index/index/index.toml new file mode 100644 index 00000000..c2a2c7db --- /dev/null +++ b/testsuite/tests/install/binary-release/my_index/index/index.toml @@ -0,0 +1 @@ +version = "1.2" diff --git a/testsuite/tests/install/binary-release/test.py b/testsuite/tests/install/binary-release/test.py new file mode 100644 index 00000000..33a20916 --- /dev/null +++ b/testsuite/tests/install/binary-release/test.py @@ -0,0 +1,64 @@ +""" +Test deployment of a binary release and basic `alr install` use +""" + +# NOTE: this test only runs on Linux + +from drivers.alr import run_alr, init_local_crate +from drivers.asserts import assert_eq, assert_match +from subprocess import run + +import platform +import os + +if platform.system() != "Linux": + print('SUCCESS') + exit(0) + +PREFIX=f"--prefix={os.getcwd()}/install" + +# Check that the prefix is empty +p = run_alr("install", PREFIX, quiet=False) +assert_match("There is no installation at prefix .*", + p.out) + +# Install the binary crate +p = run_alr("install", PREFIX, "crate", quiet=False) +assert_eq("""Note: Deploying crate=1.0.0... +Note: Installing crate=1.0.0... +Note: Installation complete. +""", + p.out) + +# Verify it's runnable at the expected place +p = run(f"{os.getcwd()}/install/bin/crate", capture_output=True) +assert p.returncode == 0, \ + f"Unexpected output, stdout: {p.stdout}, stderr: {p.stderr}" +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.*", + run_alr("install", PREFIX, "crate", + quiet=False, complain_on_error=False).out) + +# Verify another version cannot be installed +assert_match(".*Requested release crate=0.1.0 has another version already installed: crate=1.0.0.*", + run_alr("install", PREFIX, "crate=0.1.0", + quiet=False, complain_on_error=False).out) + +# Force install of the same crate and see no failure +run_alr("install", PREFIX, "crate=0.1.0", force=True) + +# Recheck output +p = run(f"{os.getcwd()}/install/bin/crate", capture_output=True) +assert_eq("Bin crate OK\n", p.stdout.decode()) + +# Check contents of the prefix +p = run_alr("install", PREFIX, quiet=False) +assert_match("""Installation prefix found at .* +Contents: + crate=0.1.0 +""", + p.out) + +print('SUCCESS') \ No newline at end of file diff --git a/testsuite/tests/install/binary-release/test.yaml b/testsuite/tests/install/binary-release/test.yaml new file mode 100644 index 00000000..0a859639 --- /dev/null +++ b/testsuite/tests/install/binary-release/test.yaml @@ -0,0 +1,4 @@ +driver: python-script +indexes: + my_index: + in_fixtures: false -- 2.39.5