From 134d1157c18fd711533a5f9763ddc7dd9716ce54 Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Wed, 7 Aug 2024 14:40:08 +0200 Subject: [PATCH] New `alr cache` (#1642) * Basic report * Test debug * Bump ncdu crate * Debug issue with disappearing folder * Refactor ncdu into den * Self-review --- .gitmodules | 6 + alire.gpr | 2 + alire.toml | 13 +- alr_env.gpr | 2 + deps/aaa | 2 +- deps/cstrings | 1 + deps/den | 1 + src/alire/alire-builds.adb | 6 +- src/alire/alire-cache.adb | 126 ++++++++++++++++++ src/alire/alire-cache.ads | 111 +++++++++++++++ src/alire/alire-paths-vault.ads | 4 +- src/alire/alire-settings-edit.adb | 12 -- src/alire/alire-settings-edit.ads | 7 - src/alire/alire-toolchains.adb | 5 +- .../alire-settings-builtins-windows.ads | 3 +- src/alr/alr-commands-cache.adb | 42 ++++++ src/alr/alr-commands-cache.ads | 43 ++++++ src/alr/alr-commands-skeleton.ads | 2 +- src/alr/alr-commands-version.adb | 3 +- src/alr/alr-commands.adb | 2 + testsuite/tests/cache/summary/test.py | 52 ++++++++ testsuite/tests/cache/summary/test.yaml | 5 + 22 files changed, 419 insertions(+), 31 deletions(-) create mode 160000 deps/cstrings create mode 160000 deps/den create mode 100644 src/alire/alire-cache.adb create mode 100644 src/alire/alire-cache.ads create mode 100644 src/alr/alr-commands-cache.adb create mode 100644 src/alr/alr-commands-cache.ads create mode 100644 testsuite/tests/cache/summary/test.py create mode 100644 testsuite/tests/cache/summary/test.yaml diff --git a/.gitmodules b/.gitmodules index fc56fd8e..ec5a589b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -60,3 +60,9 @@ [submodule "deps/dirty_booleans"] path = deps/dirty_booleans url = https://github.com/mosteo/dirty_booleans +[submodule "deps/den"] + path = deps/den + url = https://github.com/mosteo/den +[submodule "deps/cstrings"] + path = deps/cstrings + url = https://github.com/mosteo/cstrings diff --git a/alire.gpr b/alire.gpr index c15a633c..a00b73f3 100644 --- a/alire.gpr +++ b/alire.gpr @@ -3,7 +3,9 @@ with "ada_toml"; with "alire_common"; with "ajunitgen"; with "ansiada"; +with "c_strings"; with "clic"; +with "den"; with "dirty_booleans"; with "diskflags"; with "gnatcoll"; diff --git a/alire.toml b/alire.toml index 7fb33a2c..a2e72c92 100644 --- a/alire.toml +++ b/alire.toml @@ -19,7 +19,9 @@ aaa = "~0.3.0" ada_toml = "~0.3" ajunitgen = "^1.0.1" ansiada = "^1.0" +c_strings = "^1.0" clic = "~0.3" +den = "~0.1" dirty_booleans = "~0.1" diskflags = "~0.1" gnatcoll = "^21" @@ -48,18 +50,27 @@ windows = { ALIRE_OS = "windows" } # Some dependencies require precise versions during the development cycle: [[pins]] + [pins.aaa] url = "https://github.com/mosteo/aaa" -commit = "dff61d2615cc6332fa6205267bae19b4d044b9da" +commit = "0c3b440ac183c450345d4a67d407785678779aae" [pins.ada_toml] url = "https://github.com/mosteo/ada-toml" commit = "da4e59c382ceb0de6733d571ecbab7ea4919b33d" +[pins.c_strings] +url = "https://github.com/mosteo/cstrings" +commit = "e4d58ad90bf32bc44304197e5906a519f5a9a7bf" + [pins.clic] url = "https://github.com/alire-project/clic" commit = "56bbdc008e16996b6f76e443fd0165a240de1b13" +[pins.den] +url = "https://github.com/mosteo/den" +commit = "35d1f38395b93766dd64bca5901ce3b6a416ba1a" + [pins.dirty_booleans] url = "https://github.com/mosteo/dirty_booleans" commit = "05c40d88ecfe109e575ec8b21dd6ffa2e61df1dc" diff --git a/alr_env.gpr b/alr_env.gpr index b391c975..78592c5e 100644 --- a/alr_env.gpr +++ b/alr_env.gpr @@ -14,6 +14,8 @@ aggregate project Alr_Env is "deps/ajunitgen", "deps/ansi", "deps/clic", + "deps/cstrings", + "deps/den", "deps/dirty_booleans", "deps/diskflags", "deps/gnatcoll-slim", diff --git a/deps/aaa b/deps/aaa index dff61d26..0c3b440a 160000 --- a/deps/aaa +++ b/deps/aaa @@ -1 +1 @@ -Subproject commit dff61d2615cc6332fa6205267bae19b4d044b9da +Subproject commit 0c3b440ac183c450345d4a67d407785678779aae diff --git a/deps/cstrings b/deps/cstrings new file mode 160000 index 00000000..e4d58ad9 --- /dev/null +++ b/deps/cstrings @@ -0,0 +1 @@ +Subproject commit e4d58ad90bf32bc44304197e5906a519f5a9a7bf diff --git a/deps/den b/deps/den new file mode 160000 index 00000000..35d1f383 --- /dev/null +++ b/deps/den @@ -0,0 +1 @@ +Subproject commit 35d1f38395b93766dd64bca5901ce3b6a416ba1a diff --git a/src/alire/alire-builds.adb b/src/alire/alire-builds.adb index f15ea004..9593c1c7 100644 --- a/src/alire/alire-builds.adb +++ b/src/alire/alire-builds.adb @@ -1,11 +1,11 @@ with AAA.Strings; -with Alire.Settings.Builtins; -with Alire.Settings.Edit; +with Alire.Cache; with Alire.Directories; with Alire.Flags; with Alire.Paths.Vault; with Alire.Roots; +with Alire.Settings.Builtins; with GNATCOLL.VFS; @@ -83,7 +83,7 @@ package body Alire.Builds is ---------- function Path return Absolute_Path - is (Settings.Edit.Cache_Path + is (Cache.Path / Paths.Build_Folder_Inside_Working_Folder); ---------- diff --git a/src/alire/alire-cache.adb b/src/alire/alire-cache.adb new file mode 100644 index 00000000..e6aade61 --- /dev/null +++ b/src/alire/alire-cache.adb @@ -0,0 +1,126 @@ +with Ada.Calendar; + +with Alire.Directories; +with Alire.Paths; +with Alire.Platforms.Folders; +with Alire.Settings.Builtins; +with Alire.Settings.Edit; + +with Den.Du; + +package body Alire.Cache is + + use Alire.Directories.Operators; + + package Adirs renames Ada.Directories; + package Du is new Den.Du; + + ---------- + -- Path -- + ---------- + + function Path return Absolute_Path + is (if Settings.Builtins.Cache_Dir.Get /= "" then + Settings.Builtins.Cache_Dir.Get + elsif not Settings.Edit.Is_At_Default_Dir then + Settings.Edit.Path / Paths.Cache_Folder_Inside_Working_Folder + else + Platforms.Folders.Cache); + + ----------- + -- Usage -- + ----------- + + function Usage return Usages is + + Busy_Top : Simple_Logging.Ongoing := + Simple_Logging.Activity ("Listing"); + + Busy : Simple_Logging.Ongoing := Simple_Logging.Activity (""); + + Last_Check : Ada.Calendar.Time := Ada.Calendar.Clock; + + -------------- + -- Progress -- + -------------- + + procedure Progress (Path : String) is + use Ada.Calendar; + begin + if Clock - Last_Check >= 0.1 + and then Directories.Is_File (Path / Alire.Paths.Crate_File_Name) + then + Busy_Top.Step; + Busy.Step (Adirs.Simple_Name (Path)); + Last_Check := Clock; + end if; + end Progress; + + Tree : constant Du.Tree := Du.List (Path, + Progress => Progress'Access); + + ---------------- + -- Usage_Wrap -- + ---------------- + + procedure Usage_Wrap (Parent : in out Usages; + Children : Du.Tree; + Depth : Depths; + Branch : String := "" + -- Says if toolchains, releases, or builds + ) + is + begin + for Child of Children loop + declare + Branch : constant String + := (if Usage_Wrap.Branch /= "" + then Usage_Wrap.Branch + else Adirs.Simple_Name (Child.Element.Path)); + Wrapped_Children : Usages; + begin + + -- Wrap the children if we still have room to go down + + if Depth < Release or else + (Depth < Build + and then Branch = Paths.Build_Folder_Inside_Working_Folder) + then + Usage_Wrap (Wrapped_Children, + Child.Element.Children, + Depth => Depths'Succ (Depth), + Branch => Branch); + end if; + + -- Create the wrapped node at the current depth + + Parent.Insert + (Item' + (Depth => Depth, + Name => +Adirs.Simple_Name (Child.Element.Path), + Path => +Child.Element.Path, + Size => Child.Tree_Size, + Children => Wrapped_Children)); + end; + end loop; + end Usage_Wrap; + + begin + -- The root node should be the cache dir itself, unless there is still + -- no cache at all. + if Tree.Is_Empty then + return Item_Sets.Empty_Set; + elsif Tree.Length not in 1 then + raise Program_Error + with "Cache tree root length /= 1:" & Tree.Length'Image; + end if; + + -- Iterate the obtained tree wrapping contents as our usage type + return Result : Usages do + Usage_Wrap (Result, + Tree.First_Element.Element.Children, + Depths'First); + end return; + end Usage; + +end Alire.Cache; diff --git a/src/alire/alire-cache.ads b/src/alire/alire-cache.ads new file mode 100644 index 00000000..de930e04 --- /dev/null +++ b/src/alire/alire-cache.ads @@ -0,0 +1,111 @@ +with Ada.Containers.Indefinite_Ordered_Multisets; +with Ada.Directories; + +package Alire.Cache is + + -- Cache inspection and management. The cache is where we store all data + -- that, if not found, is re-downloaded or regenerated. This currently + -- comprises toolchains, pristine releases (the vault), builds, and the + -- user index fork clone when publishing. + + function Path return Absolute_Path; + -- The location for data that will be recreated if missing; its value in + -- precedence order is: + -- 1) Setting builtin 'cache.dir' + -- 2) if Alire.Settings.Path is overridden, Settings.Path/cache + -- 3) Platforms.Folders.Cache + + subtype Sizes is Ada.Directories.File_Size; + -- A size, in bytes + + -- The following builds a tree of items in the cache, that can be queried + -- to present information up to a level of detail. + + type Depths is (Location, Release, Build); + -- Locations are the top-level folders: toolchains, releases, builds. + -- Releases are a unique release milestone plus short commit. + -- Builds are synced copies for a release, named as the release + build id. + + type Base_Item is abstract tagged null record; + + function "<" (L, R : Base_Item'Class) return Boolean; + + function Depth (This : Base_Item'Class) return Depths; + + function Name (This : Base_Item'Class) return String; + + function Path (This : Base_Item'Class) return Absolute_Path; + + function Size (This : Base_Item'Class) return Sizes; + + package Item_Sets is + new Ada.Containers.Indefinite_Ordered_Multisets (Base_Item'Class); + + subtype Usages is Item_Sets.Set; + + function Children (This : Base_Item'Class) return Usages; + + function Usage return Usages; + -- Compute cache usage. First level is locations, second level is releases, + -- third level is builds. Within level, childen are sorted by size. + + type Item is new Base_Item with record + Depth : Depths; + Name : UString; + Path : Unbounded_Absolute_Path; + Size : Sizes; -- Accumulated size below this item + Children : Usages; + end record; + + function Element (This : Base_Item'Class) return Item is (Item (This)) + with Inline; + +private + + use type Sizes; + + -------------- + -- Children -- + -------------- + + function Children (This : Base_Item'Class) return Usages + is (This.Element.Children); + + ----------- + -- Depth -- + ----------- + + function Depth (This : Base_Item'Class) return Depths + is (This.Element.Depth); + + ---------- + -- Name -- + ---------- + + function Name (This : Base_Item'Class) return String + is (UStrings.To_String (This.Element.Name)); + + ---------- + -- Path -- + ---------- + + function Path (This : Base_Item'Class) return Absolute_Path + is (Absolute_Path (UStrings.To_String (This.Element.Path))); + + ---------- + -- Size -- + ---------- + + function Size (This : Base_Item'Class) return Sizes is (This.Element.Size); + + --------- + -- "<" -- + --------- + + function "<" (L, R : Base_Item'Class) return Boolean + is (L.Size > R.Size + or else + (L.Size = R.Size + and then L.Name < R.Name)); + +end Alire.Cache; diff --git a/src/alire/alire-paths-vault.ads b/src/alire/alire-paths-vault.ads index 0c6b1eeb..274ba14b 100644 --- a/src/alire/alire-paths-vault.ads +++ b/src/alire/alire-paths-vault.ads @@ -1,4 +1,4 @@ -with Alire.Settings.Edit; +with Alire.Cache; package Alire.Paths.Vault is @@ -10,7 +10,7 @@ package Alire.Paths.Vault is -- are run there (see Alire.Builds). function Path return Absolute_Path - is (Settings.Edit.Cache_Path + is (Cache.Path / Release_Folder_Inside_Working_Folder); end Alire.Paths.Vault; diff --git a/src/alire/alire-settings-edit.adb b/src/alire/alire-settings-edit.adb index 61e5a9c3..dcc75117 100644 --- a/src/alire/alire-settings-edit.adb +++ b/src/alire/alire-settings-edit.adb @@ -242,18 +242,6 @@ package body Alire.Settings.Edit is end if; end Path; - ---------------- - -- Cache_Path -- - ---------------- - - function Cache_Path return Absolute_Path - is (if Builtins.Cache_Dir.Get /= "" then - Builtins.Cache_Dir.Get - elsif Path /= Default_Config_Path then - Path / Paths.Cache_Folder_Inside_Working_Folder - else - Platforms.Folders.Cache); - -------------- -- Set_Path -- -------------- diff --git a/src/alire/alire-settings-edit.ads b/src/alire/alire-settings-edit.ads index 196a66c9..495e644e 100644 --- a/src/alire/alire-settings-edit.ads +++ b/src/alire/alire-settings-edit.ads @@ -46,13 +46,6 @@ package Alire.Settings.Edit is -- * An ALIRE_SETTINGS_DIR env given folder -- * Default per-platform path (see alire-platforms-*) - function Cache_Path return Absolute_Path; - -- The location for data that will be recreated if missing; its value in - -- precedence order is: - -- 1) Setting builtin 'cache.dir' - -- 2) if Path above is overridden, Path/cache - -- 3) Platforms.Folders.Cache - procedure Set_Path (Path : Absolute_Path); -- Override global settings folder path diff --git a/src/alire/alire-toolchains.adb b/src/alire/alire-toolchains.adb index 08a118e4..560b0a49 100644 --- a/src/alire/alire-toolchains.adb +++ b/src/alire/alire-toolchains.adb @@ -3,7 +3,7 @@ with AAA.Text_IO; with Ada.Containers.Indefinite_Vectors; with Ada.Directories; -with Alire.Settings.Edit; +with Alire.Cache; with Alire.Directories; with Alire.Index; with Alire.Manifest; @@ -12,6 +12,7 @@ with Alire.Paths; with Alire.Platforms.Current; with Alire.Properties; with Alire.Root; +with Alire.Settings.Edit; with Alire.Toolchains.Solutions; with Alire.Warnings; @@ -610,7 +611,7 @@ package body Alire.Toolchains is function Path return Absolute_Path is (if Settings.Builtins.Toolchain_Dir.Get /= "" then Settings.Builtins.Toolchain_Dir.Get - else Settings.Edit.Cache_Path / "toolchains"); + else Cache.Path / "toolchains"); ------------ -- Deploy -- diff --git a/src/alire/os_windows/alire-settings-builtins-windows.ads b/src/alire/os_windows/alire-settings-builtins-windows.ads index cc27adc8..abeaccf5 100644 --- a/src/alire/os_windows/alire-settings-builtins-windows.ads +++ b/src/alire/os_windows/alire-settings-builtins-windows.ads @@ -1,4 +1,5 @@ -- Ensure config is loaded for some defaults below +with Alire.Cache; with Alire.Settings.Edit.Early_Load; pragma Unreferenced (Alire.Settings.Edit.Early_Load); @@ -24,7 +25,7 @@ package Alire.Settings.Builtins.Windows is Msys2_Install_Dir : constant Builtin := New_Builtin (Key => "msys2.install_dir", Kind => Stn_Absolute_Path, - Def => Settings.Edit.Cache_Path / "msys64", + Def => Cache.Path / "msys64", Help => "Directory where Alire will detect and/or install" & " msys2 system package manager. (Windows only)"); diff --git a/src/alr/alr-commands-cache.adb b/src/alr/alr-commands-cache.adb new file mode 100644 index 00000000..ee2c0451 --- /dev/null +++ b/src/alr/alr-commands-cache.adb @@ -0,0 +1,42 @@ +with Alire.Cache; +with Alire.Directories; +with Alire.Utils.Tables; + +package body Alr.Commands.Cache is + + ------------- + -- Summary -- + ------------- + + procedure Summary is + use Alire.Directories; + Table : Alire.Utils.Tables.Table; + Usage : constant Alire.Cache.Usages := Alire.Cache.Usage; + begin + Table + .Append ("Path:") + .Append (Alire.Cache.Path) + .New_Row; + + Table + .Append ("Size:") + .Append (TTY_Image (if Usage.Is_Empty + then 0 + else Alire.Cache.Usage.First_Element.Size)); + + Table.Print (Trace.Always); + end Summary; + + ------------- + -- Execute -- + ------------- + + overriding + procedure Execute (Cmd : in out Command; + Args : AAA.Strings.Vector) + is + begin + Summary; + end Execute; + +end Alr.Commands.Cache; diff --git a/src/alr/alr-commands-cache.ads b/src/alr/alr-commands-cache.ads new file mode 100644 index 00000000..2f933908 --- /dev/null +++ b/src/alr/alr-commands-cache.ads @@ -0,0 +1,43 @@ +with AAA.Strings; + +package Alr.Commands.Cache is + + type Command is new Commands.Command with private; + + overriding + function Name (Cmd : Command) return CLIC.Subcommand.Identifier + is ("cache"); + + overriding + procedure Execute (Cmd : in out Command; + Args : AAA.Strings.Vector); + -- This is called once the command-line is parsed. + + overriding + function Long_Description (Cmd : Command) + return AAA.Strings.Vector + is (AAA.Strings.Empty_Vector + .Append ("Inspect and manage Alire's cache.") + .New_Line + .Append ("Cache entries can be deleted to reclaim space and will be " + & "recreated on demand. Beware that deleting toolchains and releases " + & "may cause potentially large redownloads.")); + + overriding + procedure Setup_Switches + (Cmd : in out Command; + Config : in out CLIC.Subcommand.Switches_Configuration) is null; + + overriding + function Short_Description (Cmd : Command) return String + is ("Inspect and manage Alire's cache"); + + overriding + function Usage_Custom_Parameters (Cmd : Command) return String + is (""); + +private + + type Command is new Commands.Command with null record; + +end Alr.Commands.Cache; diff --git a/src/alr/alr-commands-skeleton.ads b/src/alr/alr-commands-skeleton.ads index 83ff18c8..ff2ec9b8 100644 --- a/src/alr/alr-commands-skeleton.ads +++ b/src/alr/alr-commands-skeleton.ads @@ -9,7 +9,7 @@ package Alr.Commands.Skeleton is type Command is new Commands.Command with private; overriding - function Name (Cmd : Command) return String + function Name (Cmd : Command) return CLIC.Subcommand.Identifier is ("skeleton"); overriding diff --git a/src/alr/alr-commands-version.adb b/src/alr/alr-commands-version.adb index f4fd73a3..b2d2fa30 100644 --- a/src/alr/alr-commands-version.adb +++ b/src/alr/alr-commands-version.adb @@ -1,4 +1,5 @@ with Alire.Builds; +with Alire.Cache; with Alire.Settings.Edit; with Alire.Directories; with Alire.Index; @@ -77,7 +78,7 @@ package body Alr.Commands.Version is Table.Append ("settings folder:") .Append (Alire.Settings.Edit.Path).New_Row; Table.Append ("cache folder:") - .Append (Alire.Settings.Edit.Cache_Path).New_Row; + .Append (Alire.Cache.Path).New_Row; Table.Append ("vault folder:").Append (Paths.Vault.Path).New_Row; Table.Append ("build folder:").Append (Build_Path).New_Row; Table.Append ("temp folder:") diff --git a/src/alr/alr-commands.adb b/src/alr/alr-commands.adb index 9ce78356..214546ee 100644 --- a/src/alr/alr-commands.adb +++ b/src/alr/alr-commands.adb @@ -23,6 +23,7 @@ with Alire.Toolchains; with Alr.Commands.Action; with Alr.Commands.Build; +with Alr.Commands.Cache; with Alr.Commands.Clean; with Alr.Commands.Config; with Alr.Commands.Dev; @@ -677,6 +678,7 @@ begin -- Commands -- Sub_Cmd.Register ("General", new Sub_Cmd.Builtin_Help); + Sub_Cmd.Register ("General", new Cache.Command); Sub_Cmd.Register ("General", new Settings.Command); Sub_Cmd.Register ("General", new Config.Command); Sub_Cmd.Register ("General", new Install.Command); diff --git a/testsuite/tests/cache/summary/test.py b/testsuite/tests/cache/summary/test.py new file mode 100644 index 00000000..238062e4 --- /dev/null +++ b/testsuite/tests/cache/summary/test.py @@ -0,0 +1,52 @@ +""" +Check the basic report of cache use +""" + +import os +import re +from drivers import builds +from drivers.alr import run_alr, init_local_crate, alr_with +from drivers.asserts import assert_eq, assert_match +from drivers.helpers import contents, dir_separator + +s = re.escape(dir_separator()) + +# Default cache status after clean install + +assert_match(f"""\ +Path:.*alr-config{s}cache +Size: 0.0 B +""", +run_alr("cache").out) + +# Compile something with a dependency and there should be something in the +# cache when builds are shared. + +init_local_crate() +alr_with("libhello") +run_alr("build") +p = run_alr("cache") +if builds.are_shared(): + # Something already in the cache + assert_match(r"Path:.*alr-config[/\\]cache\nSize: (?!0.0 B).*\n", p.out) +else: + # Still nothing if no shared cache + assert_match(r"Path:.*alr-config[/\\]cache\nSize: 0.0 B\n", p.out) + +# After installing some toolchain, for sure there should be something in the +# cache, as binaries always go into the cache. + +run_alr("toolchain", "--select", "gnat_native=1", "gprbuild") +try: + p = run_alr("cache") +except: + # Something strange is happening... + + # Print to stderr the type of file + print(f"EXISTS: {os.path.exists('alr-config/cache/toolchains/gprbuild_1.0.0_e3d52b4a/share/gprbuildalr-config/cache/toolchains/gprbuild_1.0.0_e3d52b4a/share/gprbuild')}", + file=os.stderr) + + assert_eq(run_alr("version").out, contents("../alr-config/cache")) +assert_match(r"Path:.*alr-config[/\\]cache\nSize: (?!0.0 B).*\n", p.out) + +print("SUCCESS") diff --git a/testsuite/tests/cache/summary/test.yaml b/testsuite/tests/cache/summary/test.yaml new file mode 100644 index 00000000..4e949dac --- /dev/null +++ b/testsuite/tests/cache/summary/test.yaml @@ -0,0 +1,5 @@ +driver: python-script +build_mode: both +indexes: + gnat_toolchain_index: {} + basic_index: {} -- 2.39.5