From fb01b7ab614bedec52d002c82d95117b52652135 Mon Sep 17 00:00:00 2001 From: "Alejandro R. Mosteo" Date: Sun, 25 Feb 2024 22:55:12 +0100 Subject: [PATCH] bug box in case of Program_Error --- src/alire/alire-directories.adb | 4 +- src/alire/alire-errors.adb | 76 ++++++++++++++++++++++++++++ src/alire/alire-errors.ads | 15 ++++++ src/alire/alire-install.adb | 2 +- src/alire/alire-publish.adb | 10 ++-- src/alire/alire-releases.adb | 4 +- src/alire/alire-roots-editable.adb | 2 +- src/alire/alire-roots.adb | 11 ++-- src/alire/alire-solutions-diffs.adb | 8 +-- src/alire/alire-solutions.adb | 8 +-- src/alire/alire-toml_adapters.adb | 7 +-- src/alire/alire-toolchains.adb | 2 +- src/alire/alire-utils-user_input.adb | 2 +- src/alire/alire.adb | 18 +++++-- src/alire/alire.ads | 22 ++++---- src/alr/alr-actions.adb | 6 ++- src/alr/alr-commands-dev.adb | 9 ++++ src/alr/alr-commands-dev.ads | 1 + src/alr/alr-commands-toolchain.adb | 2 +- src/alr/alr-last_chance_handler.adb | 11 ++++ src/alr/alr-main.adb | 8 +++ 21 files changed, 184 insertions(+), 44 deletions(-) diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index a5c3f8e24..6b1c68830 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -331,7 +331,7 @@ package body Alire.Directories is -- like "/c/alire". This is for peace of mind. if Path'Length < 8 then - Recoverable_Error ("Suspicious deletion request for path: " & Path); + Recoverable_User_Error ("Suspicious deletion request for path: " & Path); end if; if Exists (Path) then @@ -828,7 +828,7 @@ package body Alire.Directories is if Adirs.Exists (Dst) then if Fail_On_Existing_File then - Recoverable_Error ("Cannot move " & TTY.URL (Src) + Recoverable_User_Error ("Cannot move " & TTY.URL (Src) & " into place, file already exists: " & TTY.URL (Dst)); elsif Adirs.Kind (Dst) /= Ordinary_File then diff --git a/src/alire/alire-errors.adb b/src/alire/alire-errors.adb index 4cf4adde9..b1a0a0fb8 100644 --- a/src/alire/alire-errors.adb +++ b/src/alire/alire-errors.adb @@ -1,4 +1,9 @@ +with AAA.Debug; +with AAA.Strings; + with Ada.Containers.Indefinite_Ordered_Maps; + +with Alire.OS_Lib; with Alire.Utils; package body Alire.Errors is @@ -238,4 +243,75 @@ package body Alire.Errors is return +Msg & Text; end Stack; + ------------------- + -- Program_Error -- + ------------------- + + procedure Program_Error (Explanation : String := ""; + Recoverable : Boolean := True; + Stack_Trace : String := ""; + Stack_Offset : Natural := 0) + is + Stack : constant AAA.Strings.Vector := + AAA.Strings.Split + ((if Stack_Trace /= "" + then Stack_Trace + else AAA.Debug.Stack_Trace), + ASCII.LF); + + Caller : constant Positive := + 5 + Stack_Offset - (if Stack_Trace /= "" then 2 else 0); + -- The minus 2 is because in stacks obtained from the original exception: + -- 1) Except name 2) exec name 3) stack start + -- If instead we use AAA.Debug.Stack_Trace: + -- 1) Except name 2) exec name 3) AAA.Debug 4) here 5) caller + + URL : constant String + := "https://github.com/alire-project/alire/issues/new?title=[Bug%20box]"; + + Level : constant Trace.Levels := + (if Recoverable then Warning else Error); + + --------- + -- Put -- + --------- + + procedure Put (Msg : String) is + begin + Trace.Log (Msg, Level); + end Put; + + begin + Trace.Debug (AAA.Debug.Stack_Trace); + + Put ("******************* BEGIN Alire bug detected *******************"); + Put ("Location : " + & (if integer (Stack.Length) >= Caller + then Stack (Caller) + else "")); + + if Explanation /= "" then + Put ("Extra info: " & Explanation); + end if; + + Put ("Report at : " & URL); + + if Log_Level < Debug or else not Log_Debug then + Put ("Re-run with `-vv -d` for a full stack trace."); + end if; + + if Recoverable then + Put + (TTY.Bold + ("Alire will now continue as the error might be recoverable.")); + end if; + + Put ("******************** END Alire bug detected ********************"); + + if not Recoverable then + -- Do not re-raise as we would end repeating the -vv -d info + OS_Lib.Bailout (1); + end if; + end Program_Error; + end Alire.Errors; diff --git a/src/alire/alire-errors.ads b/src/alire/alire-errors.ads index 762366c57..856da6900 100644 --- a/src/alire/alire-errors.ads +++ b/src/alire/alire-errors.ads @@ -122,6 +122,21 @@ package Alire.Errors with Preelaborate is function Stack (Text : String) return String; -- Return current error stack, plus Text as the latest error + ----------- + -- Other -- + ----------- + + procedure Program_Error (Explanation : String := ""; + Recoverable : Boolean := True; + Stack_Trace : String := ""; + Stack_Offset : Natural := 0); + -- For unexpected situations where normally a Program_Error would be + -- adecuate, but we do not want to bomb on the user because continuing is + -- acceptable. We log a stack trace, print a warning and continue, so a + -- motivated user can report an issue, but we don't needlessly raise. If + -- not Survivable, then do raise a Program_Error. If Stack_Trace /= "", + -- use it instead of generating one. + private Id_Marker : constant String := "alire-stored-error:"; diff --git a/src/alire/alire-install.adb b/src/alire/alire-install.adb index 795e31fae..319237029 100644 --- a/src/alire/alire-install.adb +++ b/src/alire/alire-install.adb @@ -327,7 +327,7 @@ package body Alire.Install is -- A different version exists, here we fail unless forced - Recoverable_Error + Recoverable_User_Error (Errors.New_Wrapper ("Release " & Rel.Milestone.TTY_Image & " has another version already installed: ") diff --git a/src/alire/alire-publish.adb b/src/alire/alire-publish.adb index 7933986d4..61c9905fc 100644 --- a/src/alire/alire-publish.adb +++ b/src/alire/alire-publish.adb @@ -244,7 +244,7 @@ package body Alire.Publish is Index_On_Disk.Loading.Load_All (Strict => True).Assert; if Index.Exists (Release.Name, Release.Version) then - Recoverable_Error + Recoverable_User_Error ("Target release " & Release.Milestone.TTY_Image & " already exist in a loaded index"); end if; @@ -564,7 +564,7 @@ package body Alire.Publish is if OS_Lib.Getenv (Environment.Testsuite, "unset") /= "unset" and then OS_Lib.Getenv (Environment.Testsuite_Allow, "unset") = "unset" then - raise Program_Error + raise Constraint_Error with "Attempting to go online to create a PR during tests"; end if; @@ -827,7 +827,7 @@ package body Alire.Publish is -- User must exist if not GitHub.User_Exists (Login) then - Recoverable_Error + Recoverable_User_Error ("Your GitHub login does not seem to exist: " & TTY.Emph (Login)); end if; @@ -838,7 +838,7 @@ package body Alire.Publish is Put_Success ("User has forked the community repository"); else if not Submit.Ask_To_Fork (Context) then - Recoverable_Error + Recoverable_User_Error ("You must fork the community index to your GitHub account" & ASCII.LF & "Please visit " & TTY.URL (Tail (Index.Community_Repo, '+')) @@ -868,7 +868,7 @@ package body Alire.Publish is -- Otherwise we assume this is a local path - Recoverable_Error + Recoverable_User_Error ("The origin must be a definitive remote location, but is " & URL); -- For testing we may want to allow local URLs, or may be for -- internal use with network drives? So allow forcing it. diff --git a/src/alire/alire-releases.adb b/src/alire/alire-releases.adb index b944de4e8..95aa11ef5 100644 --- a/src/alire/alire-releases.adb +++ b/src/alire/alire-releases.adb @@ -201,8 +201,8 @@ package body Alire.Releases is & (case R.Origin.Kind is when Git | Hg => R.Origin.Short_Unique_Id, when SVN => R.Origin.Commit, - when others => raise Program_Error - with "monorepo folder only applies to VCS origins"); + when others => raise Program_Error with + "monorepo folder only applies to VCS origins"); end Monorepo_Path; ------------------ diff --git a/src/alire/alire-roots-editable.adb b/src/alire/alire-roots-editable.adb index bb59bd76b..a54d4f020 100644 --- a/src/alire/alire-roots-editable.adb +++ b/src/alire/alire-roots-editable.adb @@ -135,7 +135,7 @@ package body Alire.Roots.Editable is and then not Index.Exists (Dep.Crate) and then Index.Releases_For_Crate (Dep.Crate).Is_Empty then - Alire.Recoverable_Error + Alire.Recoverable_User_Error ("Cannot add crate '" & Alire.Utils.TTY.Name (Dep.Crate) & "' not found in index."); end if; diff --git a/src/alire/alire-roots.adb b/src/alire/alire-roots.adb index 82c0dc919..29630d489 100644 --- a/src/alire/alire-roots.adb +++ b/src/alire/alire-roots.adb @@ -21,6 +21,7 @@ with Alire.Utils.TTY; with Alire.Utils.User_Input; with GNAT.OS_Lib; +with GNAT.SHA256; with Semantic_Versioning.Extended; @@ -317,7 +318,10 @@ package body Alire.Roots is ("Requested build hash of release " & Name.As_String & " not among solution states:"); This.Solution.Print_States (" ", Error); - raise Program_Error; + Recoverable_Program_Error ("using default hash"); + -- Using an improperly computed hash may cause some unexpected + -- recompilations but should be less of a show-stopper. + return "error:" & GNAT.SHA256.Digest (Name.As_String); end if; end Build_Hash; @@ -1516,7 +1520,8 @@ package body Alire.Roots is elsif This.Solution.State (Crate).Is_Linked then return This.Solution.State (Crate).Link.Path; else - raise Program_Error with "release must be either solved or linked"; + raise Program_Error with + "release must be either solved or linked"; end if; end Release_Base; @@ -1887,7 +1892,7 @@ package body Alire.Roots is if Old.Pins.Contains (Crate) then -- The solver will never update a pinned crate, so we may allow -- this to be attempted but it will have no effect. - Recoverable_Error + Recoverable_User_Error ("Requested crate is pinned and cannot be updated: " & Alire.Utils.TTY.Name (Crate)); end if; diff --git a/src/alire/alire-solutions-diffs.adb b/src/alire/alire-solutions-diffs.adb index 49289e28e..3c85b10d5 100644 --- a/src/alire/alire-solutions-diffs.adb +++ b/src/alire/alire-solutions-diffs.adb @@ -303,7 +303,8 @@ package body Alire.Solutions.Diffs is -- disappearing from the solutions. Chg.Best_Version := +Best_Version (Former); else - raise Program_Error with "crate is neither in former or latter"; + Recoverable_Program_Error + ("crate is neither in former or latter"); end if; end Determine_Relevant_Version; @@ -335,11 +336,10 @@ package body Alire.Solutions.Diffs is if Rel.Origin.Kind in Report_Kinds then Add_Change (Chg, Icon (Binary), TTY.Warn - (case Rel.Origin.Kind is + (case Report_Kinds (Rel.Origin.Kind) is when Binary_Archive => "binary", when External => "executable in path", - when System => "system package", - when others => raise Program_Error)); + when System => "system package")); end if; end; end Releases_Without_Sources; diff --git a/src/alire/alire-solutions.adb b/src/alire/alire-solutions.adb index 9c91bd296..e0ea1db4e 100644 --- a/src/alire/alire-solutions.adb +++ b/src/alire/alire-solutions.adb @@ -788,7 +788,7 @@ package body Alire.Solutions is & TTY.Emph (" (pinned)"), Level); else - Report_Program_Error; + Recoverable_Program_Error; -- This should be unreachable, as dependencies in this block -- should either have a release or a link. end if; -- has release @@ -1276,7 +1276,7 @@ package body Alire.Solutions is end loop; raise Program_Error with Errors.Set - ("No dependency in solution matches release " + ("No dependency in solution matches release " & Release.Milestone.TTY_Image); end State; @@ -1540,8 +1540,8 @@ package body Alire.Solutions is -- that were marked as safe to visit in the 1st step of the round. if To_Remove.Is_Empty then - raise Program_Error - with "No release visited in round" & Round'Img; + raise Program_Error with + "No release visited in round" & Round'Img; else for Dep of To_Remove loop Visit (Dep); diff --git a/src/alire/alire-toml_adapters.adb b/src/alire/alire-toml_adapters.adb index 75a229436..4f2d780a1 100644 --- a/src/alire/alire-toml_adapters.adb +++ b/src/alire/alire-toml_adapters.adb @@ -68,7 +68,7 @@ package body Alire.TOML_Adapters is is begin if Recover then - Recoverable_Error (Message, Recover); + Recoverable_User_Error (Message, Recover); else Queue.Checked_Error (Message); end if; @@ -86,7 +86,8 @@ package body Alire.TOML_Adapters is Queue.Assert_Key (Key, Kind); return Value : TOML.TOML_Value do if not Queue.Pop (Key, Value) then - raise Program_Error with ("missing key, but it was just checked?"); + raise Program_Error with + "missing key, but it was just checked?"; end if; end return; end Checked_Pop; @@ -327,7 +328,7 @@ package body Alire.TOML_Adapters is if Errored then if Force then - Recoverable_Error (+Message); + Recoverable_User_Error (+Message); return Outcome_Success; else return Outcome_Failure (+Message); diff --git a/src/alire/alire-toolchains.adb b/src/alire/alire-toolchains.adb index 184fffe4c..cc1412dab 100644 --- a/src/alire/alire-toolchains.adb +++ b/src/alire/alire-toolchains.adb @@ -683,7 +683,7 @@ package body Alire.Toolchains is end if; if Toolchains.Solutions.Is_In_Toolchain (Release) then - Recoverable_Error ("The release to be removed (" + Recoverable_User_Error ("The release to be removed (" & Release.Milestone.TTY_Image & ") is part of the " & "configured default toolchain."); diff --git a/src/alire/alire-utils-user_input.adb b/src/alire/alire-utils-user_input.adb index 9dd6401be..ed7913c1f 100644 --- a/src/alire/alire-utils-user_input.adb +++ b/src/alire/alire-utils-user_input.adb @@ -79,7 +79,7 @@ package body Alire.Utils.User_Input is if not Check_Absolute_Path (User_Path) and then not VFS.Is_Portable (User_Path) then - Recoverable_Error + Recoverable_User_Error (Error_When_Relative_Native & ": " & TTY.URL (User_Path)); end if; diff --git a/src/alire/alire.adb b/src/alire/alire.adb index 42c814ae0..83b596efe 100644 --- a/src/alire/alire.adb +++ b/src/alire/alire.adb @@ -276,12 +276,12 @@ package body Alire is -- Recoverable_Error -- ----------------------- - procedure Recoverable_Error (Msg : String; Recover : Boolean := Force) is + procedure Recoverable_User_Error (Msg : String; Recover : Boolean := Force) is Info : constant String := " (This error can be overridden with " & TTY.Terminal ("--force") & ".)"; begin if Msg'Length > 0 and then Msg (Msg'Last) /= '.' then - Recoverable_Error (Msg & ".", Recover); + Recoverable_User_Error (Msg & ".", Recover); return; end if; @@ -290,7 +290,19 @@ package body Alire is else Raise_Checked_Error (Msg & Info); end if; - end Recoverable_Error; + end Recoverable_User_Error; + + ------------------------------- + -- Recoverable_Program_Error -- + ------------------------------- + + procedure Recoverable_Program_Error (Explanation : String := "") is + begin + Errors.Program_Error (Explanation, + Recoverable => True, + Stack_Offset => 1); + -- Offset is 1 because this procedure adds its own stack frame + end Recoverable_Program_Error; -------------- -- New_Line -- diff --git a/src/alire/alire.ads b/src/alire/alire.ads index e2d207f54..857141962 100644 --- a/src/alire/alire.ads +++ b/src/alire/alire.ads @@ -235,17 +235,17 @@ package Alire with Preelaborate is -- message (Msg) and raise Checked_Error. There is no limitation on the -- length of Msg. - procedure Recoverable_Error (Msg : String; Recover : Boolean := Force); - -- When Recover, emit a warning and return normally. When not Recover call - -- Raise_Checked_Error instead. - - procedure Report_Program_Error (Explanation : String := ""; - Survivable : Boolean := True) is null; - -- For unexpected situations where normally a Program_Error would be - -- adecuate, but we do not want to bomb on the user because continuing is - -- acceptable. We log a stack trace, print a warning and continue, so - -- a motivated user can report an issue, but we don't needlessly raise. If - -- not Survivable, then do raise a Program_Error. + procedure Recoverable_User_Error (Msg : String; Recover : Boolean := Force); + -- A User_Error is an attempt to do something that we don't allow by + -- default, but that could make sense if you know what are doing in dubious + -- situations. When Recover, emit a warning and return normally. When not + -- Recover call Raise_Checked_Error instead. + + procedure Recoverable_Program_Error (Explanation : String := ""); + -- This, instead, is for situations that should never happen but that + -- are easy to detect and allow continuing, so instead of raising a + -- Program_Error deliberately, we give the same kind of feedback but + -- without raising. --------------- -- LOGGING -- diff --git a/src/alr/alr-actions.adb b/src/alr/alr-actions.adb index 0f3d058d1..ece8e9f9b 100644 --- a/src/alr/alr-actions.adb +++ b/src/alr/alr-actions.adb @@ -1,5 +1,6 @@ with Ada.Tags; +with Alire.Errors; with Alire.Utils; with Alr.OS_Lib; @@ -38,8 +39,9 @@ package body Alr.Actions is if This in Run'Class then Execute_Run (Run (This)); else - raise Program_Error - with "Unknown action class: " & Ada.Tags.External_Tag (This'Tag); + Alire.Errors.Report_Program_Error + ("Unknown action class: " & Ada.Tags.External_Tag (This'Tag), + Survivable => False); end if; end Execute; diff --git a/src/alr/alr-commands-dev.adb b/src/alr/alr-commands-dev.adb index e58627303..444f3ad1a 100644 --- a/src/alr/alr-commands-dev.adb +++ b/src/alr/alr-commands-dev.adb @@ -69,6 +69,10 @@ package body Alr.Commands.Dev is Trace.Debug ("In dev --filter"); end if; + if Cmd.Error then + Alire.Recoverable_Program_Error ("Forced error"); + end if; + if Cmd.Raise_Except then raise Program_Error with "Raising forcibly"; end if; @@ -119,6 +123,11 @@ package body Alr.Commands.Dev is "", "--filter", "Used by scope filtering test"); + Define_Switch (Config, + Cmd.Error'Access, + "", "--error", + "Program error report"); + Define_Switch (Config, Cmd.Raise_Except'Access, "", "--raise", diff --git a/src/alr/alr-commands-dev.ads b/src/alr/alr-commands-dev.ads index 3ca5591e7..bebb54a6e 100644 --- a/src/alr/alr-commands-dev.ads +++ b/src/alr/alr-commands-dev.ads @@ -34,6 +34,7 @@ private type Command is new Commands.Command with record Custom : aliased Boolean := False; -- Custom code to run instead Filtering : aliased Boolean := False; -- Runs debug scope filtering + Error : aliased Boolean := False; -- Create a recoverable error Raise_Except : aliased Boolean := False; Raise_Final : aliased Boolean := False; Self_Test : aliased Boolean := False; diff --git a/src/alr/alr-commands-toolchain.adb b/src/alr/alr-commands-toolchain.adb index cdfa6f842..bac265cf4 100644 --- a/src/alr/alr-commands-toolchain.adb +++ b/src/alr/alr-commands-toolchain.adb @@ -233,7 +233,7 @@ package body Alr.Commands.Toolchain is -- Check for mixed-origin clashes if Origin_Status = Frozen and then Rel.Origin.Kind /= Origin_Kind then - Recoverable_Error + Recoverable_User_Error ("Currently configured " & Utils.TTY.Name (The_Other (Dep.Crate)) & " has origin " & TTY.Emph (Origin_Kind'Image) & " but newly selected " & Utils.TTY.Name (Dep.Crate) diff --git a/src/alr/alr-last_chance_handler.adb b/src/alr/alr-last_chance_handler.adb index e858201c6..e27581cc9 100644 --- a/src/alr/alr-last_chance_handler.adb +++ b/src/alr/alr-last_chance_handler.adb @@ -1,13 +1,24 @@ +with AAA.Strings; + +with Ada.Exceptions; + with Alire.Errors; with Alr.OS_Lib; procedure Alr.Last_Chance_Handler (E : Ada.Exceptions.Exception_Occurrence) is + Stack : constant AAA.Strings.Vector := + AAA.Strings.Split (Ada.Exceptions.Exception_Information (E), + ASCII.LF); + Caller : constant := 3; -- 1) except name 2) exe name 3) stack start begin -- Ensure we do not show an exception trace to unsuspecting users Alire.Log_Exception (E); Alire.Errors.Pretty_Print (Alire.Errors.Get (E)); Alr.Trace.Error ("alr encountered an unexpected error," & " re-run with -d for details."); + if Natural (Stack.Length) >= Caller then + Alr.Trace.Error ("error location: " & Stack (Caller)); + end if; Alr.OS_Lib.Bailout (1); end Alr.Last_Chance_Handler; diff --git a/src/alr/alr-main.adb b/src/alr/alr-main.adb index b7519169f..896ce26f4 100644 --- a/src/alr/alr-main.adb +++ b/src/alr/alr-main.adb @@ -1,4 +1,7 @@ +with Ada.Exceptions; + with Alire_Early_Elaboration; pragma Elaborate_All (Alire_Early_Elaboration); +with Alire.Errors; with Alr.Commands; with Alr.Last_Chance_Handler; @@ -9,6 +12,11 @@ begin Commands.Execute; exception + when E : Program_Error => + Alire.Errors.Program_Error + (Explanation => Alire.Errors.Get (E), + Recoverable => False, + Stack_Trace => Ada.Exceptions.Exception_Information (E)); when E : others => Last_Chance_Handler (E); end Alr.Main;