Debug/rmtree noraise

.github/workflows/ci-macos.yml

@@ -33,22 +33,13 @@ jobs:
       with:
         python-version: '3.x'
 
-    - name: Run test script (without Homebrew)
+    - name: Run test script
       run: scripts/ci-github.sh
       shell: bash
       env:
         BRANCH: ${{ github.base_ref }}
         INDEX: ""
 
-    - name: Run test script (with Homebrew)
-      run: |
-        eval $(brew shellenv)
-        scripts/ci-github.sh
-      shell: bash
-      env:
-        BRANCH: ${{ github.base_ref }}
-        INDEX: ""
-
     - name: Upload binaries
       uses: actions/upload-artifact@v2
       with:

alire.toml

@@ -45,7 +45,7 @@ windows = { ALIRE_OS = "windows" }
 
 # Some dependencies require precise versions during the development cycle:
 [[pins]]
-aaa = { url = "https://github.com/mosteo/aaa", commit = "fbfffb1cb269a852201d172119d94f3024b617f2" }
+aaa = { url = "https://github.com/mosteo/aaa", commit = "c3b5a19adac66f42be45e22694c9463997b4f756" }
 ada_toml = { url = "https://github.com/mosteo/ada-toml", commit = "da4e59c382ceb0de6733d571ecbab7ea4919b33d" }
 clic = { url = "https://github.com/alire-project/clic", commit = "6879b90876a1c918b4e112f59c6db0e25b713f52" }
 gnatcoll = { url = "https://github.com/alire-project/gnatcoll-core.git", commit = "4e663b87a028252e7e074f054f8f453661397166" }

src/alire/alire-builds-hashes.adb

