diff --git a/alire.toml b/alire.toml index 107a13cfd..8c620105f 100644 --- a/alire.toml +++ b/alire.toml @@ -48,8 +48,8 @@ windows = { ALIRE_OS = "windows" } aaa = { url = "https://github.com/mosteo/aaa", commit = "fbfffb1cb269a852201d172119d94f3024b617f2" } ada_toml = { url = "https://github.com/mosteo/ada-toml", commit = "da4e59c382ceb0de6733d571ecbab7ea4919b33d" } clic = { url = "https://github.com/alire-project/clic", commit = "6879b90876a1c918b4e112f59c6db0e25b713f52" } -gnatcoll = { url = "https://github.com/alire-project/gnatcoll-core.git", commit = "403efe11405113cf12ae3d014df474cf7a046176" } -minirest = { url = "https://github.com/mosteo/minirest.git", commit = "17fa789b71ccaf65e8c892816456c94a09a384d0" } +gnatcoll = { url = "https://github.com/alire-project/gnatcoll-core.git", commit = "4e663b87a028252e7e074f054f8f453661397166" } +minirest = { url = "https://github.com/mosteo/minirest.git", commit = "9a9c660f9c6f27f5ef75417e7fac7061dff14d78" } semantic_versioning = { url = "https://github.com/alire-project/semantic_versioning", commit = "2f23fc5f6b4855b836b599adf292fed9c0ed4144" } simple_logging = { url = "https://github.com/alire-project/simple_logging", commit = "3505dc645f3eef6799a486aae223d37e88cfc4d5" } stopwatch = { url = "https://github.com/mosteo/stopwatch", commit = "f607a63b714f09bbf6126de9851cbc21cf8666c9" } diff --git a/deps/gnatcoll-slim b/deps/gnatcoll-slim index 403efe114..4e663b87a 160000 --- a/deps/gnatcoll-slim +++ b/deps/gnatcoll-slim @@ -1 +1 @@ -Subproject commit 403efe11405113cf12ae3d014df474cf7a046176 +Subproject commit 4e663b87a028252e7e074f054f8f453661397166 diff --git a/deps/minirest b/deps/minirest index 17fa789b7..9a9c660f9 160000 --- a/deps/minirest +++ b/deps/minirest @@ -1 +1 @@ -Subproject commit 17fa789b71ccaf65e8c892816456c94a09a384d0 +Subproject commit 9a9c660f9c6f27f5ef75417e7fac7061dff14d78 diff --git a/doc/user-changes.md b/doc/user-changes.md index 15abbbc4a..8bcf192c8 100644 --- a/doc/user-changes.md +++ b/doc/user-changes.md @@ -6,6 +6,20 @@ stay on top of `alr` new features. ## Release `2.0-dev` +### Cancel an index submission with `alr publish --cancel` + +PR [#1406](https://github.com/alire-project/alire/pull/1406) + +A pending submission can be closed with `alr publish --cancel + --reason `. + +### Track user's index submissions with `alr publish --status` + +PR [#1400](https://github.com/alire-project/alire/pull/1400) + +The new `alr publish --status` switch will print a table with unmerged pull +requests opened by the user against the community index repository. + ### Automatic release submission during `alr publish` PR [#1398](https://github.com/alire-project/alire/pull/1398) diff --git a/src/alire/alire-github.adb b/src/alire/alire-github.adb index cb2289d2f..f76c79393 100644 --- a/src/alire/alire-github.adb +++ b/src/alire/alire-github.adb @@ -6,6 +6,10 @@ with Alire.OS_Lib; with Alire.Publish; with Alire.URI; with Alire.Utils.TTY; +with Alire.Version; + +with GNATCOLL.JSON.Utility; +with GNATCOLL.Strings; with Minirest; @@ -17,11 +21,23 @@ package body Alire.GitHub is Base_URL : constant URL := "https://api.github.com"; Header_Rate : constant String := "X-Ratelimit-Remaining"; + ----------------- + -- JSON_Escape -- + ----------------- + + function JSON_Escape (S : String) return String + is + use GNATCOLL; + X : constant Strings.XString := Strings.To_XString (S); + begin + return +GNATCOLL.JSON.Utility.Escape_String (X); + end JSON_Escape; + -------------- -- API_Call -- -------------- - type Kinds is (GET, POST); + type Kinds is new Minirest.Request_Kinds; function API_Call (Proc : String; Args : Minirest.Parameters := Minirest.No_Arguments; @@ -34,7 +50,8 @@ package body Alire.GitHub is & (if Proc (Proc'First) /= '/' then "/" else "") & Proc; Headers : Minirest.Parameters := - "Accept" = "Application/vnd.github.v3.full+json"; + "Accept" = "Application/vnd.github.v3.full+json" + and "X-GitHub-Api-Version" = "2022-11-28"; begin if Token /= "" then Headers := Headers and "Authorization" = "Bearer " & Token; @@ -43,9 +60,9 @@ package body Alire.GitHub is Trace.Debug ("GitHub API call " & Kind'Image & " to " & Full_URL); Trace.Debug - ("Headers: " & Minirest.Image (Headers)); + ("Headers: " & Minirest.Image (Headers, JSON_Escape'Access)); Trace.Debug - ("Parameters: " & Minirest.Image (Args)); + ("Parameters: " & Minirest.Image (Args, JSON_Escape'Access)); return This : constant Response := (case Kind is @@ -54,11 +71,13 @@ package body Alire.GitHub is (Full_URL, Arguments => Args, Headers => Headers), - when POST => + when POST | PATCH => Minirest.Post (Full_URL, Data => Args, - Headers => Headers)) + Headers => Headers, + Escape => JSON_Escape'Access, + Kind => Minirest.Request_Kinds (Kind))) do Trace.Debug ("GitHub API response: " & This.Status_Line); @@ -95,6 +114,36 @@ package body Alire.GitHub is Ada.Exceptions.Exception_Message (E))); end API_Call; + -------------- + -- API_Call -- + -------------- + + function API_Call (Proc : String; + Args : Minirest.Parameters := Minirest.No_Arguments; + Kind : Kinds := GET; + Token : String := OS_Lib.Getenv (Env_GH_Token, ""); + Error : String := "GitHub API call failed") + return GNATCOLL.JSON.JSON_Value + is + Response : constant Minirest.Response + := API_Call (Proc => Proc, + Args => Args, + Kind => Kind, + Token => Token); + begin + if Response.Succeeded then + return GNATCOLL.JSON.Read (Response.Content.Flatten ("")); + else + Raise_Checked_Error + (Errors.New_Wrapper + .Wrap (Error) + .Wrap ("Status line: " & Response.Status_Line) + .Wrap ("Response body:") + .Wrap (Response.Content.Flatten (ASCII.LF)) + .Get); + end if; + end API_Call; + ------------------- -- Branch_Exists -- ------------------- @@ -124,10 +173,12 @@ package body Alire.GitHub is ) return Natural is - Response : constant Minirest.Response - := API_Call + begin + return + API_Call (Kind => POST, Token => Token, + Error => "Pull request could not be created", Proc => "repos" / Base / Repo / "pulls", Args => "title" = Title @@ -135,21 +186,8 @@ package body Alire.GitHub is and "base" = Base_Branch and "head" = User & ":" & Head_Branch and "draft" = Draft - and "maintainer_can_modify" = Maintainer_Can_Modify); - begin - if not Response.Succeeded then - Raise_Checked_Error - ("Pull request could not be created: " - & Response.Status_Line & " with body " - & Response.Content.Flatten (" ")); - end if; - - declare - use GNATCOLL.JSON; - Result : constant JSON_Value := Read (Response.Content.Flatten ("")); - begin - return Result.Get ("number").Get; - end; + and "maintainer_can_modify" = Maintainer_Can_Modify) + .Get ("number").Get; end Create_Pull_Request; --------------- @@ -159,25 +197,15 @@ package body Alire.GitHub is function Get_Pulls (Args : Minirest.Parameters) return GNATCOLL.JSON.JSON_Value is - Response : constant Minirest.Response - := API_Call ("repos" - / Index.Community_Organization - / Index.Community_Repo_Name - / "pulls", - Kind => GET, - Args => Args - and "per_page" = 100); begin - if Response.Succeeded then - return GNATCOLL.JSON.Read (Response.Content.Flatten ("")); - else - Raise_Checked_Error - ("Could not get list of pull requests." - & " GitHub REST API failed with code:" - & Response.Status_Code'Image - & " and status: " - & Response.Status_Line & Response.Content.Flatten (ASCII.LF)); - end if; + return + API_Call ("repos" + / Index.Community_Organization + / Index.Community_Repo_Name + / "pulls", + Error => "Could not list pull requests", + Kind => GET, + Args => Args and "per_page" = 100); end Get_Pulls; ----------------------- @@ -190,6 +218,21 @@ package body Alire.GitHub is and "head" = User_Info.User_GitHub_Login & ":" & Publish.Branch_Name (M))); + ----------------------- + -- Find_Pull_Request -- + ----------------------- + + function Find_Pull_Request (Number : Natural) + return GNATCOLL.JSON.JSON_Value + is (API_Call + ("repos" + / Index.Community_Organization + / Index.Community_Repo_Name + / "pulls" + / AAA.Strings.Trim (Number'Image), + Error => "Could not retrieve pull request information", + Kind => GET)); + ------------------------ -- Find_Pull_Requests -- ------------------------ @@ -198,6 +241,46 @@ package body Alire.GitHub is is (Get_Pulls ("state" = "open" and "head" = User_Info.User_GitHub_Login)); + ------------- + -- Comment -- + ------------- + + procedure Comment (Number : Natural; Text : String) is + Unused : constant GNATCOLL.JSON.JSON_Value + := API_Call + ("repos" + / Index.Community_Organization + / Index.Community_Repo_Name + / "issues" + / AAA.Strings.Trim (Number'Image) + / "comments", + Kind => POST, + Args => "body" = Text); + begin + Trace.Debug ("Comment via GitHub REST API successful: " & Text); + end Comment; + + ----------- + -- Close -- + ----------- + + procedure Close (Number : Natural; Reason : String) is + use AAA.Strings; + Unused : constant GNATCOLL.JSON.JSON_Value + := API_Call ("repos" + / Index.Community_Organization + / Index.Community_Repo_Name + / "pulls" + / Trim (Number'Image), + Error => "Failed to close pull request via REST API", + Kind => PATCH, + Args => "state" = "closed"); + begin + Comment (Number, + "Closed using `alr " & Version.Current & "` with reason: " + & Reason); + end Close; + ---------- -- Fork -- ---------- @@ -215,19 +298,15 @@ package body Alire.GitHub is Start : constant Time := Clock; Next : Time := Start + 1.0; - Response : constant Minirest.Response + Unused : constant GNATCOLL.JSON.JSON_Value := API_Call ("repos" / Owner / Repo / "forks", Kind => POST, - Token => Token); + Token => Token, + Error => + "Attempt to fork repo [" & Repo & "] owned by [" + & Owner & "] via " & "GitHub REST API failed" + ); begin - if not Response.Succeeded then - Raise_Checked_Error - ("Attempt to fork repo [" & Repo & "] owned by [" & Owner & "] via " - & "GitHub REST API failed with code:" - & Response.Status_Code'Image & " and status: " - & Response.Status_Line & Response.Content.Flatten (ASCII.LF)); - end if; - declare Wait : Trace.Ongoing := Trace.Activity ("Waiting for GitHub"); begin diff --git a/src/alire/alire-github.ads b/src/alire/alire-github.ads index 7764c4428..d9c34eb8e 100644 --- a/src/alire/alire-github.ads +++ b/src/alire/alire-github.ads @@ -45,9 +45,20 @@ package Alire.GitHub is -- JSON info. It will return the unique open PR, or the most recent closed -- one. + function Find_Pull_Request (Number : Natural) + return GNATCOLL.JSON.JSON_Value; + -- Find the PR with the given number, in any state + function Find_Pull_Requests return GNATCOLL.JSON.JSON_Value; -- Return open pull requests created by the user + procedure Comment (Number : Natural; Text : String); + -- Add a comment to an issue/pull request. Use plain text or markdown. + + procedure Close (Number : Natural; Reason : String); + -- Close an issue/pull request and add a comment giving the reason. The + -- comment is added after the closure. + function Fork (User : String := User_Info.User_GitHub_Login; Owner : String; diff --git a/src/alire/alire-publish-states.adb b/src/alire/alire-publish-states.adb index 3f5067f02..ec4d15ec1 100644 --- a/src/alire/alire-publish-states.adb +++ b/src/alire/alire-publish-states.adb @@ -4,6 +4,8 @@ with Alire.URI; with Alire.Utils.Tables; with Alire.Utils.User_Input.Query_Config; +with CLIC.User_Input; + with GNATCOLL.JSON; package body Alire.Publish.States is @@ -37,6 +39,7 @@ package body Alire.Publish.States is Label : constant String := "label"; Number : constant String := "number"; State : constant String := "state"; + Title : constant String := "title"; end Key; package Val is @@ -50,9 +53,14 @@ package body Alire.Publish.States is function To_Status (Info : GNATCOLL.JSON.JSON_Value) return PR_Status is begin + if Info.Is_Empty then + return (Exists => False); + end if; + return (Exists => True, Branch => +Info.Get (Key.Head).Get (Key.Label), + Title => +Info.Get (Key.Title), Number => Info.Get (Key.Number), Status => (if Info.Get (Key.State) = Val.Open then Open @@ -158,4 +166,54 @@ package body Alire.Publish.States is Table.Print (Always); end Print_Status; + ------------ + -- Cancel -- + ------------ + + procedure Cancel (PR : Natural; Reason : String) is + use Simple_Logging; + Busy : constant Ongoing := Activity ("Checking PR status") + with Unreferenced; + + Status : constant PR_Status + := To_Status (GitHub.Find_Pull_Request (PR)); + + --------------- + -- Fail_With -- + --------------- + + procedure Fail_With (Reason : String) is + begin + Raise_Checked_Error + ("Requested pull request" & TTY.Emph (PR'Image) & " " & Reason); + end Fail_With; + + Busy_Closing : constant Ongoing := Activity ("Closing") + with Unreferenced; + + use CLIC.User_Input; + begin + if not Status.Exists then + Fail_With ("does not exist"); + end if; + + if not Status.Is_Open then + Fail_With ("is already closed"); + end if; + + Trace.Info (""); -- New line required after busy spinner + + if Query ("Are you sure that you want to close PR" + & PR'Image & " (" & (+Status.Title) & ") " + & "giving as reason: """ & Reason & """?", + (Yes | No => True, others => False), Yes) = Yes + then + GitHub.Close (PR, Reason); + Put_Success ("Pull request" & TTY.Emph (PR'Image) + & " closed successfully"); + else + Put_Warning ("Operation abandoned", Info); + end if; + end Cancel; + end Alire.Publish.States; diff --git a/src/alire/alire-publish-states.ads b/src/alire/alire-publish-states.ads index 1b815e35b..1bd5d83b1 100644 --- a/src/alire/alire-publish-states.ads +++ b/src/alire/alire-publish-states.ads @@ -14,6 +14,7 @@ package Alire.Publish.States is when True => Branch : UString; -- In truth, it's `user:branch` Number : Natural := 0; + Title : UString; Status : Life_States := Open; Checks : Check_States := Pending; end case; @@ -41,4 +42,6 @@ package Alire.Publish.States is procedure Print_Status; + procedure Cancel (PR : Natural; Reason : String); + end Alire.Publish.States; diff --git a/src/alr/alr-commands-publish.adb b/src/alr/alr-commands-publish.adb index 938b85475..19740863e 100644 --- a/src/alr/alr-commands-publish.adb +++ b/src/alr/alr-commands-publish.adb @@ -7,6 +7,14 @@ package body Alr.Commands.Publish is package URI renames Alire.URI; + function To_Int (S : String) return Integer is + begin + return Integer'Value (S); + exception + when others => + Alire.Raise_Checked_Error ("Not a valid integer: " & S); + end To_Int; + ------------- -- Execute -- ------------- @@ -30,7 +38,9 @@ package body Alr.Commands.Publish is begin if Alire.Utils.Count_True - ((Cmd.Tar, Cmd.Print_Trusted, Cmd.Status)) > 1 or else + ((Cmd.Tar, Cmd.Print_Trusted, Cmd.Status, + Cmd.Cancel.all /= Unset)) > 1 + or else (Cmd.Manifest.all /= "" and then Cmd.Print_Trusted) then Reportaise_Wrong_Arguments @@ -53,6 +63,25 @@ package body Alr.Commands.Publish is Revision => (if Args.Count >= 2 then Args (2) else "HEAD"), Options => Options); + elsif Cmd.Cancel.all /= Unset then + if Cmd.Cancel.all = "" then + Reportaise_Wrong_Arguments + ("--cancel requires one pull request number"); + end if; + + if Cmd.Reason.all in "" | "unset" then + Reportaise_Wrong_Arguments + ("--cancel requires a --reason"); + end if; + + if not Args.Is_Empty then + Reportaise_Wrong_Arguments + ("Unexpected argumets; verify --reason text is quoted"); + end if; + + Alire.Publish.States.Cancel (PR => To_Int (Cmd.Cancel.all), + Reason => Cmd.Reason.all); + elsif Cmd.Status then Alire.Publish.States.Print_Status; @@ -127,6 +156,20 @@ package body Alr.Commands.Publish is "", "--skip-submit", "Do not create the online pull request onto the community index"); + Define_Switch + (Config, + Cmd.Cancel'Access, + "", "--cancel=", + "Prematurely close a pull request without waiting for the merge", + Argument => "NUM"); + + Define_Switch + (Config, + Cmd.Reason'Access, + "", "--reason=", + "Give a message for the record on why the PR is being closed", + Argument => "'short text'"); + Define_Switch (Config, Cmd.Status'Access, diff --git a/src/alr/alr-commands-publish.ads b/src/alr/alr-commands-publish.ads index cade7ad19..6bf6a8bb6 100644 --- a/src/alr/alr-commands-publish.ads +++ b/src/alr/alr-commands-publish.ads @@ -68,6 +68,12 @@ private Skip_Submit : aliased Boolean := False; -- Stop after generation instead of asking the user to continue + Cancel : aliased GNAT.Strings.String_Access := new String'(Unset); + -- Number of a PR to prematurely close + + Reason : aliased GNAT.Strings.String_Access := new String'(Unset); + -- Reason to give when closing the PR + Status : aliased Boolean := False; -- Retrieve the status of PRs opened by the user diff --git a/src/alr/alr-commands.ads b/src/alr/alr-commands.ads index a1f3bf5cc..4f65c4bd7 100644 --- a/src/alr/alr-commands.ads +++ b/src/alr/alr-commands.ads @@ -147,7 +147,6 @@ private TTY_Emph => Alire.TTY.Emph); Unset : constant String := "unset"; - -- Canary for text switches that can be both ungiven, given without value, - -- and given with value. + -- Canary for when a string switch is given without value end Alr.Commands;