PR #210: Generalize integrity checking and implement it for git origins

Generalize integrity checking and implement it for git origins

.gitmodules

@@ -20,3 +20,6 @@
 	path = deps/gnatcoll-slim
 	url = https://github.com/alire-project/gnatcoll-core.git
 	branch = slim
+[submodule "testsuite/fixtures/crates/libhello_git"]
+	path = testsuite/fixtures/crates/libhello_git
+	url = https://github.com/alire-project/libhello.git

doc/catalog-format-spec.rst

@@ -244,12 +244,12 @@ entries:
    [depends-on.'case(os)'.windows]
    libwinbar = "^3.0"
 
-  Available constraint operators are the usual Ada ones (=, /=, >, >=, <, <=) 
-  plus caret (^, any upwards version within the same major point) and tilde 
+  Available constraint operators are the usual Ada ones (=, /=, >, >=, <, <=)
+  plus caret (^, any upwards version within the same major point) and tilde
   (~, any upwards version within the same minor point).
 
 * ``project-files``: optional list of strings. Each is a path, relative to the
-  root of the source directory, to a project file to be made available. 
+  root of the source directory, to a project file to be made available.
   Expressions are accepted. For instance:
 
   .. code-block:: toml
@@ -271,7 +271,7 @@ entries:
    TAG = ""
 
 * ``gpr-set-externals``: optional table, giving a mapping from the name of
-  external variables to the values to use by default when building the project.  
+  external variables to the values to use by default when building the project.
   Expressions are accepted before the mapping. For instance:
 
   .. code-block:: toml
@@ -291,7 +291,7 @@ entries:
 
    executables = ["bin/my_main"]
 
-* ``actions``: optional list of actions to perform when installing this package. 
+* ``actions``: optional list of actions to perform when installing this package.
   The general action syntax is:
 
   .. code-block:: toml
@@ -302,7 +302,7 @@ entries:
 
   ``<command>`` is a string for a shell command to run in the source directory.
   ``<kind>`` can be either:
- 
+
   * ``post-fetch``: the command is to be run right after getting the package
     sources;
   * ``post-compile``: the command is to be run right after GPRbuild has been
@@ -358,9 +358,9 @@ following entries:
    [origin.'case(distribution)']
    'debian|ubuntu' = "native:make"
 
-* ``archive-hash``: mandatory string for source archives. A "kind:digest" field
-  that specifies a hash kind and its value. The only accepted kind is SHA512 at
-  this time.
+* ``origin-hashes``: mandatory string array for git origins and source archives.
+  An array of "kind:digest" fields that specify a hash kind and its value.
+  Kinds accepted are: sha512.
 
 * ``archive-name``: optional string. If ``origin`` points to a source archive,
   this can specifiy the name of the file to download, which is needed in order

src/alire/alire-directories.adb

@@ -1,4 +1,5 @@
 with Ada.Exceptions;
+with Ada.Numerics.Discrete_Random;
 with Ada.Unchecked_Deallocation;
 
 with Alire.Paths;
@@ -218,4 +219,52 @@ package body Alire.Directories is
               Exception_Information (E));
    end Finalize;
 
+   ----------------
+   -- TEMP FILES --
+   ----------------
+
+   ----------------------
+   -- Create_Temp_File --
+   ----------------------
+
+   function Create_Temp_File return Temp_File is
+      subtype Valid_Character is Character range 'a' .. 'z';
+      package Char_Random is new
+        Ada.Numerics.Discrete_Random (Valid_Character);
+      Gen : Char_Random.Generator;
+   begin
+      return File : Temp_File do
+         File.Name (1 .. 4) := "alr-";
+         for I in 5 .. 8 loop
+            File.Name (I) := Char_Random.Random (Gen);
+         end loop;
+      end return;
+   end Create_Temp_File;
+
+   --------------
+   -- Filename --
+   --------------
+
+   function Filename (This : Temp_File) return String is
+     (This.Name & ".tmp");
+
+   --------------
+   -- Finalize --
+   --------------
+
+   overriding
+   procedure Finalize (This : in out Temp_File) is
+      use Ada.Directories;
+   begin
+      if Exists (This.Filename) then
+         if Kind (This.Filename) = Ordinary_File then
+            Trace.Debug ("Deleting temporary file " & This.Filename & "...");
+            Delete_File (This.Filename);
+         elsif Kind (This.Filename) = Directory then
+            Trace.Debug ("Deleting temporary folder " & This.Filename & "...");
+            Delete_Tree (This.Filename);
+         end if;
+      end if;
+   end Finalize;
+
 end Alire.Directories;