@@ -0,0 +1,155 @@
+with Alire.Directories;
+with Alire.Hashes.SHA256_Impl;
+with Alire.Paths;
+with Alire.Roots;
+with Alire.Utils.Text_Files;
+
+package body Alire.Builds.Hashes is
+
+   use Directories.Operators;
+
+   package SHA renames Alire.Hashes.SHA256_Impl;
+
+   subtype Variables is AAA.Strings.Set;
+   --  We'll store all variables that affect a Release in a deterministic order
+
+   -----------
+   -- Clear --
+   -----------
+
+   procedure Clear (This : in out Hasher) is
+   begin
+      This.Hashes.Clear;
+   end Clear;
+
+   --------------
+   -- Is_Empty --
+   --------------
+
+   function Is_Empty (This : Hasher) return Boolean
+   is (This.Hashes.Is_Empty);
+
+   -------------
+   -- Compute --
+   -------------
+
+   procedure Compute (This : in out Hasher;
+                      Root : in out Roots.Root)
+   is
+
+      -------------
+      -- Compute --
+      -------------
+
+      procedure Compute (Rel : Releases.Release) is
+         Vars : Variables;
+
+         ---------
+         -- Add --
+         ---------
+
+         procedure Add (Kind, Key, Value : String) is
+            use AAA.Strings;
+            Datum : constant String :=
+                      Trim (Kind) & ":"
+                      & Trim (Key) & "="
+                      & Trim (Value);
+         begin
+            Trace.Debug ("      build hashing " & Datum);
+            Vars.Insert (Datum);
+         end Add;
+
+         ------------------
+         -- Compute_Hash --
+         ------------------
+
+         procedure Compute_Hash is
+            C : SHA.Hashing_Context;
+         begin
+            for Var of Vars loop
+               SHA.Update (C, Var, Append_Nul => True);
+               --  The nul character as separator ensures no ambiguity because
+               --  of consecutive entries.
+            end loop;
+
+            This.Hashes.Insert (Rel.Name, SHA.Get_Digest (C));
+         end Compute_Hash;
+
+         ------------------
+         -- Write_Inputs --
+         ------------------
+
+         procedure Write_Inputs is
+            File : constant Absolute_Path :=
+                     Builds.Path
+                       / Rel.Base_Folder & "_" & This.Hashes (Rel.Name)
+                       / Paths.Working_Folder_Inside_Root
+                       / "build_hash_inputs";
+            use Directories;
+            use Utils.Text_Files;
+
+            Lines : AAA.Strings.Vector;
+         begin
+            --  First ensure we have a pristine file to work with
+            Delete_Tree (File);
+            Create_Tree (Parent (File));
+            Touch (File);
+
+            --  Now add the hashed contents for the record
+
+            for Var of Vars loop
+               Lines.Append (Var);
+            end loop;
+
+            Append_Lines (File,
+                          Lines,
+                          Backup => False);
+         end Write_Inputs;
+
+      begin
+         Trace.Debug ("   build hashing: " & Rel.Milestone.TTY_Image);
+
+         --  Build profile
+         Add ("profile",
+              Rel.Name.As_String,
+              Root.Configuration.Build_Profile (Rel.Name)'Image);
+
+         --  GPR externals
+         --  TBD
+
+         --  Environment variables
+         --  TBD
+
+         --  Configuration variables
+         --  TBD
+
+         --  Final computation
+         Compute_Hash;
+
+         --  Write the hash input for the record
+         Write_Inputs;
+
+         Trace.Debug ("   build hashing release complete");
+      end Compute;
+
+   begin
+      Trace.Debug ("build hashing root " & Root.Path);
+      This.Hashes.Clear;
+
+      for Rel of Root.Solution.Releases loop
+         if Root.Requires_Build_Sync (Rel) then
+            Compute (Rel);
+         end if;
+      end loop;
+   end Compute;
+
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash (This : in out Hasher;
+                  Name : Crate_Name)
+                  return String
+   is (This.Hashes (Name));
+
+end Alire.Builds.Hashes;

src/alire/alire-builds-hashes.ads

@@ -0,0 +1,35 @@
+private with Ada.Containers.Indefinite_Ordered_Maps;
+
+limited with Alire.Roots;
+
+package Alire.Builds.Hashes is
+
+   type Hasher is tagged private;
+   --  Used to compute all build hashes for releases in a build
+
+   procedure Clear (This : in out Hasher);
+   --  Remove any cached hashes
+
+   function Is_Empty (This : Hasher) return Boolean;
+   --  Says if the Hasher has been used or not
+
+   procedure Compute (This : in out Hasher;
+                      Root : in out Roots.Root);
+   --  Compute all hashes needed for a release
+
+   function Hash (This : in out Hasher;
+                  Name : Crate_Name)
+                  return String
+     with Pre => not This.Is_Empty;
+   --  Retrieve the hash of a crate in Root's solution
+
+private
+
+   package Crate_Hash_Maps is new Ada.Containers.Indefinite_Ordered_Maps
+     (Crate_Name, String);
+
+   type Hasher is tagged record
+      Hashes : Crate_Hash_Maps.Map;
+   end record;
+
+end Alire.Builds.Hashes;

src/alire/alire-builds.adb

@@ -6,6 +6,7 @@ with Alire.OS_Lib.Subprocess;
 with Alire.Paths.Vault;
 with Alire.Platforms.Current;
 with Alire.Properties.Actions.Executor;
+with Alire.Roots;
 with Alire.Utils.Tools;
 
 package body Alire.Builds is
@@ -49,12 +50,13 @@ package body Alire.Builds is
    -- Sync --
    ----------
 
-   procedure Sync (Release   : Releases.Release;
+   procedure Sync (Root      : in out Roots.Root;
+                   Release   : Releases.Release;
                    Was_There : out Boolean)
    is
       Src       : constant Absolute_Path := Paths.Vault.Path
                                             / Release.Deployment_Folder;
-      Dst       : constant Absolute_Path := Builds.Path (Release);
+      Dst       : constant Absolute_Path := Builds.Path (Root, Release);
       Completed : Directories.Completion := Directories.New_Completion (Dst);
 
       use AAA.Strings;
@@ -126,10 +128,12 @@ package body Alire.Builds is
    -- Path --
    ----------
 
-   function Path (Release : Releases.Release) return Absolute_Path
+   function Path (Root    : in out Roots.Root;
+                  Release : Releases.Release)
+                  return Absolute_Path
    is (Builds.Path
        / (Release.Deployment_Folder
-         & "_deadbeef"));
-   --  TODO: implement actual hashing of environment for a release
+         & "_"
+         & Root.Build_Hash (Release.Name)));
 
 end Alire.Builds;

src/alire/alire-builds.ads

@@ -1,4 +1,5 @@
 with Alire.Releases;
