From 0d183915dd7a9358c8b8ff299a87a94be77e4d60 Mon Sep 17 00:00:00 2001 From: "Alejandro R. Mosteo" Date: Fri, 4 Aug 2023 12:12:26 +0200 Subject: [PATCH] Trivial safeguard in `Force_Delete` --- src/alire/alire-directories.adb | 10 +++++++++- src/alire/alire-directories.ads | 4 ++-- src/alr/alr-commands-clean.adb | 4 ++-- 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index 590ca24cb..517171505 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -238,9 +238,17 @@ package body Alire.Directories is -- Force_Delete -- ------------------ - procedure Force_Delete (Path : Any_Path) is + procedure Force_Delete (Path : Absolute_Path) is use Ada.Directories; 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; + if Exists (Path) then if Kind (Path) = Ordinary_File then Trace.Debug ("Deleting file " & Path & "..."); diff --git a/src/alire/alire-directories.ads b/src/alire/alire-directories.ads index 227173b00..bf830694d 100644 --- a/src/alire/alire-directories.ads +++ b/src/alire/alire-directories.ads @@ -51,10 +51,10 @@ package Alire.Directories is -- In Windows, git checkouts are created with read-only file that do not -- sit well with Ada.Directories.Delete_Tree. - procedure Force_Delete (Path : Any_Path); + procedure Force_Delete (Path : Absolute_Path); -- Calls Ensure_Deletable and then uses GNATCOLL.VFS deletion - procedure Delete_Tree (Path : Any_Path) renames Force_Delete; + procedure Delete_Tree (Path : Absolute_Path) renames Force_Delete; -- Delete Path, and anythin below if it was a dir function Find_Files_Under (Folder : String; diff --git a/src/alr/alr-commands-clean.adb b/src/alr/alr-commands-clean.adb index 3770e75b9..33412006d 100644 --- a/src/alr/alr-commands-clean.adb +++ b/src/alr/alr-commands-clean.adb @@ -27,7 +27,7 @@ package body Alr.Commands.Clean is -- Delete -- ------------ - procedure Delete (Path : String) + procedure Delete (Path : Alire.Absolute_Path) is use type Ada.Directories.File_Size; begin @@ -59,7 +59,7 @@ package body Alr.Commands.Clean is -- Current workspace Alire.Directories.Traverse_Tree - (Start => ".", + (Start => Alire.Directories.Current, Doing => Add_Target'Access, Recurse => True);