New Force_Delete

src/alire/alire-directories.adb

@@ -240,11 +240,91 @@ package body Alire.Directories is
 
    procedure Force_Delete (Path : Absolute_Path) is
       use Ada.Directories;
+      use GNATCOLL.VFS;
+
+      procedure Delete_Links is
+         procedure Delete_Links (Path : Absolute_Path) is
+            Contents : File_Array_Access :=
+                         VFS.New_Virtual_File (Path).Read_Dir;
+         begin
+            for Item of Contents.all loop
+               if Item.Is_Symbolic_Link then
+                  --  Delete it here and now before normalization, as after
+                  --  normalization links are resolved and the original link
+                  --  name is lost.
+                  declare
+                     Deleted : Boolean := False;
+                     Target  : constant Virtual_File :=
+                                 VFS.New_Virtual_File (+Item.Full_Name);
+                  begin
+                     Target.Normalize_Path (Resolve_Symlinks => True);
+                     Item.Delete (Deleted);
+                     if Deleted then
+                        Trace.Debug ("Deleted softlink: "
+                                     & Item.Display_Full_Name
+                                     & " --> "
+                                     & Target.Display_Full_Name);
+                     else
+                        --  Not deleting a link is unsafe, as it may point
+                        --  outside the target tree. Fail in this case.
+                        Raise_Checked_Error
+                          ("Failed to delete softlink: "
+                           & Item.Display_Full_Name);
+                     end if;
+                  end;
+               elsif Item.Is_Directory
+                 and then Item.Display_Base_Name not in "." | ".."
+               then
+                  Delete_Links (+Item.Full_Name);
+               end if;
+            end loop;
+
+            Unchecked_Free (Contents);
+         end Delete_Links;
+
+      begin
+         if Adirs.Exists (Path) then
+            Delete_Links (Path);
+         end if;
+      end Delete_Links;
+
+      ----------------------
+      -- Report_Remaining --
+      ----------------------
+
+      procedure Report_Remaining is
+      begin
+         Trace.Warning ("Could not completely remove " & Path);
+         Trace.Debug ("Remains 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"))
+                          & Path,
+                          Output,
+                          Err_To_Out => True);
+         begin
+            if Code = 0 then
+               Trace.Debug (Output.Flatten (New_Line));
+            else
+               Trace.Warning ("Contents listing failed with code: "
+                              & Code'Image);
+            end if;
+         end;
+      end Report_Remaining;
+
    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;
@@ -254,13 +334,24 @@ package body Alire.Directories is
             Trace.Debug ("Deleting file " & Path & "...");
             Delete_File (Path);
          elsif Kind (Path) = Directory then
-            Trace.Debug ("Deleting temporary folder " & Path & "...");
-
+            Trace.Debug ("Deleting folder " & Path & "...");
             Ensure_Deletable (Path);
-            Remove_Softlinks (Path, Recursive => True);
+            Delete_Links;
+            --  By first deleting any softlinks, we ensure that the remaining
+            --  tree is safe to delete, that no malicious link is followed
+            --  outside the target tree, and that broken/recursive links
+            --  confuse the tree removal procedure.
             Adirs.Delete_Tree (Path);
+         else
+            Raise_Checked_Error ("Cannot delete special file:" & Path);
          end if;
       end if;
+   exception
+      when E : others =>
+         Trace.Debug ("Exception attempting deletion of " & Path);
+         Log_Exception (E);
+         Report_Remaining;
+         raise;
    end Force_Delete;
 
    ----------------------
@@ -753,58 +844,6 @@ package body Alire.Directories is
                      Recurse => True);
    end Merge_Contents;
 
-   ------------------------------
-   -- Remove_Softlinks_In_Tree --
-   ------------------------------
-
-   procedure Remove_Softlinks (Path      : Any_Path;
-                                       Recursive : Boolean)
-   is
-      use GNATCOLL.VFS;
-
-      Success : Boolean := False;
-
-      ---------------------
-      -- Remove_Internal --
-      ---------------------
-
-      procedure Remove_Internal (Target : Adirs.Directory_Entry_Type) is
-         use Ada.Directories;
-         VF    : constant VFS.Virtual_File :=
-                   VFS.New_Virtual_File
-                     (VFS.From_FS (Full_Name (Target)));
-      begin
-         if VF.Is_Symbolic_Link then
-
-            Trace.Debug ("Deleting softlink: " & VF.Display_Full_Name);
-            VF.Delete (Success);
-            --  Uses unlink under the hood so it should delete just the link
-
-            if not Success then
-               Raise_Checked_Error ("Failed to delete softlink: "
-                                    & VF.Display_Full_Name);
-            end if;
-         else
-            if Kind (Target) = Directory and then Recursive
-              and then Simple_Name (Target) not in "." | ".."
-            then
-               Search (Full_Name (Target),
-                       Pattern => "",
-                       Process => Remove_Internal'Access);
-            end if;
-         end if;
-      end Remove_Internal;
-
-   begin
-      --  GNATCOLL's read_dir returns softlinks as the target kind, so we are
-      --  forced to iterate using Ada.Directories but using GC to check for
-      --  softlinks.
-
-      Ada.Directories.Search (Path,
-                              Pattern => "",
-                              Process => Remove_Internal'Access);
-   end Remove_Softlinks;
-
    -------------------
    -- Traverse_Tree --
    -------------------

src/alire/alire-directories.ads

@@ -98,11 +98,6 @@ package Alire.Directories is
    --  the top-level only contains "doinstall", "README" and so on that
    --  are unusable and would be confusing in a binary prefix.
 
-   procedure Remove_Softlinks (Path      : Any_Path;
-                               Recursive : Boolean);
-   --  Remove softlinks only (not their targets) at Path and subdirs when
-   --  Recursive.
-
    procedure Touch (File : File_Path)
      with Pre => Is_Directory (Parent (File));
    --  If the file exists, update last edition time; otherwise create it.

src/alr/alr-main.adb

@@ -1,4 +1,5 @@
-with Alire_Early_Elaboration; pragma Elaborate_All (Alire_Early_Elaboration);
+with Alire_Early_Elaboration;
+pragma Elaborate_All (Alire_Early_Elaboration);
 
 with Alr.Commands;
 with Alr.Last_Chance_Handler;

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:35cc9636468031e1874fe142a6f40557d3befc6dd26cdded0401f440534f4bd6"]
+hashes = ["sha256:73d1455dd4b49ea598faa939557c15046db6c689552db03fd6a49c57d3cbc1b2"]

testsuite/tests/install/softlinks/test.py

@@ -1,5 +1,16 @@
 """
-Test that binary files containing softlinks can be installed properly
+Test that binary files containing softlinks can be installed properly. The test
+crate contains all kinds of pernicious links (broken, recursive, etc.):
+
+crate
+├── bin -> subdir/bin
+├── broken -> missing
+└── subdir
+    ├── bin
+    │   ├── loop -> ../../subdir
+    │   └── x
+    ├── parent -> ..
+    └── self -> ../subdir
 """
 
 import sys