+limited with Alire.Roots;
 
 package Alire.Builds is
 
@@ -29,14 +30,17 @@ package Alire.Builds is
    function Sandboxed_Dependencies return Boolean;
    --  Queries config to see if dependencies should be sandboxed in workspace
 
-   procedure Sync (Release   : Releases.Release;
+   procedure Sync (Root      : in out Roots.Root;
+                   Release   : Releases.Release;
                    Was_There : out Boolean)
      with Pre => Release.Origin.Requires_Build;
 
    function Path return Absolute_Path;
    --  Location of shared builds
 
-   function Path (Release : Releases.Release) return Absolute_Path;
+   function Path (Root    : in out Roots.Root;
+                  Release : Releases.Release)
+                  return Absolute_Path;
    --  Computes the complete path in which the release is going to be built
 
 end Alire.Builds;

src/alire/alire-directories.adb

@@ -238,9 +238,17 @@ package body Alire.Directories is
    -- Force_Delete --
    ------------------
 
-   procedure Force_Delete (Path : Any_Path) is
+   procedure Force_Delete (Path : Absolute_Path) is
       use Ada.Directories;
    begin
+
+      --  Given that we never delete anything outside one of our folders, the
+      --  conservatively shortest thing we can be asked to delete is something
+      --  like "/c/alire". This is for peace of mind.
+      if Path'Length < 8 then
+         Recoverable_Error ("Suspicious deletion request for path: " & Path);
+      end if;
+
       if Exists (Path) then
          if Kind (Path) = Ordinary_File then
             Trace.Debug ("Deleting file " & Path & "...");
@@ -253,6 +261,32 @@ package body Alire.Directories is
             Adirs.Delete_Tree (Path);
          end if;
       end if;
+   exception
+      when E : others =>
+         Trace.Error ("Could not delete: " & Path);
+         Log_Exception (E, Error);
+         Trace.Error ("Contents follow: ");
+         declare
+            use AAA.Strings;
+            use Platforms.Current;
+            Output : Vector;
+            Code   : constant Integer :=
+                       OS_Lib.Subprocess.Unchecked_Spawn_And_Capture
+                         ((if On_Windows then "dir" else "ls"),
+                          (if On_Windows
+                           then To_Vector ("/a/o/q/r/s")
+                           else To_Vector ("-alRF")),
+                          Output,
+                          Err_To_Out => True);
+         begin
+            if Code = 0 then
+               Trace.Error (Output.Flatten (New_Line));
+            else
+               Trace.Error ("Contents listing failed with code: "
+                            & Code'Image);
+            end if;
+         end;
+         --  raise;
    end Force_Delete;
 
    ----------------------

src/alire/alire-directories.ads

@@ -51,10 +51,10 @@ package Alire.Directories is
    --  In Windows, git checkouts are created with read-only file that do not
    --  sit well with Ada.Directories.Delete_Tree.
 
-   procedure Force_Delete (Path : Any_Path);
+   procedure Force_Delete (Path : Absolute_Path);
    --  Calls Ensure_Deletable and then uses GNATCOLL.VFS deletion
 
-   procedure Delete_Tree (Path : Any_Path) renames Force_Delete;
+   procedure Delete_Tree (Path : Absolute_Path) renames Force_Delete;
    --  Delete Path, and anythin below if it was a dir
 
    function Find_Files_Under (Folder    : String;

src/alire/alire-hashes-common.adb

@@ -32,6 +32,25 @@ package body Alire.Hashes.Common is
          raise;
    end Hash_File;
 
+   ------------
+   -- Update --
+   ------------
+
+   procedure Update (C          : in out Context;
+                     S          : String;
+                     Append_Nul : Boolean := True)
+   is
+      use Ada.Streams;
+      Bytes : Stream_Element_Array (1 .. S'Length)
+        with Address => S (S'First)'Address, Import;
+      pragma Assert (Bytes'Size = S (S'Range)'Size);
+   begin
+      Update (C, Bytes);
+      if Append_Nul then
+         Update (C, Stream_Element_Array'(1 .. 1 => 0));
+      end if;
+   end Update;
+
 begin
    Hashes.Hash_Functions (Kind) := Hash_File'Access;
 end Alire.Hashes.Common;