Fix installation of binary crates containing softlinks (#1653)

* Force creation of missing soft link

* More detailed test of softlink installation

src/alire/alire-directories.adb

@@ -136,6 +136,28 @@ package body Alire.Directories is
       End_Search (Search);
    end Copy;
 
+   ---------------
+   -- Copy_Link --
+   ---------------
+
+   procedure Copy_Link (Src, Dst : Any_Path) is
+      use AAA.Strings;
+      use all type Platforms.Operating_Systems;
+      Keep_Links : constant String
+        := (case Platforms.Current.Operating_System is
+               when Linux           => "-d",
+               when FreeBSD | MacOS => "-R",
+               when others          =>
+                  raise Program_Error with "Unsupported operation");
+   begin
+      --  Given that we are here because Src is indeed a link, we should be in
+      --  a Unix-like platform able to do this.
+      OS_Lib.Subprocess.Checked_Spawn
+        ("cp",
+         To_Vector (Keep_Links)
+         & Src & Dst);
+   end Copy_Link;
+
    -----------------
    -- Create_Tree --
    -----------------
@@ -812,9 +834,6 @@ package body Alire.Directories is
            and then Base = Parent (Src)
          then
             Trace.Debug ("   Merge: Not merging top-level file " & Src);
-            if Remove_From_Source then
-               Adirs.Delete_File (Src);
-            end if;
             return;
          end if;
 
@@ -831,20 +850,19 @@ package body Alire.Directories is
             --  recursion we could more efficiently rename now into place.
          end if;
 
-         --  Copy/Move a file into place
+         --  Copy file into place
 
-         Trace.Debug ("   Merge: "
-                     & (if Remove_From_Source then " moving " else " copying ")
+         Trace.Debug ("   Merge: copying "
                      & Adirs.Full_Name (Item)
                      & " into " & Dst);
 
          if Adirs.Exists (Dst) then
             if Fail_On_Existing_File then
-               Recoverable_User_Error ("Cannot move " & TTY.URL (Src)
+               Recoverable_User_Error ("Cannot copy " & 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)
+               Raise_Checked_Error ("Cannot overwrite " & TTY.URL (Dst)
                                     & " as it is not a regular file");
             else
                Trace.Debug ("   Merge: Deleting in preparation to replace: "
@@ -853,56 +871,51 @@ package body Alire.Directories is
             end if;
          end if;
 
-         --  We use GNATCOLL.VFS here as some binary packages contain softlinks
+         --  We use GNAT.OS_Lib 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
-               if Remove_From_Source then
-                  VF.Rename (VFS.New_Virtual_File (Dst), OK);
-               else
-                  VF.Copy (VFS.Filesystem_String (Dst), OK);
-               end if;
-               if not OK then
-                  Raise_Checked_Error ("Failed to copy/move softlink: "
-                                       & TTY.URL (Src));
-               end if;
-            else
-               begin
-                  if Remove_From_Source then
-                     Adirs.Rename (Old_Name => Src,
-                                   New_Name => Dst);
-                  else
-                     Adirs.Copy_File (Source_Name => Src,
-                                      Target_Name => Dst,
-                                      Form       => "preserve=all_attributes");
-                  end if;
-               exception
-                  when E : others =>
-                     Trace.Error
-                       ("When " &
-                        (if Remove_From_Source
-                           then "renaming "
-                           else "copying ")
-                        & Src & " --> " & Dst & ": ");
-                     Log_Exception (E, Error);
-                     raise;
-               end;
+         if GNAT.OS_Lib.Is_Symbolic_Link (Src) then
+            Trace.Debug ("   Merge (softlink): " & Src);
+
+            Copy_Link (Src, Dst);
+            if not GNAT.OS_Lib.Is_Symbolic_Link (Dst) then
+               Raise_Checked_Error ("Failed to copy softlink: "
+                                    & TTY.URL (Src)
+                                    & " to " & TTY.URL (Dst)
+                                    & " (dst not a link)");
             end if;
-         end;
+         else
+            begin
+               Adirs.Copy_File (Source_Name => Src,
+                                Target_Name => Dst,
+                                Form        => "preserve=all_attributes");
+            exception
+               when E : others =>
+                  Trace.Error
+                    ("When copying " & Src & " --> " & Dst & ": ");
+                  Log_Exception (E, Error);
+                  raise;
+            end;
+         end if;
       end Merge;
 
    begin
       Traverse_Tree (Start   => Src,
                      Doing   => Merge'Access,
                      Recurse => True);
+
+      --  This is space-inefficient since we use 2x the actual size, but this
+      --  is the only way we have unless we want to go into platform-dependent
+      --  details and radical changes due to softlinks .
+
+      --  TODO: remove this limitation on a non-patch release.
+
+      if Remove_From_Source then
+         Force_Delete (Src);
+      end if;
    end Merge_Contents;
 
    -------------------
@@ -988,7 +1001,7 @@ package body Alire.Directories is
 
             if not Prune and then Recurse and then Kind (Item) = Directory then
                declare
-                  Normal_Name : constant String
+                  Normal_Name : constant Absolute_Path
                     :=
                       String (GNATCOLL.VFS.Full_Name
                               (VFS.New_Virtual_File (Full_Name (Item)),

src/alire/alire-directories.ads

@@ -32,6 +32,10 @@ package Alire.Directories is
    --  equivalent to "cp -r src/* dst/". Excluding may be a single name that
    --  will not be copied (if file) or recursed into (if folder).
 
+   procedure Copy_Link (Src, Dst : Any_Path)
+     with Pre => GNAT.OS_Lib.Is_Symbolic_Link (Src);
+   --  Copy a softlink into a new place preserving its relative path to target
+
    function Current return String renames Ada.Directories.Current_Directory;
 
    function Parent (Path : Any_Path) return String

testsuite/tests/install/softlinks/my_index/index/cr/crate/crate-0.1.0.toml

@@ -8,4 +8,4 @@ executables=['main']
 
 [origin.'case(os)'.'...']
 url = "file:../../../crate-0.1.0.tgz"
-hashes = ["sha256:73d1455dd4b49ea598faa939557c15046db6c689552db03fd6a49c57d3cbc1b2"]
+hashes = ["sha256:f3bd6b531710b41c9d62144b5a29fa0b4b78ab553c29957f41d4ca9075f5b0b8"]

testsuite/tests/install/softlinks/test.py

@@ -2,21 +2,47 @@
 Test that binary files containing softlinks can be installed properly. The test
 crate contains all kinds of pernicious links (broken, recursive, etc.):
 
-crate
+crate/
 ├── bin -> subdir/bin
 ├── broken -> missing
+├── lib
+│   ├── mock.so -> mock.so.0.0
+│   ├── mock.so.0 -> mock.so.0.0
+│   ├── mock.so.0.0
+│   ├── zzz.so -> mock.so
+│   └── zzz.so.0 -> mock.so
+├── order
+│   ├── ab -> b
+│   ├── af -> d/f
+│   ├── b
+│   ├── cb -> b
+│   ├── d
+│   │   └── f
+│   └── zf -> d/f
 └── subdir
     ├── bin
     │   ├── loop -> ../../subdir
     │   └── x
     ├── parent -> ..
     └── self -> ../subdir
+
 """
 
+import os
+import shutil
+import subprocess
 import sys
 
-from drivers.alr import run_alr
-from drivers.helpers import on_windows
+from drivers.alr import crate_dirname, run_alr
+from drivers.helpers import contents, on_windows
+
+
+def kind(file):
+    return (os.path.isfile(file), os.path.islink(file), os.path.isdir(file))
+
+def ls(path):
+    out = subprocess.run(["ls", "-alFR", path], capture_output=True, text=True)
+    return out.stdout
 
 
 # Does not apply to Windows as it does not support softlinks
@@ -27,5 +53,35 @@
 # This command should succeed normally
 run_alr("install", "--prefix=install", "crate")
 
+# Contents should be identical. For that, we first untar the crate and then
+# directly compare with the destination.
+
+run_alr("get", "crate") # This merely untars and moves the whole dir in one step,
+                        # so contents are not modified.
+cratedir = crate_dirname("crate")
+os.chdir(cratedir)
+shutil.rmtree("alire")  # Created by get
+os.remove("alire.toml") # Created by get
+items = contents(".")   # Contents of the original crate
+os.chdir("..")
+os.chdir("install")     # Contents of the install prefix
+
+for item in items:
+    orig = f"../{cratedir}/{item}"
+    whatis = kind(orig)
+    if os.path.islink(orig) and os.path.isdir(orig):
+        continue # We aren't yet able to copy those
+    if not os.path.exists (orig):
+        continue # Broken links, we don't copy them at all
+    assert os.path.exists(item), \
+        f"Missing expected entry {item}: {whatis}') in " + \
+        f"contents (dst):\n{ls('.')}" + \
+        f"contents (src):\n{ls('../' + cratedir)}"
+    assert kind(item) == kind(orig), \
+        f"Unexpected kind for {item}: {kind(item)} != {kind(orig)}"
+
+# Cleanup
+os.chdir("..")
+shutil.rmtree(cratedir)
 
 print('SUCCESS')