From 9ec189e82ee930ec9180d3e658b9cfe6d3cf9b10 Mon Sep 17 00:00:00 2001 From: "Alejandro R. Mosteo" Date: Thu, 11 Jul 2024 18:05:11 +0200 Subject: [PATCH] Fix enumeration of files with troublesome softlinks --- .gitmodules | 6 + alire.gpr | 2 + alire.toml | 12 +- alr_env.gpr | 2 + deps/aaa | 2 +- deps/cstrings | 1 + deps/den | 1 + src/alire/alire-directories.adb | 195 +++++++------------ src/alire/alire-directories.ads | 2 +- src/alire/alire-install.adb | 2 +- src/alire/alire-roots.adb | 16 +- src/alire/alire-toml_index.adb | 7 +- src/alire/alire-toolchains.adb | 2 +- src/alr/alr-commands-clean.adb | 2 +- src/alr/alr-commands-test.adb | 2 +- src/alr/alr-files.adb | 24 ++- testsuite/tests/install/softlinks/test.py | 9 +- testsuite/tests/install/softlinks/test.yaml | 2 - testsuite/tests/misc/dir-traversal/test.py | 25 +++ testsuite/tests/misc/dir-traversal/test.yaml | 6 + 20 files changed, 158 insertions(+), 162 deletions(-) create mode 160000 deps/cstrings create mode 160000 deps/den create mode 100644 testsuite/tests/misc/dir-traversal/test.py create mode 100644 testsuite/tests/misc/dir-traversal/test.yaml diff --git a/.gitmodules b/.gitmodules index fc56fd8ee..ec5a589be 100644 --- a/.gitmodules +++ b/.gitmodules @@ -60,3 +60,9 @@ [submodule "deps/dirty_booleans"] path = deps/dirty_booleans url = https://github.com/mosteo/dirty_booleans +[submodule "deps/den"] + path = deps/den + url = https://github.com/mosteo/den +[submodule "deps/cstrings"] + path = deps/cstrings + url = https://github.com/mosteo/cstrings diff --git a/alire.gpr b/alire.gpr index c15a633c6..a00b73f38 100644 --- a/alire.gpr +++ b/alire.gpr @@ -3,7 +3,9 @@ with "ada_toml"; with "alire_common"; with "ajunitgen"; with "ansiada"; +with "c_strings"; with "clic"; +with "den"; with "dirty_booleans"; with "diskflags"; with "gnatcoll"; diff --git a/alire.toml b/alire.toml index 7fb33a2c2..2cbbc4cad 100644 --- a/alire.toml +++ b/alire.toml @@ -19,7 +19,9 @@ aaa = "~0.3.0" ada_toml = "~0.3" ajunitgen = "^1.0.1" ansiada = "^1.0" +c_strings = "^1.0" clic = "~0.3" +den = "~0.1" dirty_booleans = "~0.1" diskflags = "~0.1" gnatcoll = "^21" @@ -50,16 +52,24 @@ windows = { ALIRE_OS = "windows" } [[pins]] [pins.aaa] url = "https://github.com/mosteo/aaa" -commit = "dff61d2615cc6332fa6205267bae19b4d044b9da" +commit = "0c3b440ac183c450345d4a67d407785678779aae" [pins.ada_toml] url = "https://github.com/mosteo/ada-toml" commit = "da4e59c382ceb0de6733d571ecbab7ea4919b33d" +[pins.c_strings] +url = "https://github.com/mosteo/cstrings" +commit = "e5b1931d47b9fee273177773fb5e3f8979bc6076" + [pins.clic] url = "https://github.com/alire-project/clic" commit = "56bbdc008e16996b6f76e443fd0165a240de1b13" +[pins.den] +url = "https://github.com/mosteo/den" +commit = "1f0fe7df0e479e1bf86edd607ffea6bfddb9352e" + [pins.dirty_booleans] url = "https://github.com/mosteo/dirty_booleans" commit = "05c40d88ecfe109e575ec8b21dd6ffa2e61df1dc" diff --git a/alr_env.gpr b/alr_env.gpr index b391c975e..78592c5e6 100644 --- a/alr_env.gpr +++ b/alr_env.gpr @@ -14,6 +14,8 @@ aggregate project Alr_Env is "deps/ajunitgen", "deps/ansi", "deps/clic", + "deps/cstrings", + "deps/den", "deps/dirty_booleans", "deps/diskflags", "deps/gnatcoll-slim", diff --git a/deps/aaa b/deps/aaa index dff61d261..0c3b440ac 160000 --- a/deps/aaa +++ b/deps/aaa @@ -1 +1 @@ -Subproject commit dff61d2615cc6332fa6205267bae19b4d044b9da +Subproject commit 0c3b440ac183c450345d4a67d407785678779aae diff --git a/deps/cstrings b/deps/cstrings new file mode 160000 index 000000000..e5b1931d4 --- /dev/null +++ b/deps/cstrings @@ -0,0 +1 @@ +Subproject commit e5b1931d47b9fee273177773fb5e3f8979bc6076 diff --git a/deps/den b/deps/den new file mode 160000 index 000000000..203512fcb --- /dev/null +++ b/deps/den @@ -0,0 +1 @@ +Subproject commit 203512fcb05ec0e837269f1f156dae513f605077 diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index f9551b4d4..ef1de9da6 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -13,6 +13,8 @@ with Alire.Platforms.Folders; with Alire.VFS; with Alire.Utils; +with Den.Walk; + with GNAT.String_Hash; with GNATCOLL.VFS; @@ -392,51 +394,35 @@ package body Alire.Directories is Max_Depth : Natural := Natural'Last) return AAA.Strings.Vector is + use all type Den.Kinds; Found : AAA.Strings.Vector; - procedure Locate (Folder : String; - Current_Depth : Natural; - Max_Depth : Natural) + ----------- + -- Check -- + ----------- + + procedure Check (Item : Den.Walk.Item; + Enter : in out Boolean; + Stop : in out Boolean) is - use Ada.Directories; - Search : Search_Type; begin - Start_Search (Search, Folder, "", - Filter => (Ordinary_File => True, - Directory => True, - others => False)); - - while More_Entries (Search) loop - declare - Current : Directory_Entry_Type; - begin - Get_Next_Entry (Search, Current); - if Kind (Current) = Directory then - if Simple_Name (Current) /= "." - and then - Simple_Name (Current) /= ".." - and then - Current_Depth < Max_Depth - then - Locate (Folder / Simple_Name (Current), - Current_Depth + 1, - Max_Depth); - end if; - elsif Kind (Current) = Ordinary_File - and then Simple_Name (Current) = Simple_Name (Name) - then - Found.Append (Folder / Name); - end if; - end; - end loop; + Stop := False; - End_Search (Search); - end Locate; + if Max_Depth < Natural'Last and then Item.Depth > Max_Depth then + Enter := False; + end if; + + if Den.Kind (Item.Path) = File + and then Den.Name (Item.Path) = Den.Name (Name) + then + Found.Append (Item.Path); + end if; + end Check; - use Ada.Directories; begin - if Exists (Folder) and then Kind (Folder) = Directory then - Locate (Folder, 0, Max_Depth); + if Den.Exists (Folder) and then Den.Kind (Folder) = Den.Directory then + Den.Walk.Find (Folder, + Check'Access); end if; return Found; @@ -828,25 +814,24 @@ package body Alire.Directories is ----------- procedure Merge - (Item : Ada.Directories.Directory_Entry_Type; + (Item : Any_Path; Stop : in out Boolean) is - use all type Adirs.File_Kind; - + use all type Den.Kinds; Rel_Path : constant Relative_Path := - Find_Relative_Path (Base, Adirs.Full_Name (Item)); + Find_Relative_Path (Base, Den.Absolute (Item)); -- If this proves to be too slow, we should do our own recursion, -- building the relative path along the way, as this is recomputing -- it for every file needlessly. Dst : constant Absolute_Path := Target / Rel_Path; - Src : constant Absolute_Path := Adirs.Full_Name (Item); + Src : constant Absolute_Path := Den.Absolute (Item); begin Stop := False; -- Check if we must skip (we delete source file) - if Adirs.Kind (Item) = Ordinary_File + if Den.Kind (Item) /= Directory and then Skip_Top_Level_Files and then Base = Parent (Src) then @@ -856,7 +841,7 @@ package body Alire.Directories is -- Create a new dir if necessary - if Adirs.Kind (Item) = Directory then + if Den.Kind (Item) = Directory then if not Is_Directory (Dst) then Trace.Debug (" Merge: Creating destination dir " & Dst); Create_Tree (Dst); @@ -870,15 +855,15 @@ package body Alire.Directories is -- Copy file into place Trace.Debug (" Merge: copying " - & Adirs.Full_Name (Item) + & Den.Absolute (Item) & " into " & Dst); - if Adirs.Exists (Dst) then + if Den.Exists (Dst) then if Fail_On_Existing_File then Recoverable_User_Error ("Cannot copy " & TTY.URL (Src) & " into place, file already exists: " & TTY.URL (Dst)); - elsif Adirs.Kind (Dst) /= Ordinary_File then + elsif Den.Kind (Dst) /= File then Raise_Checked_Error ("Cannot overwrite " & TTY.URL (Dst) & " as it is not a regular file"); else @@ -912,7 +897,11 @@ package body Alire.Directories is exception when E : others => Trace.Error - ("When copying " & Src & " --> " & Dst & ": "); + ("When copying " & Src & " (" & Den.Kind (Src)'Image + & ") --> " & Dst & ": "); + Trace.Error + ("Src item was: " + & Item & " (" & Den.Kind (Item)'Image & ")"); Log_Exception (E, Error); raise; end; @@ -941,112 +930,60 @@ package body Alire.Directories is procedure Traverse_Tree (Start : Any_Path; Doing : access procedure - (Item : Ada.Directories.Directory_Entry_Type; + (Item : Any_Path; Stop : in out Boolean); Recurse : Boolean := False; Spinner : Boolean := False) is use Ada.Directories; - Visited : AAA.Strings.Set; - -- To avoid infinite recursion in case of softlinks pointed to parent - -- folders - Progress : Simple_Logging.Ongoing := Simple_Logging.Activity (Text => "Exploring " & Start, Level => (if Spinner then Info else Debug)); - procedure Go_Down (Item : Directory_Entry_Type); - - ---------------------------- - -- Traverse_Tree_Internal -- - ---------------------------- - - procedure Traverse_Tree_Internal - (Start : Any_Path; - Doing : access procedure - (Item : Ada.Directories.Directory_Entry_Type; - Stop : in out Boolean); - Recurse : Boolean := False) - is - pragma Unreferenced (Doing, Recurse); - begin - Search (Start, - "", - (Directory => True, Ordinary_File => True, others => False), - Go_Down'Access); - end Traverse_Tree_Internal; - ------------- -- Go_Down -- ------------- - procedure Go_Down (Item : Directory_Entry_Type) is - Stop : Boolean := False; - Prune : Boolean := False; - VF : constant VFS.Virtual_File := - VFS.New_Virtual_File (VFS.From_FS (Full_Name (Item))); - -- We use this later to check whether this is a soft link + procedure Go_Down (This : Den.Walk.Item; + Enter : in out Boolean; + Stop : in out Boolean) + is + use all type Den.Kinds; + Path : constant Any_Path := This.Path; begin + Enter := True; + Stop := False; - -- Ada.Directories reports softlinks not as special files but as the - -- target of the link. This confuses users of Traverse_Tree that may - -- see files within a folder that has never been visited before. - - -- Short of introducing new file kinds for softlinks and reporting - -- them to clients, for now we just ignore softlinks to dirs, and - -- this way only actual folders are traversed. - - if VF.Is_Symbolic_Link and then Kind (Item) = Directory then - Trace.Warning ("Skipping softlink dir during tree traversal: " - & Full_Name (Item)); + begin + Doing (This.Path, Stop); + exception + when Traverse_Tree_Prune_Dir => + Enter := False; + end; + if Stop then return; end if; - if Simple_Name (Item) /= "." and then Simple_Name (Item) /= ".." then - begin - Doing (Item, Stop); - exception - when Traverse_Tree_Prune_Dir => - Prune := True; - end; - if Stop then - return; - end if; - - if not Prune and then Recurse and then Kind (Item) = Directory then - declare - Normal_Name : constant Absolute_Path - := - String (GNATCOLL.VFS.Full_Name - (VFS.New_Virtual_File (Full_Name (Item)), - Normalize => True, - Resolve_Links => True).all); - begin - if Visited.Contains (Normal_Name) then - Trace.Debug ("Not revisiting " & Normal_Name); - else - Visited.Insert (Normal_Name); - if Spinner then - Progress.Step ("Exploring .../" & Simple_Name (Item)); - end if; - Traverse_Tree_Internal (Normal_Name, Doing, Recurse); - end if; - end; - elsif Prune and then Kind (Item) = Directory then - Trace.Debug ("Skipping dir: " & Full_Name (Item)); - elsif Prune and then Kind (Item) /= Directory then - Trace.Warning ("Pruning of non-dir entry has no effect: " - & Full_Name (Item)); + if Enter and then Recurse and then Den.Kind (Path) = Directory then + if Spinner then + Progress.Step ("Exploring .../" & Simple_Name (Path)); end if; + elsif not Enter and then Den.Kind (Path) = Directory then + Trace.Debug ("Skipping dir: " & Full_Name (Path)); + elsif not Enter and then Den.Kind (Path) /= Directory then + Trace.Warning ("Pruning of non-dir entry has no effect: " + & Full_Name (Path)); end if; end Go_Down; begin Trace.Debug ("Traversing folder: " & Adirs.Full_Name (Start)); - Traverse_Tree_Internal (Start, Doing, Recurse); + Den.Walk.Find (Start, + Action => Go_Down'Access, + Options => (Enter_Regular_Dirs => Recurse, others => <>)); end Traverse_Tree; --------------- @@ -1062,7 +999,7 @@ package body Alire.Directories is -- Accumulate -- ---------------- - procedure Accumulate (Item : Directory_Entry_Type; + procedure Accumulate (Item : Any_Path; Stop : in out Boolean) is begin diff --git a/src/alire/alire-directories.ads b/src/alire/alire-directories.ads index bbf513751..250b4b709 100644 --- a/src/alire/alire-directories.ads +++ b/src/alire/alire-directories.ads @@ -114,7 +114,7 @@ package Alire.Directories is procedure Traverse_Tree (Start : Any_Path; Doing : access procedure - (Item : Ada.Directories.Directory_Entry_Type; + (Item : Any_Path; Stop : in out Boolean); Recurse : Boolean := False; Spinner : Boolean := False); diff --git a/src/alire/alire-install.adb b/src/alire/alire-install.adb index 319237029..133fcda61 100644 --- a/src/alire/alire-install.adb +++ b/src/alire/alire-install.adb @@ -395,7 +395,7 @@ package body Alire.Install is Result : Installed_Milestones; procedure Find - (Item : Ada.Directories.Directory_Entry_Type; + (Item : Any_Path; Stop : in out Boolean) is Name : constant String := Adirs.Simple_Name (Item); diff --git a/src/alire/alire-roots.adb b/src/alire/alire-roots.adb index 5b60531da..45e6dd563 100644 --- a/src/alire/alire-roots.adb +++ b/src/alire/alire-roots.adb @@ -20,6 +20,8 @@ with Alire.User_Pins.Maps; with Alire.Utils.TTY; with Alire.Utils.User_Input; +with Den; + with GNAT.OS_Lib; with GNAT.SHA256; @@ -1229,17 +1231,17 @@ package body Alire.Roots is Found : AAA.Strings.Set; -- Milestone --> Description procedure Check_Dir - (Item : Ada.Directories.Directory_Entry_Type; - Stop : in out Boolean) + (Item : Any_Path; + Stop : in out Boolean) is pragma Unreferenced (Stop); - use Ada.Directories; + use all type Den.Kinds; begin - if Kind (Item) /= Directory then + if Den.Kind (Item) /= Directory then return; end if; - if Simple_Name (Item) = Paths.Working_Folder_Inside_Root + if Den.Name (Item) = Paths.Working_Folder_Inside_Root then -- This is an alire metadata folder, don't go in. It could also be -- a crate named "alire" but that seems like a bad idea anyway. @@ -1250,12 +1252,12 @@ package body Alire.Roots is declare Opt : Optional.Root := - Optional.Detect_Root (Full_Name (Item)); + Optional.Detect_Root (Den.Full_Name (Item)); begin if Opt.Is_Valid then Found.Insert (TTY.URL (Directories.Find_Relative_Path - (Starting_Path, Full_Name (Item))) & "/" + (Starting_Path, Den.Full_Name (Item))) & "/" & Opt.Value.Release.Constant_Reference.Milestone.TTY_Image & ": " & TTY.Emph (if Opt.Value.Release.Constant_Reference.Description /= "" diff --git a/src/alire/alire-toml_index.adb b/src/alire/alire-toml_index.adb index b60e714b0..8534d77e1 100644 --- a/src/alire/alire-toml_index.adb +++ b/src/alire/alire-toml_index.adb @@ -58,7 +58,7 @@ package body Alire.TOML_Index is -- describes a supported index, and that the file tree follows the proper -- naming conventions, without extraneous files being present. - procedure Load_Manifest (Item : Ada.Directories.Directory_Entry_Type; + procedure Load_Manifest (Item : Any_Path; Stop : in out Boolean); -- Check if entry is a candidate to manifest file, and in that case load -- its contents. May raise Checked_Error. @@ -273,7 +273,8 @@ package body Alire.TOML_Index is end return; when others => Result := - Outcome_Failure ("Several index.toml files found in index"); + Outcome_Failure ("Several index.toml files found in index: " + & Repo_Version_Files.Flatten (";")); return ""; end case; end Locate_Root; @@ -357,7 +358,7 @@ package body Alire.TOML_Index is -- Load_Manifest -- ------------------- - procedure Load_Manifest (Item : Ada.Directories.Directory_Entry_Type; + procedure Load_Manifest (Item : Any_Path; Stop : in out Boolean) is pragma Unreferenced (Stop); diff --git a/src/alire/alire-toolchains.adb b/src/alire/alire-toolchains.adb index 08a118e43..370e6f660 100644 --- a/src/alire/alire-toolchains.adb +++ b/src/alire/alire-toolchains.adb @@ -527,7 +527,7 @@ package body Alire.Toolchains is -- Detect -- ------------ - procedure Detect (Item : Ada.Directories.Directory_Entry_Type; + procedure Detect (Item : Any_Path; Stop : in out Boolean) is use Ada.Directories; diff --git a/src/alr/alr-commands-clean.adb b/src/alr/alr-commands-clean.adb index d22918736..1e58bc496 100644 --- a/src/alr/alr-commands-clean.adb +++ b/src/alr/alr-commands-clean.adb @@ -42,7 +42,7 @@ package body Alr.Commands.Clean is -- Add_Target -- ---------------- - procedure Add_Target (Item : Ada.Directories.Directory_Entry_Type; + procedure Add_Target (Item : Alire.Any_Path; Unused_Stop : in out Boolean) is use Ada.Directories; diff --git a/src/alr/alr-commands-test.adb b/src/alr/alr-commands-test.adb index cfe4c35dd..d16d31705 100644 --- a/src/alr/alr-commands-test.adb +++ b/src/alr/alr-commands-test.adb @@ -436,7 +436,7 @@ package body Alr.Commands.Test is -- Not_Empty -- --------------- - procedure Not_Empty (Item : Ada.Directories.Directory_Entry_Type; + procedure Not_Empty (Item : Alire.Any_Path; Stop : in out Boolean) is pragma Unreferenced (Item, Stop); diff --git a/src/alr/alr-files.adb b/src/alr/alr-files.adb index f728fa1c5..22cf73dea 100644 --- a/src/alr/alr-files.adb +++ b/src/alr/alr-files.adb @@ -1,4 +1,4 @@ -with Ada.Directories; +with Den; package body Alr.Files is @@ -7,19 +7,27 @@ package body Alr.Files is ------------------------- function Locate_Any_GPR_File return Natural is - use Ada.Directories; Candidates : AAA.Strings.Vector; - procedure Check (File : Directory_Entry_Type) is + ----------- + -- Check -- + ----------- + + procedure Check (File : Alire.Any_Path; Stop : in out Boolean) is + use AAA.Strings; begin - Candidates.Append (Full_Name (File)); + Stop := False; + if Den.Kind (File) in Den.File + and then Has_Suffix (To_Lower_Case (File), ".gpr") + then + Candidates.Append (Den.Full (File)); + end if; end Check; begin - Search (Current_Directory, - "*.gpr", - (Ordinary_File => True, others => False), - Check'Access); + Alire.Directories.Traverse_Tree + (Alire.Directories.Current, + Check'Access); return Natural (Candidates.Length); end Locate_Any_GPR_File; diff --git a/testsuite/tests/install/softlinks/test.py b/testsuite/tests/install/softlinks/test.py index a0f881d6f..dcebdcca2 100644 --- a/testsuite/tests/install/softlinks/test.py +++ b/testsuite/tests/install/softlinks/test.py @@ -30,8 +30,9 @@ import os import shutil +import subprocess from drivers.alr import run_alr, crate_dirname -from drivers.helpers import contents, on_windows +from drivers.helpers import contents def kind(file): @@ -42,11 +43,6 @@ def ls(path): return out.stdout -# Does not apply to Windows as it does not support softlinks -if on_windows(): - print('SKIP: on Windows, unapplicable') - sys.exit(0) - # This command should succeed normally run_alr("install", "--prefix=install", "crate") @@ -80,5 +76,6 @@ def ls(path): # Cleanup os.chdir("..") shutil.rmtree(cratedir) +shutil.rmtree("install") print('SUCCESS') diff --git a/testsuite/tests/install/softlinks/test.yaml b/testsuite/tests/install/softlinks/test.yaml index 1f89021f2..0a859639c 100644 --- a/testsuite/tests/install/softlinks/test.yaml +++ b/testsuite/tests/install/softlinks/test.yaml @@ -1,6 +1,4 @@ driver: python-script -control: - - [SKIP, "skip_unix", "Test is Unix-only"] indexes: my_index: in_fixtures: false diff --git a/testsuite/tests/misc/dir-traversal/test.py b/testsuite/tests/misc/dir-traversal/test.py new file mode 100644 index 000000000..408943982 --- /dev/null +++ b/testsuite/tests/misc/dir-traversal/test.py @@ -0,0 +1,25 @@ +""" +Check that broken/recursive symlinks don't cause alr to fail +""" + +import os +from drivers.alr import run_alr, init_local_crate +# from drivers.asserts import assert_eq, assert_match + +init_local_crate() + +# Create a symbolic link to itself. This used to cause alr to fail. +os.symlink("self", "self") + +# Commands that traverse looking for things (crates, executables) shouldn't +# fail. + +run_alr("clean", "--temp") +run_alr("run") +run_alr("run", "--list") +run_alr("show", "--nested") + +# Remove the symlink, otherwise it breaks the testsuite driver +os.unlink("self") + +print("SUCCESS") \ No newline at end of file diff --git a/testsuite/tests/misc/dir-traversal/test.yaml b/testsuite/tests/misc/dir-traversal/test.yaml new file mode 100644 index 000000000..9a541fdd1 --- /dev/null +++ b/testsuite/tests/misc/dir-traversal/test.yaml @@ -0,0 +1,6 @@ +driver: python-script +build_mode: both +control: + - [SKIP, "skip_unix", "Test is Unix-only"] +indexes: + compiler_only_index: {}