src/alire/alire-directories.ads

@@ -60,8 +60,27 @@ package Alire.Directories is
    --  This whole mess of accesses and leaks is due to a bug in the
    --    in-place initialization of limited
 
+   ---------------------
+   -- Temporary files --
+   ---------------------
+
+   type Temp_File (<>) is tagged limited private;
+   --  A RAII scoped type to manage a temporary file.
+   --  The file is deleted once an object of this type goes out of scope.
+   --  If the file was never created nothing will happen.
+
+   function Create_Temp_File return Temp_File;
+   --  Creates an instance with a unique file name.
+
+   function Filename (This : Temp_File) return String;
+   --  The filename is a random sequence of 8 characters + ".tmp"
+
 private
 
+   ------------
+   -- Guards --
+   ------------
+
    Stay : constant Destination := null;
 
    type Guard (Enter : Destination := Stay)
@@ -73,4 +92,17 @@ private
    overriding procedure Initialize (This : in out Guard);
    overriding procedure Finalize   (This : in out Guard);
 
+   ----------------
+   -- Temp files --
+   ----------------
+
+   subtype Temp_Filename is String (1 .. 8);
+
+   type Temp_File is new Ada.Finalization.Limited_Controlled with record
+      Name : Temp_Filename;
+   end record;
+
+   overriding
+   procedure Finalize (This : in out Temp_File);
+
 end Alire.Directories;

src/alire/alire-hashes-common.adb

@@ -22,7 +22,7 @@ package body Alire.Hashes.Common is
       end loop;
       Close (File);
 
