diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index 517171505..a2f0906f3 100644 --- a/src/alire/alire-directories.adb +++ b/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 -- ------------------- diff --git a/src/alire/alire-directories.ads b/src/alire/alire-directories.ads index bf830694d..b0f2ae094 100644 --- a/src/alire/alire-directories.ads +++ b/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. diff --git a/src/alr/alr-main.adb b/src/alr/alr-main.adb index b7519169f..3cb3f039f 100644 --- a/src/alr/alr-main.adb +++ b/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; diff --git a/testsuite/tests/install/softlinks/my_index/crate-0.1.0.tgz b/testsuite/tests/install/softlinks/my_index/crate-0.1.0.tgz index 50b40e1f5..11effa04c 100644 Binary files a/testsuite/tests/install/softlinks/my_index/crate-0.1.0.tgz and b/testsuite/tests/install/softlinks/my_index/crate-0.1.0.tgz differ diff --git a/testsuite/tests/install/softlinks/my_index/index/cr/crate/crate-0.1.0.toml b/testsuite/tests/install/softlinks/my_index/index/cr/crate/crate-0.1.0.toml index 64f0a36f0..dd47659fa 100644 --- a/testsuite/tests/install/softlinks/my_index/index/cr/crate/crate-0.1.0.toml +++ b/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"] diff --git a/testsuite/tests/install/softlinks/test.py b/testsuite/tests/install/softlinks/test.py index 64b8b8dcb..43e3bafe5 100644 --- a/testsuite/tests/install/softlinks/test.py +++ b/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