From fa83fe00032707ec89c66d630274bb21e8aed55e Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Fri, 18 Apr 2025 22:49:10 +0200 Subject: [PATCH] fix: fallback to copy/delete for renames (#1925) * Use Merge_Dirs for pin cloning We were using a rename that could fail across filesystems * Remove after copy * Fix infinite recursion in attrib for softlinks * Use den for softlink deletion * Self-review * Best-effort rename --- .vscode/settings.json | 8 + src/alire/alire-directories.adb | 241 ++++++++++++++++---------- src/alire/alire-directories.ads | 10 +- src/alire/alire-origins-deployers.adb | 8 +- src/alire/alire-releases.adb | 6 +- src/alire/alire-roots-editable.adb | 4 +- src/alire/alire-roots.adb | 2 +- src/alire/alire-user_pins.adb | 8 +- 8 files changed, 181 insertions(+), 106 deletions(-) diff --git a/.vscode/settings.json b/.vscode/settings.json index d913bfb3..ccb79cbb 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -11,4 +11,12 @@ "terminal.integrated.env.linux": { "ALIRE_OS": "linux", }, + "workspaceKeybindings.alireGprbuild.enabled": true, + "workspaceKeybindings.alireBuildFile.enabled": true, + "triggerTaskOnSave.tasks": { + "Alire: Compile current file": [ + "*.ads", + "*.adb", + ], + } } diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index d91def8b..a2c4b0b9 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -10,7 +10,6 @@ with Alire.OS_Lib.Subprocess; with Alire.Paths; with Alire.Platforms.Current; with Alire.Platforms.Folders; -with Alire.VFS; with Alire.Utils; with Den.Filesystem; @@ -27,6 +26,8 @@ with SI_Units.Binary; package body Alire.Directories is + use all type Den.Kinds; + ------------------- -- Temp_Registry -- ------------------- @@ -108,7 +109,6 @@ package body Alire.Directories is procedure Copy (Src_Folder, Dst_Parent_Folder : String; Excluding : String := "") is - use all type Den.Kinds; begin for Simple_Item of Den.Iterators.Iterate (Src_Folder) loop declare @@ -152,6 +152,7 @@ package body Alire.Directories is use GNATCOLL.VFS; begin Make_Dir (Create (+Path)); + Trace.Debug ("Created tree: " & Path); end Create_Tree; ------------------------ @@ -188,7 +189,6 @@ package body Alire.Directories is function Detect_Root_Path (Starting_At : Absolute_Path := Current) return String is - use Ada.Directories; --------------------------- -- Find_Candidate_Folder -- @@ -201,14 +201,14 @@ package body Alire.Directories is Trace.Debug ("Looking for alire metadata at: " & Path); if Exists (Path / Paths.Crate_File_Name) and then - Kind (Path / Paths.Crate_File_Name) = Ordinary_File + Kind (Path / Paths.Crate_File_Name) = File then return Path; else - return Find_Candidate_Folder (Containing_Directory (Path)); + return Find_Candidate_Folder (Adirs.Containing_Directory (Path)); end if; exception - when Use_Error => + when Adirs.Use_Error => Trace.Debug ("Root directory reached without finding alire metadata"); return ""; -- There's no containing folder (hence we're at root) @@ -223,29 +223,49 @@ package body Alire.Directories is ---------------------- procedure Ensure_Deletable (Path : Any_Path) is - use Ada.Directories; + + --------------------------- + -- Ensure_Deletable_Item -- + --------------------------- + + procedure Ensure_Deletable_Item + (Path : Any_Path; Unused : in out Boolean) + is + begin + case Den.Kind (Path) is + when Nothing => + raise Program_Error + with "cannot change attributes of non-existing file: " & Path; + when Directory => + Trace.Debug ("Forcing writability of dir " & Path); + OS_Lib.Subprocess.Checked_Spawn + ("attrib", + AAA.Strings.Empty_Vector + .Append ("-R") -- Remove read-only + .Append ("/D") -- On dirs + .Append (Path & "\*")); + when File | Softlink | Special => + Trace.Debug ("Forcing writability of file " & Path); + OS_Lib.Subprocess.Checked_Spawn + ("attrib", + AAA.Strings.Empty_Vector + .Append ("-R") -- Remove read-only + .Append (Path)); + end case; + end Ensure_Deletable_Item; + begin - if Platforms.Current.Operating_System in Platforms.Windows - and then Exists (Path) + if Platforms.Current.Operating_System not in Platforms.Windows + or else not Exists (Path) then - if Kind (Path) = Directory then - Trace.Debug ("Forcing writability of dir " & Path); - OS_Lib.Subprocess.Checked_Spawn - ("attrib", - AAA.Strings.Empty_Vector - .Append ("-R") -- Remove read-only - .Append ("/D") -- On dirs - .Append ("/S") -- Recursively - .Append (Path & "\*")); - elsif Kind (Path) = Ordinary_File then - Trace.Debug ("Forcing writability of dir " & Path); - OS_Lib.Subprocess.Checked_Spawn - ("attrib", - AAA.Strings.Empty_Vector - .Append ("-R") -- Remove read-only - .Append (Path)); - end if; + return; end if; + + -- Do our own recursion as attrib's one is broken for looping softlinks + Traverse_Tree + (Start => Path, + Doing => Ensure_Deletable_Item'Access, + Recurse => True); end Ensure_Deletable; ------------------ @@ -253,47 +273,22 @@ package body Alire.Directories is ------------------ procedure Force_Delete (Path : Absolute_Path) is - use Ada.Directories; - use GNATCOLL.VFS; + + ------------------ + -- Delete_Links -- + ------------------ 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); + for Item of Den.Iterators.Iterate (Path) loop + if Den.Kind (Path / Item) = Softlink then + Den.Filesystem.Unlink (Path / Item); + elsif Den.Kind (Path / Item) = Directory then + Delete_Links (Path / Item); end if; end loop; - - Unchecked_Free (Contents); end Delete_Links; begin @@ -345,9 +340,9 @@ package body Alire.Directories is end if; if Exists (Path) then - if Kind (Path) = Ordinary_File then + if Kind (Path) = File then Trace.Debug ("Deleting file " & Path & "..."); - Delete_File (Path); + Adirs.Delete_File (Path); elsif Kind (Path) = Directory then Trace.Debug ("Deleting folder " & Path & "..."); Ensure_Deletable (Path); @@ -355,7 +350,7 @@ package body Alire.Directories is -- 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. + -- do not confuse the tree removal procedure. Adirs.Delete_Tree (Path); else Raise_Checked_Error ("Cannot delete special file:" & Path); @@ -369,6 +364,53 @@ package body Alire.Directories is raise; end Force_Delete; + ------------ + -- Rename -- + ------------ + + procedure Rename (Source, + Destination : Any_Path) + is + type Modes is (Move, Copy); + begin + if Exists (Destination) then + Raise_Checked_Error + ("Cannot rename " & Source + & " into existing destination " & Destination); + end if; + + for Mode in Modes loop + Trace.Debug ("Renaming " & Source & " (" & Kind (Source)'Image & ") " + & "into " & Destination + & " using mode=" & Mode'Image); + + if Mode = Copy then + Merge_Contents + (Src => Source, + Dst => Destination, + Skip_Top_Level_Files => False, + Fail_On_Existing_File => True, + Remove_From_Source => False, + Silent => True); + + Delete_Tree (Den.Filesystem.Absolute (Source)); + else + begin + Adirs.Rename (Source, Destination); + exit; + exception + when E : Adirs.Use_Error => + Log_Exception (E); + Trace.Debug ("Could not rename, falling back to copy/del"); + -- Ensure no remainder of the move attempt (?) + Delete_Tree (Destination); + end; + end if; + end loop; + + Trace.Debug ("Renaming successful"); + end Rename; + ---------------------- -- Find_Files_Under -- ---------------------- @@ -378,7 +420,6 @@ package body Alire.Directories is Max_Depth : Natural := Natural'Last) return AAA.Strings.Vector is - use all type Den.Kinds; Found : AAA.Strings.Vector; ----------- @@ -450,7 +491,6 @@ package body Alire.Directories is overriding procedure Finalize (This : in out Guard) is - use Ada.Directories; use Ada.Strings.Unbounded; procedure Free is new Ada.Unchecked_Deallocation (Absolute_Path, Destination); @@ -458,7 +498,7 @@ package body Alire.Directories is begin if This.Enter /= null and then - Current_Directory /= To_String (This.Original) + Adirs.Current_Directory /= To_String (This.Original) then Log ("Going back to folder: " & To_String (This.Original), Debug); Ada.Directories.Set_Directory (To_String (This.Original)); @@ -689,7 +729,6 @@ package body Alire.Directories is overriding procedure Finalize (This : in out Temp_File) is - use Ada.Directories; begin if This.Keep then return; @@ -709,9 +748,9 @@ package body Alire.Directories is Ensure_Deletable (This.Filename); if Exists (This.Filename) then - if Kind (This.Filename) = Ordinary_File then + if Den.Kind (This.Filename) = File then Trace.Debug ("Deleting temporary file " & This.Filename & "..."); - Delete_File (This.Filename); + Adirs.Delete_File (This.Filename); elsif Kind (This.Filename) = Directory then Trace.Debug ("Deleting temporary folder " & This.Filename & "..."); @@ -728,6 +767,8 @@ package body Alire.Directories is end; end if; + else + Trace.Debug ("Not deleting non-existing temporary: " & This.Filename); end if; -- Remove temp dir if empty to keep things tidy, and avoid modifying @@ -743,7 +784,7 @@ package body Alire.Directories is AAA.Directories.Remove_Folder_If_Empty (Parent (This.Filename)); end if; exception - when Use_Error => + when Adirs.Use_Error => -- May be raised by Adirs.Containing_Directory Trace.Debug ("Failed to identify location of temp file: " & This.Filename); @@ -761,9 +802,22 @@ package body Alire.Directories is procedure Merge_Contents (Src, Dst : Any_Path; Skip_Top_Level_Files : Boolean; Fail_On_Existing_File : Boolean; - Remove_From_Source : Boolean) + Remove_From_Source : Boolean; + Silent : Boolean := True) is + --------------- + -- Merge_Log -- + --------------- + + procedure Merge_Log (S : String) is + begin + if Silent then + return; + end if; + Trace.Debug (S); + end Merge_Log; + Base : constant Absolute_Path := Den.Filesystem.Absolute (Src); Target : constant Absolute_Path := Den.Filesystem.Absolute (Dst); @@ -775,7 +829,6 @@ package body Alire.Directories is (Item : Any_Path; Stop : in out Boolean) is - use all type Den.Kinds; Src : constant Absolute_Path := Den.Filesystem.Absolute (Item); Rel_Path : constant Relative_Path := Find_Relative_Path (Base, Src); @@ -801,7 +854,7 @@ package body Alire.Directories is if Den.Kind (Item) = Directory then if not Is_Directory (Dst) then - Trace.Debug (" Merge: Creating destination dir " & Dst); + Merge_Log (" Merge: Creating destination dir " & Dst); Create_Tree (Dst); end if; @@ -812,9 +865,9 @@ package body Alire.Directories is -- Copy file into place - Trace.Debug (" Merge: copying " - & Den.Filesystem.Absolute (Item) - & " into " & Dst); + Merge_Log (" Merge: copying " + & Den.Filesystem.Absolute (Item) + & " into " & Dst); if Den.Exists (Dst) then if Fail_On_Existing_File then @@ -825,8 +878,8 @@ package body Alire.Directories is Raise_Checked_Error ("Cannot overwrite " & TTY.URL (Dst) & " as it is not a regular file"); else - Trace.Debug (" Merge: Deleting in preparation to replace: " - & Dst); + Merge_Log + (" Merge: Deleting in preparation to replace: " & Dst); Adirs.Delete_File (Dst); end if; end if; @@ -837,9 +890,16 @@ package body Alire.Directories is end Merge; begin - Traverse_Tree (Start => Src, - Doing => Merge'Access, - Recurse => True); + Trace.Debug ("Merging " & Src & " (" & Kind (Src)'Image + & ") into " & Dst & " (" & Kind (Dst)'Image & ")"); + + if Kind (Src) = File then + Den.Filesystem.Copy (Src, Dst); + else + Traverse_Tree (Start => Src, + Doing => Merge'Access, + Recurse => True); + end if; -- 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 @@ -863,8 +923,6 @@ package body Alire.Directories is Recurse : Boolean := False; Spinner : Boolean := False) is - use Ada.Directories; - Progress : Simple_Logging.Ongoing := Simple_Logging.Activity (Text => "Exploring " & Start, Level => (if Spinner @@ -879,7 +937,6 @@ package body Alire.Directories is Enter : in out Boolean; Stop : in out Boolean) is - use all type Den.Kinds; Path : constant Any_Path := This.Path; begin Enter := True; @@ -897,7 +954,7 @@ package body Alire.Directories is if Enter and then Recurse and then Den.Kind (Path) = Directory then if Spinner then - Progress.Step ("Exploring .../" & Simple_Name (Path)); + Progress.Step ("Exploring .../" & Adirs.Simple_Name (Path)); end if; elsif not Enter and then Den.Kind (Path) = Directory then Trace.Debug ("Skipping dir: " & Full_Name (Path)); @@ -920,8 +977,7 @@ package body Alire.Directories is function Tree_Size (Path : Any_Path) return Ada.Directories.File_Size is - use Ada.Directories; - Result : File_Size := 0; + Result : Adirs.File_Size := 0; ---------------- -- Accumulate -- @@ -930,10 +986,11 @@ package body Alire.Directories is procedure Accumulate (Item : Any_Path; Stop : in out Boolean) is + use type Ada.Directories.File_Size; begin Stop := False; - if Kind (Item) = Ordinary_File then - Result := Result + Size (Item); + if Kind (Item) = File then + Result := Result + Adirs.Size (Item); end if; end Accumulate; @@ -942,8 +999,8 @@ package body Alire.Directories is return 0; end if; - case Ada.Directories.Kind (Path) is - when Ordinary_File => + case Den.Kind (Path) is + when File => return Ada.Directories.Size (Path); when Directory => diff --git a/src/alire/alire-directories.ads b/src/alire/alire-directories.ads index c7c79fb7..1f728f13 100644 --- a/src/alire/alire-directories.ads +++ b/src/alire/alire-directories.ads @@ -87,7 +87,8 @@ package Alire.Directories is procedure Merge_Contents (Src, Dst : Any_Path; Skip_Top_Level_Files : Boolean; Fail_On_Existing_File : Boolean; - Remove_From_Source : Boolean); + Remove_From_Source : Boolean; + Silent : Boolean := True); -- Move all contents from Src into Dst, recursively. Dirs already existing -- on Dst tree will be merged. For existing regular files, either log -- at debug level or fail. If Skip, discard files at the Src top-level. @@ -95,6 +96,13 @@ 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 Rename (Source, + Destination : Any_Path); + -- Renames files/directories. Will try first with a plain rename, and + -- fallback to copy/delete if rename fails. As we sometimes create + -- temporary files in user-supplied locations, depending on the underlying + -- move system call, these might fail across filesystems. + procedure Touch (File : File_Path; Create_Tree : Boolean := False) with Pre => Create_Tree or else Is_Directory (Parent (File)); -- If the file exists, update last edition time; otherwise create it. diff --git a/src/alire/alire-origins-deployers.adb b/src/alire/alire-origins-deployers.adb index 0fd0f243..22b6eed7 100644 --- a/src/alire/alire-origins-deployers.adb +++ b/src/alire/alire-origins-deployers.adb @@ -101,7 +101,9 @@ package body Alire.Origins.Deployers is / Directories.Temp_Name); -- We use a temporary location to fetch and verify, as otherwise any -- failure before final deployment may result in considering a crate - -- already deployed. + -- already deployed. This folder is a sibling of the final destination + -- so a simple renaming should work (space already taken in the same + -- drive). The_Deployer : constant Deployer'Class := New_Deployer (From); Result : Outcome; @@ -136,8 +138,8 @@ package body Alire.Origins.Deployers is Trace.Debug ("Renaming into place " & TTY.URL (Temp_Dir.Filename) & " as " & TTY.URL (Folder)); - Ada.Directories.Rename (Old_Name => Temp_Dir.Filename, - New_Name => Folder); + Directories.Rename (Source => Temp_Dir.Filename, + Destination => Folder); end if; -- Add an info file for monorepos to make explicit where a release is diff --git a/src/alire/alire-releases.adb b/src/alire/alire-releases.adb index 56b7ffa4..2b5a62be 100644 --- a/src/alire/alire-releases.adb +++ b/src/alire/alire-releases.adb @@ -287,9 +287,9 @@ package body Alire.Releases is (Directories.Full_Name (Upstream_File)); end if; -- And rename the original manifest into upstream - Ada.Directories.Rename - (Old_Name => Paths.Crate_File_Name, - New_Name => Upstream_File); + Directories.Rename + (Source => Paths.Crate_File_Name, + Destination => Upstream_File); end; end if; end Backup_Upstream_Manifest; diff --git a/src/alire/alire-roots-editable.adb b/src/alire/alire-roots-editable.adb index 85917a43..4a01f634 100644 --- a/src/alire/alire-roots-editable.adb +++ b/src/alire/alire-roots-editable.adb @@ -475,8 +475,8 @@ package body Alire.Roots.Editable is Directories.Delete_Tree (Destination); end if; - Adirs.Rename (Old_Name => Temp_Pin.Filename, - New_Name => Destination); + Directories.Rename (Source => Temp_Pin.Filename, + Destination => Destination); -- Finally add the new pin to the manifest diff --git a/src/alire/alire-roots.adb b/src/alire/alire-roots.adb index 4d6da7dc..85365b8c 100644 --- a/src/alire/alire-roots.adb +++ b/src/alire/alire-roots.adb @@ -1599,7 +1599,7 @@ package body Alire.Roots is else Put_Info ("Migrating lockfile from " & TTY.URL (Old_Path) & " to " & TTY.URL (Path)); - Adirs.Rename (Old_Path, Path); + Directories.Rename (Old_Path, Path); end if; end if; diff --git a/src/alire/alire-user_pins.adb b/src/alire/alire-user_pins.adb index 682f8243..71a98da4 100644 --- a/src/alire/alire-user_pins.adb +++ b/src/alire/alire-user_pins.adb @@ -164,7 +164,7 @@ package body Alire.User_Pins is -- Ensure the temporary pin location is in the same directory as the -- final one, so a plain rename should always succeed. - Temp : Directories.Temp_File := + Temp : constant Directories.Temp_File := Directories.With_Name (Adirs.Containing_Directory (Destination) / Directories.Temp_Name); @@ -206,10 +206,10 @@ package body Alire.User_Pins is & " failed, re-run with -vv -d for details"); end if; - -- Successful checkout + -- Successful checkout, rename into final destination - Adirs.Rename (Temp.Filename, Destination); - Temp.Keep; + Directories.Rename (Temp.Filename, + Destination); end Checkout; ------------ -- 2.39.5