-      return Utils.To_Lower_Case (Kind'Img) & ":" & Digest (Ctxt);
+      return Any_Hash (Utils.To_Lower_Case (Kind'Img) & ":" & Digest (Ctxt));
 
    exception
       when others =>

src/alire/alire-hashes.ads

@@ -12,10 +12,18 @@ package Alire.Hashes with Preelaborate is
    --  To add a new kind, instance the Alire.Hashes.Common generic and with it
    --  in Alire.TOML_Index body.
 
-   subtype Any_Hash is String with
-     Dynamic_Predicate => Is_Well_Formed (Any_Hash);
+   type Any_Digest is new String with
+     Dynamic_Predicate =>
+       (for all Char of Any_Digest => Char in 'a' .. 'f' | '0' .. '9');
+   --  Just the actual hash part, in hexadecimal encoding.
 
-   function Digest (Hash : Any_Hash) return String;
+   type Any_Hash is new String with
+     Dynamic_Predicate => Is_Well_Formed (String (Any_Hash));
+   --  A string with "kind:digest" format.
+
+   function New_Hash (Kind : Kinds; Digest : Any_Digest) return Any_Hash;
+
+   function Digest (Hash : Any_Hash) return Any_Digest;
    --  Return the actual fingerprint without the kind prefix.
 
    function Hash_File (Kind : Kinds;
@@ -37,8 +45,8 @@ private
    -- Digest --
    ------------
 
-   function Digest (Hash : Any_Hash) return String is
-     (Utils.Tail (Hash, ':'));
+   function Digest (Hash : Any_Hash) return Any_Digest is
+     (Any_Digest (Utils.Tail (String (Hash), ':')));
 
    --------------------
    -- Hash_Functions --
@@ -79,6 +87,13 @@ private
    ----------
 
    function Kind (Hash : Any_Hash) return Kinds is
-     (Kinds'Value (Utils.Head (Hash, ':')));
+     (Kinds'Value (Utils.Head (String (Hash), ':')));
+
+   --------------
+   -- New_Hash --
+   --------------
+
+   function New_Hash (Kind : Kinds; Digest : Any_Digest) return Any_Hash is
+     (Any_Hash (Utils.To_Lower_Case (Kind'Img) & ":" & String (Digest)));
 
 end Alire.Hashes;

src/alire/alire-origins-deployers-git.adb

@@ -1,15 +1,53 @@
+with Alire.Directories;
+with Alire.Errors;
+with Alire.OS_Lib.Subprocess;
+
 with Alire.VCSs.Git;
 
 package body Alire.Origins.Deployers.Git is
 
-   -----------
-   -- Fetch --
-   -----------
+   ------------
+   -- Deploy --
+   ------------
 
    overriding
    function Deploy (This : Deployer; Folder : String) return Outcome is
    begin
       return VCSs.Git.Handler.Clone (This.Base.URL_With_Commit, Folder);
    end Deploy;
 
+   ------------------
+   -- Compute_Hash --
+   ------------------
+
+   overriding
+   function Compute_Hash (This   : Deployer;
+                          Folder : String;
+                          Kind   : Hashes.Kinds) return Hashes.Any_Digest
+   is
+      pragma Unreferenced (This);
+      use OS_Lib.Subprocess;
+
+      --  Enter the folder to hash
+      Guard : Directories.Guard (Directories.Enter (Folder)) with unreferenced;
+
+      Output    : Utils.String_Vector;
+      Tmp_File  : constant Directories.Temp_File :=
+                    Directories.Create_Temp_File;
+
+      --  Generate platform-independent archive
+      Exit_Code : constant Integer :=
+                    Spawn ("git",
+                           "-c core.autocrlf=false archive HEAD -o "
+                             & Tmp_File.Filename);
+   begin
+      if Exit_Code /= 0 then
+         raise Checked_Error with Errors.Set
+           ("Unexpected error while executing process:" & Exit_Code'Img
+            & "; output: " & Output.Flatten);
+      else -- OK
+         return Hashes.Digest (Hashes.Hash_File (Kind, Tmp_File.Filename));
+      end if;
+   end Compute_Hash;
+
 end Alire.Origins.Deployers.Git;

src/alire/alire-origins-deployers-git.ads

@@ -5,4 +5,9 @@ package Alire.Origins.Deployers.Git is
    overriding
    function Deploy (This : Deployer; Folder : String) return Outcome;
 
+   overriding
+   function Compute_Hash (This   : Deployer;
+                          Folder : String;
+                          Kind   : Hashes.Kinds) return Hashes.Any_Digest;
+
 end Alire.Origins.Deployers.Git;

src/alire/alire-origins-deployers-source_archive.adb

@@ -17,7 +17,6 @@ package body Alire.Origins.Deployers.Source_Archive is
       use GNATCOLL.VFS;
       Archive_Name : constant String := This.Base.Archive_Name;
       Archive_File : constant String := Dirs.Compose (Folder, Archive_Name);
-      Archive_Hash : constant String := This.Base.Archive_Hash;
       Exit_Code    :          Integer;
       package Subprocess renames Alire.OS_Lib.Subprocess;
    begin
@@ -31,22 +30,6 @@ package body Alire.Origins.Deployers.Source_Archive is
          return Outcome_Failure ("wget call failed with code" & Exit_Code'Img);
       end if;
 
-      declare
-         Down_Hash : constant Hashes.Any_Hash :=
-                       Hashes.Hash_File (Kind => Hashes.Kind (Archive_Hash),
-                                         Path => Archive_File);
-      begin
-         if Archive_Hash /= Down_Hash then
-            return Outcome_Failure
-              ("Archive integrity test failed. "
-               & "Expected [" & Archive_Hash
-               & "] but got [" & Down_Hash & "]");
-         else
-            Trace.Debug
-              ("Retrieved file " & Archive_File & " integrity verified.");
-         end if;
-      end;
-
       Trace.Detail ("Extracting source archive...");
       case This.Base.Archive_Format is
          when Alire.Origins.Tarball =>
@@ -64,4 +47,18 @@ package body Alire.Origins.Deployers.Source_Archive is
       return Outcome_Success;
    end Deploy;
 
+   -------------------
+   -- Verify_Hashes --
+   -------------------
+
+   overriding
+   function Compute_Hash (This   : Deployer;
+                          Folder : String;
+                          Kind   : Hashes.Kinds) return Hashes.Any_Digest is
+      Archive_Name : constant String := This.Base.Archive_Name;
+      Archive_File : constant String := Dirs.Compose (Folder, Archive_Name);
+   begin
+      return Hashes.Digest (Hashes.Hash_File (Kind, Archive_File));
+   end Compute_Hash;
+
 end Alire.Origins.Deployers.Source_Archive;

src/alire/alire-origins-deployers-source_archive.ads

@@ -5,4 +5,9 @@ package Alire.Origins.Deployers.Source_Archive is
    overriding
    function Deploy (This : Deployer; Folder : String) return Outcome;
 
+   overriding
+   function Compute_Hash (This   : Deployer;
+                          Folder : String;
+                          Kind   : Hashes.Kinds) return Hashes.Any_Digest;
+
 end Alire.Origins.Deployers.Source_Archive;