From 5c17abb0dc6ed48158ebd51750761317063b5ccd Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Mon, 3 Jul 2023 20:39:13 +0200 Subject: [PATCH] Improvements to publishing with automatic PR creation (#1398) * Added --submit switch to `alr publish` * Forking of community index * Changes up to pushing the manifest * PR creation * Reshaped as steps of the assistant * Use release-specific branch * Report PR webpage after creation * Detect existing conflicting PR * Minor tweaks (draft mode, texts, busy spinners) * Documentation * Allow overriding of community index info This will allow our testing and help maintainers of other indexes * Fix temp dir being not absolute * Fixes for self-build with `alr build` * Fixes for Windows temp file specifics * Document all steps more thoroughly Also use a better name for the new child package. * Make submission the default after user confirmation Document this change in behavior and the new `--skip-submit` switch that restores the former behavior. * Default to submit, and add switch not to submit --- alire.toml | 3 +- deps/minirest | 2 +- doc/publishing.md | 16 + doc/user-changes.md | 20 +- src/alire/alire-config-edit.ads | 15 + src/alire/alire-config.ads | 10 + src/alire/alire-directories.adb | 68 +++- src/alire/alire-directories.ads | 15 + src/alire/alire-environment.ads | 3 + src/alire/alire-github.adb | 196 +++++++-- src/alire/alire-github.ads | 58 ++- src/alire/alire-index.ads | 11 +- src/alire/alire-os_lib-subprocess.adb | 34 +- src/alire/alire-paths.ads | 2 + src/alire/alire-platforms-common.ads | 9 + src/alire/alire-platforms-folders.ads | 4 + src/alire/alire-publish-states.adb | 78 ++++ src/alire/alire-publish-states.ads | 33 ++ src/alire/alire-publish-submit.adb | 382 ++++++++++++++++++ src/alire/alire-publish-submit.ads | 54 +++ src/alire/alire-publish.adb | 130 ++++-- src/alire/alire-publish.ads | 72 +++- src/alire/alire-uri.adb | 11 + src/alire/alire-uri.ads | 7 + src/alire/alire-vcss-git.adb | 196 ++++++++- src/alire/alire-vcss-git.ads | 51 +++ src/alire/alire.adb | 17 + src/alire/alire.ads | 3 + .../alire-platforms-folders__freebsd.adb | 9 + .../alire-platforms-folders__linux.adb | 9 + .../alire-platforms-folders__macos.adb | 9 + .../alire-platforms-folders__windows.adb | 11 + src/alr/alr-commands-publish.adb | 11 +- src/alr/alr-commands-publish.ads | 6 +- testsuite/drivers/alr.py | 19 +- testsuite/run.py | 6 + .../tests/monorepo/subdir-in-tar/test.py | 6 +- .../tests/publish/check-properties/test.py | 4 +- testsuite/tests/publish/check-trusted/test.py | 2 + .../tests/publish/local-repo-branched/test.py | 2 +- .../tests/publish/local-repo-nonstd/test.py | 10 +- testsuite/tests/publish/local-repo/test.py | 12 +- testsuite/tests/publish/pin-removal/test.py | 2 +- .../publish/remote-origin-nonstd/test.py | 4 +- testsuite/tests/publish/remote-origin/test.py | 4 +- .../publish/tarball-plaindir-nonstd/test.py | 2 +- .../tests/publish/tarball-plaindir/test.py | 2 +- .../tests/publish/tarball-repo-nonstd/test.py | 2 +- testsuite/tests/publish/tarball-repo/test.py | 2 +- 49 files changed, 1486 insertions(+), 148 deletions(-) create mode 100644 src/alire/alire-publish-states.adb create mode 100644 src/alire/alire-publish-states.ads create mode 100644 src/alire/alire-publish-submit.adb create mode 100644 src/alire/alire-publish-submit.ads diff --git a/alire.toml b/alire.toml index 84a85a42..a84eca86 100644 --- a/alire.toml +++ b/alire.toml @@ -21,7 +21,7 @@ ajunitgen = "^1.0.1" ansiada = "^1.0" clic = "~0.3" gnatcoll = "^21" -minirest = "~0.2" +minirest = "~0.3" optional = "~0.1" semantic_versioning = "^3.0" simple_logging = "^2.0" @@ -49,6 +49,7 @@ aaa = { url = "https://github.com/mosteo/aaa", commit = "f60254934a7d6e39b72380b ada_toml = { url = "https://github.com/mosteo/ada-toml", commit = "da4e59c382ceb0de6733d571ecbab7ea4919b33d" } clic = { url = "https://github.com/alire-project/clic", commit = "8d26222de71014554999e48c821906fca0e3dc41" } gnatcoll = { url = "https://github.com/alire-project/gnatcoll-core.git", commit = "403efe11405113cf12ae3d014df474cf7a046176" } +minirest = { url = "https://github.com/mosteo/minirest.git", commit = "9045d8faafcea996fa7b51ccda84c54712eff821" } 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/minirest b/deps/minirest index a50d0f7c..9045d8fa 160000 --- a/deps/minirest +++ b/deps/minirest @@ -1 +1 @@ -Subproject commit a50d0f7cc1c546b9dd61bc3dd3004e4b953fb9f2 +Subproject commit 9045d8faafcea996fa7b51ccda84c54712eff821 diff --git a/doc/publishing.md b/doc/publishing.md index e981da3c..1a941f56 100644 --- a/doc/publishing.md +++ b/doc/publishing.md @@ -5,6 +5,22 @@ command. The steps to take are described after some introductory concepts (jump to these steps directly [here](#detailed-steps); you can also ask for help on the [gitter channel](https://gitter.im/ada-lang/Alire) of the project. +## Automated publishing (TL;DR.) + +The simplest publishing experience, provided you have a GitHub account and +Personal Access Token, consist on issuing +``` +alr publish --submit +``` +at the root of your workspace, when said workspace is an up-to-date clone of a +git repository. + +The publishing assistant will review your submission, point out any necessary +fixes or additional information required, and provide you with a tracking URL. + +Read on for the details underlying these automated steps, or in case you need +to perform further tweaking. + ## General concepts The community index is a collection of diff --git a/doc/user-changes.md b/doc/user-changes.md index b7b92b43..15abbbc4 100644 --- a/doc/user-changes.md +++ b/doc/user-changes.md @@ -6,6 +6,24 @@ stay on top of `alr` new features. ## Release `2.0-dev` +### Automatic release submission during `alr publish` + +PR [#1398](https://github.com/alire-project/alire/pull/1398) + +`alr publish` will now prompt to continue after manifest creation into a series +of steps culminating on the creation of a draft pull request on the community +index repository. + +The new steps will perform all necessary actions: forking of the community +repository into the user account, cloning, committing of the new manifest, and +pull request creation. + +For `alr` to be able to do these steps on the user's behalf, the user has to +provide a 'Personal Access Token (PAT)' with 'repo' permissions. + +The old behavior, ending the assistant after manifest creation, can be achieved +with the new `--skip-submit` flag. + ### Removal of `alr test --docker` PR [#1366](https://github.com/alire-project/alire/pull/1366) @@ -58,7 +76,7 @@ manually move the contents to avoid redownloading toolchains. ### Installation of indexed crates -PR [#1322](https://github.com/alire-project/alire/pull/1335) +PR [#1335](https://github.com/alire-project/alire/pull/1335) It is now possible to install an indexed crate directly: ``` diff --git a/src/alire/alire-config-edit.ads b/src/alire/alire-config-edit.ads index f8768f25..a34aa12e 100644 --- a/src/alire/alire-config-edit.ads +++ b/src/alire/alire-config-edit.ads @@ -137,6 +137,21 @@ private " character. The token ${GPR_FILE} is replaced by" & " a path to the project file to open.")), + (+Keys.Index_Host, + Cfg_String, + +("URL of the community index host, defaults to " + & Defaults.Index_Host)), + + (+Keys.Index_Owner, + Cfg_String, + +("Owner of the index repository (GitHub user/org), defaults to " + & Defaults.Index_Owner)), + + (+Keys.Index_Repo_Name, + Cfg_String, + +("Name of the index repository, defaults to " + & Defaults.Index_Repo_Name)), + (+Keys.Msys2_Do_Not_Install, Cfg_Bool, +("If true, Alire will not try to automatically" & diff --git a/src/alire/alire-config.ads b/src/alire/alire-config.ads index ff38ec52..b650e3ad 100644 --- a/src/alire/alire-config.ads +++ b/src/alire/alire-config.ads @@ -36,6 +36,12 @@ package Alire.Config with Preelaborate is -- When unset (default) or true, add the community index if no other -- index is already configured. + Index_Host : constant Config_Key := "index.host"; + Index_Owner : constant Config_Key := "index.owner"; + Index_Repo_Name : constant Config_Key := "index.repository_name"; + -- These three conform the URL where the community index is hosted, + -- allowing to override the default. + Solver_Autonarrow : constant Config_Key := "solver.autonarrow"; -- When true, `alr with` will substitute "any" dependencies by the -- appropriate caret/tilde. @@ -84,6 +90,10 @@ package Alire.Config with Preelaborate is Warning_Old_Index : constant Boolean := True; + Index_Host : constant String := "https://github.com"; + Index_Owner : constant String := "alire-project"; + Index_Repo_Name : constant String := "alire-index"; + end Defaults; end Alire.Config; diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index 5eacd149..ef116c38 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -4,10 +4,10 @@ with Ada.Exceptions; with Ada.Numerics.Discrete_Random; with Ada.Unchecked_Deallocation; -with Alire.Errors; with Alire.OS_Lib.Subprocess; with Alire.Paths; with Alire.Platforms.Current; +with Alire.Platforms.Folders; with Alire.VFS; with GNATCOLL.VFS; @@ -16,8 +16,6 @@ with SI_Units.Binary; package body Alire.Directories is - package Adirs renames Ada.Directories; - ------------------- -- Temp_Registry -- ------------------- @@ -212,18 +210,26 @@ package body Alire.Directories is procedure Ensure_Deletable (Path : Any_Path) is use Ada.Directories; begin - if Exists (Path) and then - Kind (Path) = Directory and then - Platforms.Current.Operating_System in Platforms.Windows + if Platforms.Current.Operating_System in Platforms.Windows + and then Exists (Path) 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 & "\*")); + 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; end if; end Ensure_Deletable; @@ -407,6 +413,13 @@ package body Alire.Directories is function Is_Directory (Path : Any_Path) return Boolean is (Adirs.Exists (Path) and then Adirs.Kind (Path) in Adirs.Directory); + ------------- + -- Is_File -- + ------------- + + function Is_File (Path : Any_Path) return Boolean + is (Adirs.Exists (Path) and then Adirs.Kind (Path) in Adirs.Ordinary_File); + ---------------- -- TEMP FILES -- ---------------- @@ -461,13 +474,32 @@ package body Alire.Directories is else - This.Name := +Ada.Directories.Full_Name (Simple_Name); + -- Default to the system temp folder. Note that spawns that capture + -- output may fail if the temp folder is unset (e.g., git commands + -- that clean the current repository). + + This.Name := +Ada.Directories.Full_Name (Platforms.Folders.Temp + / Simple_Name); end if; Temp_Registry.Add (+This.Name); end Initialize; + ------------ + -- Create -- + ------------ + + function Create (This : in out Temp_File) return GNAT.OS_Lib.File_Descriptor + is + begin + if This.FD in GNAT.OS_Lib.Invalid_FD then + This.FD := GNAT.OS_Lib.Create_Output_Text_File (This.Filename); + end if; + + return This.FD; + end Create; + -------------- -- Filename -- -------------- @@ -500,6 +532,11 @@ package body Alire.Directories is -- We are deleting it here, so remove from "live" temp files registry Temp_Registry.Del (+This.Name); + -- Close it first, if created and opened by us + if This.FD not in GNAT.OS_Lib.Invalid_FD then + GNAT.OS_Lib.Close (This.FD); + end if; + -- Force writability of folder when in Windows, as some tools (e.g. git) -- that create read-only files will cause a Use_Error @@ -909,6 +946,7 @@ package body Alire.Directories is return Temp : constant Temp_File := (Temp_File'(Ada.Finalization.Limited_Controlled with Keep => <>, + FD => <>, Name => +Adirs.Full_Name (Name))) do Temp_Registry.Add (+Temp.Name); diff --git a/src/alire/alire-directories.ads b/src/alire/alire-directories.ads index 7534bfc0..aa3578e4 100644 --- a/src/alire/alire-directories.ads +++ b/src/alire/alire-directories.ads @@ -2,12 +2,17 @@ with Ada.Directories; with AAA.Strings; +with Alire.Errors; with Alire.OS_Lib; private with Ada.Finalization; +with GNAT.OS_Lib; + package Alire.Directories is + package Adirs renames Ada.Directories; + function "/" (L, R : String) return String renames OS_Lib."/"; -- Package to enable easy use of "/" @@ -78,6 +83,9 @@ package Alire.Directories is function Is_Directory (Path : Any_Path) return Boolean; -- Returns false for non-existing paths too + function Is_File (Path : Any_Path) return Boolean; + -- False if Path does not designate a regular file + procedure Merge_Contents (Src, Dst : Any_Path; Skip_Top_Level_Files : Boolean; Fail_On_Existing_File : Boolean; @@ -164,6 +172,12 @@ package Alire.Directories is -- The file is deleted once an object of this type goes out of scope. -- If the file/folder was never created on disk nothing will happen. + function Create (This : in out Temp_File) return GNAT.OS_Lib.File_Descriptor + with Post => Create'Result not in GNAT.OS_Lib.Invalid_FD + or else raise Checked_Error + with Errors.Set ("Could not create temporary file at " & This.Filename); + -- Actually creates the file and returns its file descriptor. Idempotent. + function Filename (This : Temp_File) return Absolute_Path; -- The filename is a random sequence of 8 characters + ".tmp" @@ -230,6 +244,7 @@ private type Temp_File is new Ada.Finalization.Limited_Controlled with record Keep : Boolean := False; Name : Unbounded_Absolute_Path; + FD : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; end record; overriding diff --git a/src/alire/alire-environment.ads b/src/alire/alire-environment.ads index 6114cebe..48568082 100644 --- a/src/alire/alire-environment.ads +++ b/src/alire/alire-environment.ads @@ -15,6 +15,9 @@ package Alire.Environment is Config : constant String := "ALR_CONFIG"; -- Folder where current alr will look for configuration + Testsuite : constant String := "ALR_TESTSUITE"; + -- If defined, we are running under the testsuite harness + type Context is tagged limited private; procedure Set (This : in out Context; Name, Value, Origin : String); diff --git a/src/alire/alire-github.adb b/src/alire/alire-github.adb index 55f05ee5..8a96e919 100644 --- a/src/alire/alire-github.adb +++ b/src/alire/alire-github.adb @@ -1,27 +1,31 @@ +with Ada.Calendar; with Ada.Exceptions; with Alire.Errors; +with Alire.OS_Lib; +with Alire.Publish; +with Alire.URI; with Alire.Utils.TTY; with Minirest; package body Alire.GitHub is + use URI.Operators; + Base_URL : constant URL := "https://api.github.com"; Header_Rate : constant String := "X-Ratelimit-Remaining"; - --------- - -- "/" -- - --------- - - function "/" (L, R : String) return String is (L & "/" & R); - -------------- -- API_Call -- -------------- - function API_Call (Proc : String; - Args : Minirest.Parameters := Minirest.No_Arguments) + type Kinds is (GET, POST); + + function API_Call (Proc : String; + Args : Minirest.Parameters := Minirest.No_Arguments; + Kind : Kinds := GET; + Token : String := OS_Lib.Getenv (Env_GH_Token, "")) return Minirest.Response is use Minirest; @@ -29,29 +33,51 @@ package body Alire.GitHub is Base_URL & (if Proc (Proc'First) /= '/' then "/" else "") & Proc; + Headers : Minirest.Parameters := + "Accept" = "Application/vnd.github.v3.full+json"; begin + if Token /= "" then + Headers := Headers and "Authorization" = "Bearer " & Token; + end if; + + Trace.Debug + ("GitHub API call " & Kind'Image & " to " & Full_URL); + Trace.Debug + ("Headers: " & Minirest.Image (Headers)); + Trace.Debug + ("Parameters: " & Minirest.Image (Args)); + return This : constant Response := - Minirest.Get - (Full_URL, - Arguments => Args, - Headers => "Accept" = "Application/vnd.github.v3.full+json") + (case Kind is + when GET => + Minirest.Get + (Full_URL, + Arguments => Args, + Headers => Headers), + when POST => + Minirest.Post + (Full_URL, + Data => Args, + Headers => Headers)) do + Trace.Debug + ("GitHub API response: " & This.Status_Line); + Trace.Debug + ("Headers: " & This.Raw_Headers.Flatten (ASCII.LF)); + Trace.Debug + ("Data: " & This.Content.Flatten (ASCII.LF)); + if not This.Succeeded then -- Log info about why the API call failed Trace.Debug ("Failed GitHub request to API: " & Utils.TTY.URL (Full_URL)); - Trace.Debug ("Status: " & This.Status_Line); - Trace.Debug ("Headers: " - & This.Raw_Headers.Flatten ((1 => ASCII.LF))); - Trace.Debug ("Contents: " - & This.Content.Flatten ((1 => ASCII.LF))); -- Raise if API is rate-limiting to avoid misleading failures if This.Headers.Contains (Header_Rate) and then - Integer'Value (This.Headers (Header_Rate)) <= 0 + Integer'Value (This.Headers.Get (Header_Rate)) <= 0 then Raise_Checked_Error ("GitHub API rate limit exceeded, please wait for a while" @@ -74,20 +100,143 @@ package body Alire.GitHub is ------------------- function Branch_Exists - (User : String := Config.DB.Get (Config.Keys.User_Github_Login, - Default => ""); + (User : String := User_Info.User_GitHub_Login; Repo : String := Index.Community_Repo_Name; Branch : String := Index.Community_Branch) return Boolean is (API_Call ("repos" / User / Repo / "branches" / Branch).Succeeded); + ------------------------- + -- Create_Pull_Request -- + ------------------------- + + function Create_Pull_Request + (User : String := User_Info.User_GitHub_Login; + Base : String := Index.Community_Organization; + Repo : String := Index.Community_Repo_Name; + Head_Branch : String := Index.Community_Branch; + Base_Branch : String := Index.Community_Branch; + Draft : Boolean := False; + Maintainer_Can_Modify : Boolean := True; + Token : String; + Title : String; + Message : String -- What goes in the body of the PR + ) + return Natural + is + use all type Minirest.Parameters; + Response : constant Minirest.Response + := API_Call + (Kind => POST, + Token => Token, + Proc => "repos" / Base / Repo / "pulls", + Args => + "title" = Title + and "body" = Message + 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; + end Create_Pull_Request; + + ----------------------- + -- Find_Pull_Request -- + ----------------------- + + function Find_Pull_Request (M : Milestones.Milestone) + return GNATCOLL.JSON.JSON_Value + is + use all type Minirest.Parameters; + + Response : constant Minirest.Response + := API_Call ("repos" + / Index.Community_Organization + / Index.Community_Repo_Name + / "pulls", + Kind => GET, + Args => + "state" = "all" + and "head" = User_Info.User_GitHub_Login & ":" + & Publish.Branch_Name (M)); + 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; + end Find_Pull_Request; + + ---------- + -- Fork -- + ---------- + + function Fork + (User : String := User_Info.User_GitHub_Login; + Owner : String; + Repo : String; + Token : String; + Timeout : Duration := 10.0) + return Async_Result + is + use Ada.Calendar; + + Start : constant Time := Clock; + Next : Time := Start + 1.0; + + Response : constant Minirest.Response + := API_Call ("repos" / Owner / Repo / "forks", + Kind => POST, + Token => Token); + 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 + while Clock - Start < Timeout loop + delay until Next; + Next := Next + 1.0; + Wait.Step; + if Repo_Exists (User, Repo) then + return Completed; + end if; + end loop; + end; + + return Pending; + end Fork; + ----------------- -- Repo_Exists -- ----------------- function Repo_Exists - (User : String := Config.DB.Get (Config.Keys.User_Github_Login, - Default => ""); + (User : String := User_Info.User_GitHub_Login; Repo : String := Index.Community_Repo_Name) return Boolean is (API_Call ("repos" / User / Repo).Succeeded); @@ -97,8 +246,7 @@ package body Alire.GitHub is ----------------- function User_Exists - (User : String := Config.DB.Get (Config.Keys.User_Github_Login, - Default => "")) + (User : String := User_Info.User_GitHub_Login) return Boolean is (API_Call ("users" / User).Succeeded); diff --git a/src/alire/alire-github.ads b/src/alire/alire-github.ads index 2653213f..eb53fd9f 100644 --- a/src/alire/alire-github.ads +++ b/src/alire/alire-github.ads @@ -1,26 +1,70 @@ -with Alire.Config; with Alire.Index; +with Alire.Milestones; +with Alire.Utils.User_Input.Query_Config; + +with GNATCOLL.JSON; package Alire.GitHub is + Env_GH_Token : constant String := "GH_TOKEN"; + -- This is the environment variable used by the `gh` tool to look for the + -- user token. We can reuse it so if it's available, we need not pester the + -- user for it. + + URL_Tokens : constant String := "https://github.com/settings/tokens"; + -- URL in which Personal Access Tokens (PATs) can be created + + package User_Info renames Alire.Utils.User_Input.Query_Config; + + type Async_Result is (Completed, Pending); + function Branch_Exists - (User : String := Config.DB.Get (Config.Keys.User_Github_Login, - Default => ""); + (User : String := User_Info.User_GitHub_Login; Repo : String := Index.Community_Repo_Name; Branch : String := Index.Community_Branch) return Boolean; -- Check that a branch exists in a user's repository + function Create_Pull_Request + (User : String := User_Info.User_GitHub_Login; + Base : String := Index.Community_Organization; + Repo : String := Index.Community_Repo_Name; + Head_Branch : String := Index.Community_Branch; + Base_Branch : String := Index.Community_Branch; + Draft : Boolean := False; + Maintainer_Can_Modify : Boolean := True; + Token : String; + Title : String; + Message : String -- What goes in the body of the PR + ) return Natural; + -- Returns the number of the PR just created + + function Find_Pull_Request (M : Milestones.Milestone) + return GNATCOLL.JSON.JSON_Value; + -- Find a pull request that matches the user and branch, and return the raw + -- JSON info. It will return the unique open PR, or the most recent closed + -- one. + + function Fork + (User : String := User_Info.User_GitHub_Login; + Owner : String; + Repo : String; + Token : String; + Timeout : Duration := 10.0) return Async_Result; + -- User is the one into which the fork will appear; Owner is the one we are + -- forking Repo from. Forks are done in the background after the request is + -- accepted, so we have to busy wait for it to become available. If Timeout + -- elapses without succeeding, it will return Pending. It'll only raise if + -- the initial request is denied. + function Repo_Exists - (User : String := Config.DB.Get (Config.Keys.User_Github_Login, - Default => ""); + (User : String := User_Info.User_GitHub_Login; Repo : String := Index.Community_Repo_Name) return Boolean; -- Check that a user has a certain public repo function User_Exists - (User : String := Config.DB.Get (Config.Keys.User_Github_Login, - Default => "")) + (User : String := User_Info.User_GitHub_Login) return Boolean; -- Check that a user exists in GitHub diff --git a/src/alire/alire-index.ads b/src/alire/alire-index.ads index 49d8da98..753b6962 100644 --- a/src/alire/alire-index.ads +++ b/src/alire/alire-index.ads @@ -1,6 +1,7 @@ private with Alire_Early_Elaboration; pragma Unreferenced (Alire_Early_Elaboration); +with Alire.Config; pragma Unreferenced (Alire.Config); with Alire.Crates.Containers; with Alire.Dependencies; with Alire.Origins; @@ -13,11 +14,15 @@ with Semantic_Versioning.Extended; package Alire.Index is - Community_Host : constant String := "https://github.com"; + Community_Host : constant String + := Config.DB.Get (Config.Keys.Index_Host, Config.Defaults.Index_Host); - Community_Organization : constant String := "alire-project"; + Community_Organization : constant String + := Config.DB.Get (Config.Keys.Index_Owner, Config.Defaults.Index_Owner); - Community_Repo_Name : constant String := "alire-index"; + Community_Repo_Name : constant String + := Config.DB.Get (Config.Keys.Index_Repo_Name, + Config.Defaults.Index_Repo_Name); Community_Repo : constant URL := "git+" & Community_Host diff --git a/src/alire/alire-os_lib-subprocess.adb b/src/alire/alire-os_lib-subprocess.adb index 81eb3895..efc4b94b 100644 --- a/src/alire/alire-os_lib-subprocess.adb +++ b/src/alire/alire-os_lib-subprocess.adb @@ -1,5 +1,7 @@ with Ada.Text_IO; +with Alire.Directories; + with AnsiAda; use AnsiAda; with CLIC.TTY; @@ -228,8 +230,6 @@ package body Alire.OS_Lib.Subprocess is return Integer is use GNAT.OS_Lib; - File : File_Descriptor; - Name : String_Access; Extra : constant AAA.Strings.Vector := (if Understands_Verbose then Empty_Vector & "-v" else Empty_Vector); @@ -238,7 +238,8 @@ package body Alire.OS_Lib.Subprocess is Arg_List : Argument_List_Access := To_Argument_List (Full_Args); use Ada.Text_IO; - Outfile : File_Type; + + Outfile : Directories.Temp_File; Exit_Code : Integer; @@ -247,15 +248,7 @@ package body Alire.OS_Lib.Subprocess is ------------- procedure Cleanup is - Ok : Boolean; begin - Delete_File (Name.all, Ok); - if not Ok then - Trace.Error ("Failed to delete tmp file: " & Name.all); - end if; - - Free (Name); - Cleanup (Arg_List); end Cleanup; @@ -264,22 +257,18 @@ package body Alire.OS_Lib.Subprocess is ----------------- procedure Read_Output is + File : File_Type; begin - Open (Outfile, In_File, Name.all); - while not End_Of_File (Outfile) loop - Output.Append (Get_Line (Outfile)); + Open (File, In_File, Outfile.Filename); + while not End_Of_File (File) loop + Output.Append (Get_Line (File)); end loop; - Close (Outfile); + Close (File); end Read_Output; begin - Create_Temp_Output_File (File, Name); - if Name = null then - Raise_Checked_Error ("Cannot create temporary file"); - end if; - Trace.Detail ("Spawning: " & Image (Command, Full_Args) & - " > " & Name.all); + " > " & Outfile.Filename); -- Prepare arguments for I in Arg_List'Range loop @@ -288,11 +277,10 @@ package body Alire.OS_Lib.Subprocess is Spawn (Program_Name => Locate_In_Path (Command), Args => Arg_List.all, - Output_File_Descriptor => File, + Output_File_Descriptor => Outfile.Create, Return_Code => Exit_Code, Err_To_Out => Err_To_Out); - Close (File); -- Can't raise Read_Output; if Exit_Code /= 0 then diff --git a/src/alire/alire-paths.ads b/src/alire/alire-paths.ads index 17dcf8d6..e9a8b96d 100644 --- a/src/alire/alire-paths.ads +++ b/src/alire/alire-paths.ads @@ -9,6 +9,8 @@ package Alire.Paths with Preelaborate is Deps_Folder_Inside_Cache_Folder : constant Relative_Path := "dependencies"; + Release_Folder_Inside_Working_Folder : constant Relative_Path := "releases"; + Temp_Folder_Inside_Working_Folder : constant Relative_Path := "tmp"; Working_Folder_Inside_Root : constant Relative_Path := "alire"; diff --git a/src/alire/alire-platforms-common.ads b/src/alire/alire-platforms-common.ads index 6b544ebb..d79ed58a 100644 --- a/src/alire/alire-platforms-common.ads +++ b/src/alire/alire-platforms-common.ads @@ -22,6 +22,15 @@ private package Alire.Platforms.Common is function Unix_Home_Folder return String is (OS_Lib.Getenv ("HOME", Default => "/tmp")); + ---------------------- + -- Unix_Temp_Folder -- + ---------------------- + + function Unix_Temp_Folder return String + is (OS_Lib.Getenv ("XDG_RUNTIME_DIR", + Default => OS_Lib.Getenv ("TMPDIR", + Default => "."))); + ---------------------- -- XDG_Cache_Folder -- ---------------------- diff --git a/src/alire/alire-platforms-folders.ads b/src/alire/alire-platforms-folders.ads index e2613af3..ab8bcb20 100644 --- a/src/alire/alire-platforms-folders.ads +++ b/src/alire/alire-platforms-folders.ads @@ -18,4 +18,8 @@ package Alire.Platforms.Folders is function Home return Absolute_Path; -- $HOME (Linux/macOS) or $UserProfile (Windows) + function Temp return Absolute_Path; + -- $XDG_RUNTIME_DIR or else $TMPDIR or else . on Linux, + -- $TEMP or $TMP or . on Windows + end Alire.Platforms.Folders; diff --git a/src/alire/alire-publish-states.adb b/src/alire/alire-publish-states.adb new file mode 100644 index 00000000..de86953e --- /dev/null +++ b/src/alire/alire-publish-states.adb @@ -0,0 +1,78 @@ +with Alire.GitHub; +with Alire.Index; +with Alire.URI; + +with GNATCOLL.JSON; + +package body Alire.Publish.States is + + use URI.Operators; + + ------------- + -- Webpage -- + ------------- + + function Webpage (PR : Natural) return URL + is (Index.Community_Host + / Index.Community_Organization + / Index.Community_Repo_Name + / "pull" + / AAA.Strings.Trim (PR'Image)); + + ------------- + -- Webpage -- + ------------- + + function Webpage (PR : PR_Status) return URL + is (Webpage (PR.Number)); + + ----------------------- + -- Find_Pull_Request -- + ----------------------- + + function Find_Pull_Request (M : Milestones.Milestone) return PR_Status + is + use GNATCOLL.JSON; + Result : constant JSON_Value := GitHub.Find_Pull_Request (M); + List : constant JSON_Array := Result.Get; + Target : JSON_Value := JSON_Null; + + Key_Number : constant String := "number"; + Key_State : constant String := "state"; + Val_Open : constant String := "open"; + begin + for I in 1 .. Length (List) loop + declare + Obj : constant JSON_Value := Get (List, I); + begin + -- Keep the first one we see + if Obj.Get (Key_State).Get = Val_Open then + Target := Obj; + exit; + + elsif Target.Is_Empty + or else + (Target.Get (Key_State) /= Val_Open + and then Integer'(Target.Get (Key_Number).Get) < + Obj.Get (Key_Number)) + then + -- Keep the one with the highest #number + Target := Obj; + end if; + end; + end loop; + + if Target.Is_Empty then + return (Exists => False); + else + return + (Exists => True, + Number => Target.Get (Key_Number), + Status => (if Target.Get (Key_State) = Val_Open + then Open + else Rejected), -- TODO: be more precise in the future + others => <>); -- TODO: likewise, inform the rest of fields + end if; + end Find_Pull_Request; + +end Alire.Publish.States; diff --git a/src/alire/alire-publish-states.ads b/src/alire/alire-publish-states.ads new file mode 100644 index 00000000..d472dd56 --- /dev/null +++ b/src/alire/alire-publish-states.ads @@ -0,0 +1,33 @@ +with Alire.Milestones; + +package Alire.Publish.States is + + type Check_States is (Pending, Running, Failed, Succeeded); + + type Life_States is (Open, Merged, Changes_Requested, Rejected); + -- Those are specific to our publishing needs, and cooked from github data + + type PR_Status (Exists : Boolean) is tagged record + case Exists is + when False => null; + when True => + Number : Natural := 0; + Status : Life_States := Open; + Checks : Check_States := Pending; + Changes_Requested : Boolean := False; + end case; + end record; + + function Is_Open (PR : PR_Status) return Boolean + is (PR.Exists and then PR.Status in Open | Changes_Requested); + + function Webpage (PR : PR_Status) return URL; + + function Webpage (PR : Natural) return URL; + -- Build the URL from the PR number + + function Find_Pull_Request (M : Milestones.Milestone) return PR_Status; + -- Find the status of a PR. Only one can be open, that will be returned in + -- preference. Otherwise, the one closed more recently will be returned. + +end Alire.Publish.States; diff --git a/src/alire/alire-publish-submit.adb b/src/alire/alire-publish-submit.adb new file mode 100644 index 00000000..f3bc478f --- /dev/null +++ b/src/alire/alire-publish-submit.adb @@ -0,0 +1,382 @@ +with Alire.Directories; +with Alire.Errors; +with Alire.GitHub; +with Alire.Index; +with Alire.OS_Lib; +with Alire.Paths; +with Alire.Platforms.Folders; +with Alire.Publish.States; +with Alire.TOML_Index; +with Alire.URI; +with Alire.Utils.TTY; +with Alire.Utils.User_Input.Query_Config; +with Alire.VCSs.Git; +with Alire.Version; +with Alire.VFS; + +with CLIC.User_Input; + +package body Alire.Publish.Submit is + + package User_Info renames Utils.User_Input.Query_Config; + + use URI.Operators; + + subtype Vector is AAA.Strings.Vector; + + -- Remote names used through + Origin : constant String := "origin"; + Upstream : constant String := "upstream"; + Upstream_Base : constant String := Upstream / Index.Community_Branch; + Upstream_Repo : constant URL := Index.Community_Host + / Index.Community_Organization + / Index.Community_Repo_Name; + + ---------------- + -- Remote_URL -- + ---------------- + + function User_Remote_URL return String + -- Must be a function so the user is not prematurely queried for the login + is (Index.Community_Host + / User_Info.User_GitHub_Login + / Index.Community_Repo_Name); + + --------------------- + -- Local_Repo_Path -- + --------------------- + + function Local_Repo_Path return Absolute_Path + is (Platforms.Folders.Cache / "publish" / "community"); + + ------------------- + -- Ask_For_Token -- + ------------------- + + function Ask_For_Token (Reason : String) return String is + + -------------- + -- Validate -- + -------------- + + function Validate (S : String) return Boolean + is (S /= ""); + + GH_Token : constant String := OS_Lib.Getenv (GitHub.Env_GH_Token, ""); + begin + if GH_Token = "" then + Put_Info + (TTY.Terminal ("alr") & " requires a GitHub Personal Access " + & "Token (PAT) " & Reason & ". To avoid being asked for it " + & "every time, you can define the GH_TOKEN environment " + & "variable."); + Put_Info + ("You can create access tokens at " & TTY.URL (GitHub.URL_Tokens)); + end if; + + return (if GH_Token /= "" + then GH_Token + else + CLIC.User_Input.Query_String + ("Please provide your GitHub Personal Access Token: ", + Default => "", + Validation => Validate'Unrestricted_Access)); + end Ask_For_Token; + + ------------ + -- Exists -- + ------------ + + procedure Exists (Context : in out Data) is + begin + -- Detect root we are going to need + + Context.Root := Roots.Optional.Search_Root (Directories.Current); + if not Context.Root.Is_Valid then + Raise_Checked_Error ("Cannot continue outside of a workspace"); + end if; + + declare + Busy : constant Trace.Ongoing := + Trace.Activity ("Looking up pull requests") + with Unreferenced; + + Status : constant States.PR_Status + := States.Find_Pull_Request (Context.Root.Value.Release.Milestone); + begin + if Status.Is_Open then + Raise_Checked_Error + (Errors.New_Wrapper + .Wrap ("There is already an open pull request for " + & Utils.TTY.Name (Context.Root.Value.Name)) + .Wrap ("Visit " & TTY.URL (Status.Webpage) & " for details") + .Get); + end if; + end; + + Put_Success ("No conflicting pull request found"); + end Exists; + + --------------- + -- Fork_Repo -- + --------------- + + procedure Fork (Context : in out Data) is + use all type CLIC.User_Input.Answer_Kind; + use all type GitHub.Async_Result; + begin + + -- Verify manifest to publish was generated at expected place + + if not Directories.Is_File (Context.Generated_Manifest) then + Raise_Checked_Error ("Cannot continue: manifest missing at " + & TTY.URL (Context.Generated_Manifest)); + end if; + + Context.Token := +Ask_For_Token + ("to fork the community index to your account"); + + if GitHub.Repo_Exists then + Put_Success ("Community index fork exists in user account"); + return; + else + if CLIC.User_Input.Query + ("A fork of the community index will now be created into your " + & "GitHub account to be able to submit a pull request. " + & "Do you agree?", + Valid => (Yes | No => True, others => False), + Default => Yes) /= Yes + then + Raise_Checked_Error + ("Cannot continue with automatic submission"); + end if; + end if; + + case GitHub.Fork (Owner => Index.Community_Organization, + Repo => Index.Community_Repo_Name, + Token => +Context.Token) + is + when Pending => + Raise_Checked_Error + ("Forking is still ongoing, " + & "please try again in a few minutes"); + when Completed => + Put_Success ("Fork of community index completed"); + end case; + end Fork; + + ----------- + -- Clone -- + ----------- + + procedure Clone (Context : in out Data) is + + use all type Vector; + + ---------------------- + -- Prepare_Upstream -- + ---------------------- + + procedure Prepare_Upstream is + begin + -- Ensure upstream is proper by removing/readding it + if VCSs.Git.Remotes (Local_Repo_Path).Contains (Upstream) then + VCSs.Git.Command + (Local_Repo_Path, + To_Vector ("remote") & "remove" & Upstream).Discard_Output; + end if; + + -- Set up the upstream remote + VCSs.Git.Add_Remote (Local_Repo_Path, + Name => Upstream, + URL => Upstream_Repo); + end Prepare_Upstream; + + ---------- + -- Pull -- + ---------- + + procedure Pull is + begin + -- Start by preparing the base upstream remote + + Prepare_Upstream; + + -- Fetch any upstream remote changes + + VCSs.Git.Command (Local_Repo_Path, + To_Vector ("fetch") & Upstream).Discard_Output; + + -- Force-checkout the branch we want + + VCSs.Git.Command (Local_Repo_Path, + To_Vector ("checkout") + & Upstream_Base + & "-B" & Context.Branch_Name).Discard_Output; + + -- And ensure the situation is pristine to add our new manifest + + VCSs.Git.Command (Repo => Local_Repo_Path, + Args => + To_Vector ("reset") + & "--hard" + & Upstream_Base).Discard_Output; + -- Discard any local changes + + VCSs.Git.Command (Repo => Local_Repo_Path, + Args => To_Vector ("clean") & "-fd").Discard_Output; + -- Drop any spurious files/folders (like other submitted manifests) + + Put_Success ("Local index updated successfully"); + end Pull; + + begin + if Directories.Is_Directory (Local_Repo_Path) + and then VCSs.Git.Handler.Is_Repository (Local_Repo_Path) + and then VCSs.Git.Handler.Remote_URL (Local_Repo_Path) = + User_Remote_URL + then + -- It's enough to refresh the local repo + Pull; + return; + end if; + + Directories.Force_Delete (Local_Repo_Path); + -- Delete a possibly outdated repo + + VCSs.Git.Handler.Clone + (From => Index.Community_Host + / User_Info.User_GitHub_Login + / Index.Community_Repo_Name, + Into => Local_Repo_Path).Assert; + + -- We can reuse the pull logic now to set up the local branch + Pull; + Put_Success ("Community index cloned succesfully"); + end Clone; + + ---------- + -- Push -- + ---------- + + procedure Push (Context : in out Data) is + + Filename : constant String := + TOML_Index.Manifest_File + (Context.Root.Value.Name, + Context.Root.Value.Release.Version); + + Manifest : constant Absolute_Path := + Context.Root.Value.Working_Folder + / Paths.Release_Folder_Inside_Working_Folder + / Filename; + + ---------- + -- Copy -- + ---------- + + procedure Copy is + Target : constant Absolute_Path + := Local_Repo_Path + / VFS.To_Native + (TOML_Index.Manifest_Path (Context.Root.Value.Name)) + / Filename; + begin + Directories.Create_Tree (Directories.Parent (Target)); + Directories.Adirs.Copy_File (Manifest, Target); + Put_Success ("Manifest copied into place: " & TTY.URL (Target), + Trace.Detail); + end Copy; + + ------------ + -- Commit -- + ------------ + + procedure Commit is + use all type AAA.Strings.Vector; + use all type VCSs.Git.States; + begin + -- Add files first, so if there's something new it's detected as + -- dirty. + + VCSs.Git.Command (Local_Repo_Path, + To_Vector ("add") & ".").Discard_Output; + + -- Now we can check if there's something to commit or not + + if VCSs.Git.Handler.Status (Local_Repo_Path) = Dirty then + VCSs.Git.Commit_All + (Local_Repo_Path, + Msg => Context.PR_Name + & " (via `alr publish --submit`)").Assert; + else + Put_Warning + ("Nothing to commit: " + & "manifest was already in repository"); + end if; + end Commit; + + ------------ + -- Upload -- + ------------ + + procedure Upload is + begin + VCSs.Git.Push (Local_Repo_Path, + Remote => Origin, + Token => +Context.Token, + Force => True, + Create => True).Assert; + Put_Success ("Manifest pushed into remote index"); + end Upload; + + begin + Copy; + Commit; + Upload; + end Push; + + ------------------ + -- Request_Pull -- + ------------------ + + procedure Request_Pull (Context : in out Data) is + use all type CLIC.User_Input.Answer_Kind; + begin + if CLIC.User_Input.Query + ("A pull request is about to be created on " + & TTY.URL (Upstream_Repo / "pulls") + & New_Line + & "Do you want to continue?", + Valid => (No | Yes => True, others => False), + Default => Yes) /= Yes + then + Raise_Checked_Error ("Cancelled"); + end if; + + declare + Busy : constant Trace.Ongoing := + Trace.Activity ("Opening pull request") + with Unreferenced; + + Number : constant Natural + := GitHub.Create_Pull_Request + (Draft => True, + Token => +Context.Token, + Head_Branch => Context.Branch_Name, + Title => Context.PR_Name, + Message => + "Created via `alr publish` with `alr " + & Version.Current & "`"); + begin + Put_Success ("Pull request created successfully"); + Put_Info ("Visit " & TTY.URL (States.Webpage (Number)) + & " for details"); + Put_Warning ("The submission is in " & TTY.Emph ("draft mode") & ". " + & "Please visit the given URL and request a review once " + & "automated checks have succeeded.", + Trace.Info); + end; + end Request_Pull; + +end Alire.Publish.Submit; diff --git a/src/alire/alire-publish-submit.ads b/src/alire/alire-publish-submit.ads new file mode 100644 index 00000000..d3564249 --- /dev/null +++ b/src/alire/alire-publish-submit.ads @@ -0,0 +1,54 @@ +private package Alire.Publish.Submit is + + -- Steps for the assistant, not intended to be called directly. These steps + -- are executed right after manifest creation in the order that follows. + + procedure Exists (Context : in out Data); + -- Check if there's a PR already for this release. GitHub doesn't allow two + -- PRs from the same user and from the same branch, so to avoid a failure + -- late in the process, we check immediately that no such a PR exists + -- already. + + -- To uniquely identify the PR, a branch `release/crate-version` is created + -- in the user fork of the community index. + + procedure Fork (Context : in out Data); + -- To be able to submit the PR, the user needs to have its own fork of the + -- community index (as users cannot create branches in the community index + -- itself). This step checks if the user already has its own fork, or + -- creates it otherwise. + + -- To be able to create a fork in the user's account, we need a Personal + -- Access Token (PAT) with `repo` permissions. The same token will allow us + -- to later create a new branch, push to it, and open the PR. This PAT can + -- be supplied via the GH_TOKEN env var (also used by the `gh` tool), or + -- `alr` will ask for it when undefined. We don't store it in our config + -- as this is a sensitive piece of info. + + procedure Clone (Context : in out Data); + -- Once the fork is sure to exist, we clone it locally to + -- /publish/community, unless a repo already exists at that location + -- with a matching remote. We add a new `upstream` remote (or recreate + -- it just to be sure) that points to the community index. We fetch from + -- upstream, as the status of the user's clone is not important, but the + -- upstream status is. + + procedure Push (Context : in out Data); + -- Once in sync with upstream, we locally create the + -- `release/crate-version` branch, copy the manifest to its intended + -- location, commit it, and force-push to the user's fork, creating the + -- same branch remotely. As we are using upstream to base the new branch, + -- and we are force-pushing, there's no possibility of ending in an + -- incongruous or conflicting state. + + -- At this point, the user could open their fork on GitHub and they would + -- see the banner asking to create a PR against the community index from + -- its fork, because there is a recent push. + + procedure Request_Pull (Context : in out Data); + -- This step simply uses the REST API to open the pull request on the + -- community index, using the user's fork branch as head, just as if the + -- web interface were used. A default title and message using the release + -- name and version are used. + +end Alire.Publish.Submit; diff --git a/src/alire/alire-publish.adb b/src/alire/alire-publish.adb index 47897d1d..f85aae6c 100644 --- a/src/alire/alire-publish.adb +++ b/src/alire/alire-publish.adb @@ -5,7 +5,7 @@ with AAA.Strings; with Alire.Config; with Alire.Crates; -with Alire.Directories; +with Alire.Environment; with Alire.Errors; with Alire.Index_On_Disk.Loading; with Alire.GitHub; @@ -17,9 +17,9 @@ with Alire.Origins.Deployers; with Alire.OS_Lib.Subprocess; with Alire.Paths; with Alire.Properties.From_TOML; +with Alire.Publish.Submit; with Alire.Releases; with Alire.Root; -with Alire.Roots.Optional; with Alire.TOML_Adapters; with Alire.TOML_Index; with Alire.TOML_Keys; @@ -57,24 +57,10 @@ package body Alire.Publish is .Append ("savannah.nongnu.org") .Append ("sf.net"); - type Data is limited record - Options : All_Options; - - Origin : Origins.Origin := Origins.New_External ("undefined"); - -- We use external as "undefined" until a proper origin is provided. - - Path : UString := +"."; - -- Where to find the local workspace - - Subdir : Unbounded_Relative_Path; - -- Subdir inside the root repo, for monorepo crates - - Revision : UString := +"HEAD"; - -- A particular revision for publishing from a git repo - - Tmp_Deploy_Dir : Directories.Temp_File; - -- Place to check the sources - end record; + Early_Stop : exception; + -- Raise this exception from a step to terminate prematurely but without + -- generating an error. E.g., if the user doesn't want to submit online + -- after successful manifest generation. --------------- -- Base_Path -- @@ -114,15 +100,35 @@ package body Alire.Publish is function Packaged_Manifest (This : Data) return Any_Path is (Deploy_Path (This) / Roots.Crate_File_Name); + ------------------------ + -- Generated_Filename -- + ------------------------ + + function Generated_Filename (This : Data) return String + is (TOML_Index.Manifest_File + (This.Root.Value.Name, + This.Root.Value.Release.Version)); + + ------------------------ + -- Generated_Manifest -- + ------------------------ + + function Generated_Manifest (This : Data) return Absolute_Path + is (This.Root.Value.Working_Folder + / Paths.Release_Folder_Inside_Working_Folder + / This.Generated_Filename); + ----------------- -- New_Options -- ----------------- - function New_Options (Skip_Build : Boolean := False; - Manifest : String := Roots.Crate_File_Name) + function New_Options (Skip_Build : Boolean := False; + Skip_Submit : Boolean := False; + Manifest : String := Roots.Crate_File_Name) return All_Options is (Manifest_File => +Manifest, - Skip_Build => Skip_Build); + Skip_Build => Skip_Build, + Skip_Submit => Skip_Submit); --------------- -- Git_Error -- @@ -448,6 +454,7 @@ package body Alire.Publish is declare use Ada.Text_IO; + use all type CLIC.User_Input.Answer_Kind; use TOML; TOML_Manifest : constant TOML_Value := TOML_Load.Load_File (User_Manifest); @@ -462,7 +469,7 @@ package body Alire.Publish is (if Workspace.Is_Valid then Workspace.Value.Working_Folder else "." / Paths.Working_Folder_Inside_Root) - / "releases" + / Paths.Release_Folder_Inside_Working_Folder / TOML_Index.Manifest_File (Name, Version); Index_File : File_Type; begin @@ -498,10 +505,26 @@ package body Alire.Publish is ("Your index manifest file has been generated at " & TTY.URL (Index_Manifest)); - -- Show the upload URL in normal circumstances, or a more generic - -- message otherwise (when lacking a github login). + -- Ask to submit, or show the upload URL if submission skipped, or a + -- more generic message otherwise (when lacking a github login). - if Config.DB.Defined (Config.Keys.User_Github_Login) then + if not Context.Options.Skip_Submit then + -- Safeguard to avoid tests creating a live pull request + if OS_Lib.Getenv (Environment.Testsuite, "unset") /= "unset" then + raise Program_Error + with "Attempting to go online to create a PR during tests"; + end if; + + -- Go ahead? + if CLIC.User_Input.Query + ("Do you want to continue onto submission to the online " + & "community index?", + Valid => (Yes | No => True, others => False), + Default => Yes) = No + then + raise Early_Stop; + end if; + elsif Config.DB.Defined (Config.Keys.User_Github_Login) then Put_Info ("Please upload this file to " & TTY.URL @@ -856,7 +879,12 @@ package body Alire.Publish is Step_Deploy_Sources, Step_Check_Build, Step_Show_And_Confirm, - Step_Generate_Index_Manifest); + Step_Generate_Index_Manifest, + Step_Check_Exists, + Step_Fork, + Step_Clone, + Step_Push, + Step_Submit); type Step_Array is array (Positive range <>) of Step_Names; @@ -869,7 +897,12 @@ package body Alire.Publish is Step_Deploy_Sources => Deploy_Sources'Access, Step_Check_Build => Check_Build'Access, Step_Show_And_Confirm => Show_And_Confirm'Access, - Step_Generate_Index_Manifest => Generate_Index_Manifest'Access); + Step_Generate_Index_Manifest => Generate_Index_Manifest'Access, + Step_Check_Exists => Submit.Exists'Access, + Step_Fork => Submit.Fork'Access, + Step_Clone => Submit.Clone'Access, + Step_Push => Submit.Push'Access, + Step_Submit => Submit.Request_Pull'Access); function Step_Description (Step : Step_Names) return String is (case Step is @@ -880,7 +913,21 @@ package body Alire.Publish is when Step_Deploy_Sources => "Deploy sources", when Step_Check_Build => "Build release", when Step_Show_And_Confirm => "User review", - when Step_Generate_Index_Manifest => "Generate index manifest"); + when Step_Generate_Index_Manifest => "Generate index manifest", + when Step_Check_Exists => "Check existing PR", + when Step_Fork => "Fork community index", + when Step_Clone => "Clone community index", + when Step_Push => "Upload manifest", + when Step_Submit => "Submit manifest for review"); + + Submit_Steps : constant Step_Array := + (Step_Check_Exists, + Step_Fork, + Step_Clone, + Step_Push, + Step_Submit); + + No_Steps : constant Step_Array (1 .. 0) := (others => <>); --------------- -- Run_Steps -- @@ -901,6 +948,9 @@ package body Alire.Publish is Step_Calls (Steps (Current)) (Context); end loop; + exception + when Early_Stop => + Trace.Info ("Publishing assistant stopped"); end Run_Steps; ------------------- @@ -917,7 +967,9 @@ package body Alire.Publish is Path => +Path, Subdir => <>, Revision => +Revision, - Tmp_Deploy_Dir => <>); + Tmp_Deploy_Dir => <>, + Root => <>, + Token => <>); Guard : Directories.Guard (Directories.Enter (Base_Path (Context))) with Unreferenced; @@ -930,7 +982,11 @@ package body Alire.Publish is Step_Deploy_Sources, Step_Check_Build, Step_Show_And_Confirm, - Step_Generate_Index_Manifest)); + Step_Generate_Index_Manifest) + & + (if not Options.Skip_Submit + then Submit_Steps + else No_Steps)); end Directory_Tar; ---------------- @@ -1173,7 +1229,9 @@ package body Alire.Publish is Revision => +Commit, - Tmp_Deploy_Dir => <>); + Tmp_Deploy_Dir => <>, + Root => <>, + Token => <>); begin Run_Steps (Context, (Step_Verify_Origin, @@ -1181,7 +1239,11 @@ package body Alire.Publish is Step_Deploy_Sources, Step_Check_Build, Step_Show_And_Confirm, - Step_Generate_Index_Manifest)); + Step_Generate_Index_Manifest) + & + (if not Options.Skip_Submit + then Submit_Steps + else No_Steps)); end; exception when E : Checked_Error | Origins.Unknown_Source_Archive_Format_Error => diff --git a/src/alire/alire-publish.ads b/src/alire/alire-publish.ads index 74f2650f..b1df314c 100644 --- a/src/alire/alire-publish.ads +++ b/src/alire/alire-publish.ads @@ -1,12 +1,16 @@ -with Alire.Roots; +private with Alire.Directories; +with Alire.Milestones; +private with Alire.Origins; +with Alire.Roots.Optional; with Alire.URI; package Alire.Publish is type All_Options is private; - function New_Options (Skip_Build : Boolean := False; - Manifest : String := Roots.Crate_File_Name) + function New_Options (Skip_Build : Boolean := False; + Skip_Submit : Boolean := False; + Manifest : String := Roots.Crate_File_Name) return All_Options; procedure Directory_Tar (Path : Any_Path := "."; @@ -35,17 +39,25 @@ package Alire.Publish is -- a file `crate-version.toml` in the current directory or raises -- Checked_Error with the appropriate error message set. + function Branch_Name (M : Milestones.Milestone) return String + is ("release/" + & M.Crate.As_String & "-" + & M.Version.Image); + procedure Print_Trusted_Sites; -- Print our list of allowed sites to host git releases function Is_Trusted (URL : Alire.URL) return Boolean; -- According to our whitelist + type Data is tagged limited private; + private type All_Options is tagged record Manifest_File : UString; Skip_Build : Boolean := False; + Skip_Submit : Boolean := False; end record; function Manifest (Options : All_Options) return Any_Path @@ -54,4 +66,58 @@ private function Nonstandard_Manifest (Options : All_Options) return Boolean is (Options.Manifest /= Roots.Crate_File_Name); + -- Data shared across publishing steps, needs to be visible to children + + type Data is tagged limited record + Options : All_Options; + + Origin : Origins.Origin := Origins.New_External ("undefined"); + -- We use external as "undefined" until a proper origin is provided. + + Path : UString := +"."; + -- Where to find the local workspace + + Subdir : Unbounded_Relative_Path; + -- Subdir inside the root repo, for monorepo crates + + Revision : UString := +"HEAD"; + -- A particular revision for publishing from a git repo + + Tmp_Deploy_Dir : Directories.Temp_File; + -- Place to check the sources + + Root : Roots.Optional.Root; + -- Required valid by the submit steps + + Token : UString; + -- GitHub Personal Access token, required to fork/create PR + end record; + + ----------------- + -- Branch_Name -- + ----------------- + + function Branch_Name (This : Data) return String + is (Branch_Name (This.Root.Value.Release.Milestone)); + + ------------- + -- PR_Name -- + ------------- + + function PR_Name (This : Data) return String + is (This.Root.Value.Name.As_String & " " + & This.Root.Value.Release.Version.Image); + + ------------------------ + -- Generated_Filename -- + ------------------------ + + function Generated_Filename (This : Data) return String; + + ------------------------ + -- Generated_Manifest -- + ------------------------ + + function Generated_Manifest (This : Data) return Absolute_Path; + end Alire.Publish; diff --git a/src/alire/alire-uri.adb b/src/alire/alire-uri.adb index 59262ee4..1c8e47a4 100644 --- a/src/alire/alire-uri.adb +++ b/src/alire/alire-uri.adb @@ -49,4 +49,15 @@ package body Alire.URI is Unknown); end Scheme; + package body Operators is + + --------- + -- "/" -- + --------- + + function "/" (L, R : String) return String + is (L & "/" & R); + + end Operators; + end Alire.URI; diff --git a/src/alire/alire-uri.ads b/src/alire/alire-uri.ads index e425a7de..d7db14cf 100644 --- a/src/alire/alire-uri.ads +++ b/src/alire/alire-uri.ads @@ -24,6 +24,13 @@ package Alire.URI with Preelaborate is -- / \ / \ -- urn:example:animal:ferret:nose + package Operators is + + function "/" (L, R : String) return String; + -- Concatenate with forward slash + + end Operators; + type Schemes is (None, -- For URLs without scheme (to be interpreted as local paths) diff --git a/src/alire/alire-vcss-git.adb b/src/alire/alire-vcss-git.adb index 1dadf6c8..cc63c802 100644 --- a/src/alire/alire-vcss-git.adb +++ b/src/alire/alire-vcss-git.adb @@ -4,12 +4,15 @@ with Alire.Directories; with Alire.OS_Lib.Subprocess; with Alire.Errors; with Alire.Utils.Tools; +with Alire.Utils.User_Input.Query_Config; with Alire.VFS; with GNAT.Source_Info; package body Alire.VCSs.Git is + package User_Info renames Utils.User_Input.Query_Config; + ------------- -- Run_Git -- ------------- @@ -56,6 +59,19 @@ package body Alire.VCSs.Git is Err_To_Out => True); end Unchecked_Run_Git_And_Capture; + ---------------- + -- Add_Remote -- + ---------------- + + procedure Add_Remote (Repo : Directory_Path; + Name : String; + URL : String) + is + Guard : Directories.Guard (Directories.Enter (Repo)) with Unreferenced; + begin + Run_Git (To_Vector ("remote") & "add" & Name & URL); + end Add_Remote; + ------------ -- Branch -- ------------ @@ -80,6 +96,30 @@ package body Alire.VCSs.Git is & Output.Flatten ("\n ")); end Branch; + -------------- + -- Branches -- + -------------- + + function Branches (Repo : Directory_Path; + Local : Boolean := True; + Remote : Boolean := True) + return AAA.Strings.Vector + is + Guard : Directories.Guard (Directories.Enter (Repo)) with Unreferenced; + Output : constant AAA.Strings.Vector := + Run_Git_And_Capture + (Empty_Vector + & "branch" & "--format=%(refname:short)" + & (if Local and then Remote then + To_Vector ("-a") + elsif Remote then + To_Vector ("-r") + else + Empty_Vector)); + begin + return Output; + end Branches; + ----------- -- Clone -- ----------- @@ -144,6 +184,111 @@ package body Alire.VCSs.Git is return Alire.Errors.Get (E); end Clone; + ------------- + -- Command -- + ------------- + + function Command (Repo : Directory_Path; + Args : AAA.Strings.Vector; + Quiet : Boolean := False) + return Output + is + Guard : Directories.Guard (Directories.Enter (Repo)) with Unreferenced; + begin + return + (Run_Git_And_Capture + (Arguments => + (if Quiet then To_Vector ("-q") else Empty_Vector) & Args) + with null record); + end Command; + + ---------------- + -- Commit_All -- + ---------------- + + function Commit_All (Repo : Directory_Path; + Msg : String := "Automatic by alr") return Outcome + is + Guard : Directories.Guard (Directories.Enter (Repo)) with Unreferenced; + begin + Run_Git (Empty_Vector & "add" & "."); + Run_Git (Empty_Vector + & "-c" + & String'("user.email=" & User_Info.User_Email) + & "commit" + & "-m" & Msg); + return Outcome_Success; + exception + when E : others => + return Alire.Errors.Get (E); + end Commit_All; + + ---------- + -- Push -- + ---------- + + function Push (Repo : Directory_Path; + Remote : String; + Force : Boolean := False; + Create : Boolean := False; + Token : String := "") return Outcome + is + Guard : Directories.Guard (Directories.Enter (Repo)) with Unreferenced; + + Writname : constant String := "writable"; + + Force_Flags : constant Vector := + (if Force then To_Vector ("-f") else Empty_Vector); + + Create_Flags : constant Vector := + (if Create + then To_Vector ("-u") + & (if Token /= "" + then Writname + else Remote) + & Handler.Branch (Repo) + else Empty_Vector); + begin + if Token = "" then + Run_Git (Empty_Vector + & "push" + & Force_Flags + & Create_Flags); + else + -- Create a temporary remote with our credentials and use it to push + declare + Old : constant URL := + Handler.Remote_URL (Repo, Handler.Remote (Repo)); + Writurl : constant URL := + Replace (Old, "//", "//" + & User_Info.User_GitHub_Login + & ":" & Token & "@"); + begin + Run_Git (Empty_Vector + & "remote" & "add" & Writname & Writurl); + Run_Git (Empty_Vector + & "push" + & Force_Flags + & (if Create + then Create_Flags + else To_Vector (Writname))); + Run_Git (Empty_Vector + & "remote" & "remove" & Writname); + end; + end if; + + return Outcome_Success; + exception + when E : others => + -- Ensure token is not left behind even in case of push failure + if Handler.Remote_URL (Repo, Writname) /= "" then + Run_Git (Empty_Vector + & "remote" & "remove" & Writname); + end if; + + return Alire.Errors.Get (E); + end Push; + --------------------- -- Revision_Commit -- --------------------- @@ -272,6 +417,50 @@ package body Alire.VCSs.Git is end if; end Remote; + ---------------- + -- Remote_URL -- + ---------------- + + not overriding + function Remote_URL (This : VCS; + Path : Directory_Path; + Remote : String := "origin") + return String + is + pragma Unreferenced (This); + Guard : Directories.Guard (Directories.Enter (Path)) with Unreferenced; + Output : constant AAA.Strings.Vector := + Run_Git_And_Capture (Empty_Vector & "remote" & "-v"); + begin + for Line of Output loop + declare + Cols : constant Vector := Split (Line, ASCII.HT, Trim => True); + begin + if Cols (1) = Remote then + return AAA.Strings.Split (Cols (2), ' ').First_Element; + end if; + end; + end loop; + + return ""; + end Remote_URL; + + ------------- + -- Remotes -- + ------------- + + function Remotes (Repo : Directory_Path) return AAA.Strings.Set is + Guard : Directories.Guard (Directories.Enter (Repo)) with Unreferenced; + Output : constant AAA.Strings.Vector := + Run_Git_And_Capture (To_Vector ("remote")); + begin + return Result : AAA.Strings.Set do + for Line of Output loop + Result.Include (Line); + end loop; + end return; + end Remotes; + ------------------- -- Remote_Commit -- ------------------- @@ -368,14 +557,19 @@ package body Alire.VCSs.Git is -- Retrieve revisions from remote branch tip up to our local HEAD. If -- not empty, we are locally ahead. declare + Branch : constant String := This.Branch (Repo); Remote : constant String := This.Remote (Repo, Checked => False); begin if Remote = "" then return No_Remote; + elsif (for all B of Branches (Repo, Local => False) => + B /= Remote & "/" & Branch) + then -- The branch doesn't even exist remotely + return Ahead; elsif Run_Git_And_Capture (Empty_Vector & "rev-list" - & String'(Remote & "/" & This.Branch (Repo) + & String'(Remote & "/" & Branch & "..HEAD")).Is_Empty then return Clean; diff --git a/src/alire/alire-vcss-git.ads b/src/alire/alire-vcss-git.ads index 9f9996a8..765c154f 100644 --- a/src/alire/alire-vcss-git.ads +++ b/src/alire/alire-vcss-git.ads @@ -23,12 +23,22 @@ package Alire.VCSs.Git is function Handler return VCS; + procedure Add_Remote (Repo : Directory_Path; + Name : String; + URL : String); + not overriding function Branch (This : VCS; Path : Directory_Path) return String; -- Returns the branch name of the repo checked out at Path. + function Branches (Repo : Directory_Path; + Local : Boolean := True; + Remote : Boolean := True) + return AAA.Strings.Vector; + -- List all known branches (without going on-line) + overriding function Clone (This : VCS; From : URL; @@ -46,6 +56,35 @@ package Alire.VCSs.Git is -- default remote branch. For any Depth /= 0, apply --depth . A -- commit may be specified as From#Commit_Id + type Output is new AAA.Strings.Vector with null record; + + procedure Discard_Output (This : Output) is null; + -- Allows running a git command and ignoring its output + + function Command (Repo : Directory_Path; + Args : AAA.Strings.Vector; + Quiet : Boolean := False) + return Output; + + -- Run any command directly. "git" is implicit. "-q" appended when Quiet. + -- Will raise on exit code /= 0 + + function Commit_All (Repo : Directory_Path; + Msg : String := "Automatic by alr") + return Outcome; + -- Add and commit all changes in a given repo; commiter will be set to the + -- user email stored in our config. + + function Push (Repo : Directory_Path; + Remote : String; + Force : Boolean := False; + Create : Boolean := False; + Token : String := "") return Outcome; + -- Push to the remote. If Create, use "-u ". If an + -- Auth Token is given, a temporary remote that includes the token will be + -- created and removed for the push; the local branch will be set to track + -- the original remote afterwards. + not overriding function Remote_Commit (This : VCS; From : URL; @@ -79,6 +118,17 @@ package Alire.VCSs.Git is -- Retrieve current remote name (usually "origin"). If checked, raise -- Checked_Error when no remote configured. Otherwise, return ""; + not overriding + function Remote_URL (This : VCS; + Path : Directory_Path; + Remote : String := "origin") + return String; + -- Returns the URL for the given remote, or "" if unset. Assumes both fetch + -- and push remotes are the same. + + function Remotes (Repo : Directory_Path) return AAA.Strings.Set; + -- Return all the remote names defined in the repository + overriding function Update (This : VCS; Repo : Directory_Path) @@ -101,6 +151,7 @@ package Alire.VCSs.Git is function Status (This : VCS; Repo : Directory_Path) return States; + -- Note that untracked files don't cause a Dirty result! not overriding function Fetch_URL (This : VCS; diff --git a/src/alire/alire.adb b/src/alire/alire.adb index 0ea6abb2..3e2ea7ef 100644 --- a/src/alire/alire.adb +++ b/src/alire/alire.adb @@ -6,6 +6,8 @@ with Alire.Utils.TTY; with GNAT.IO; +with GNATCOLL.OS.Constants; + package body Alire is --------- @@ -289,4 +291,19 @@ package body Alire is end if; end Recoverable_Error; + -------------- + -- New_Line -- + -------------- + + function New_Line return String + is + use all type GNATCOLL.OS.OS_Type; + begin + case GNATCOLL.OS.Constants.OS is + when Unix | MacOS => return (1 .. 1 => Character'Val (16#0A#)); + when Windows => return (Character'Val (16#0D#), + Character'Val (16#0A#)); + end case; + end New_Line; + end Alire; diff --git a/src/alire/alire.ads b/src/alire/alire.ads index 8deb8a90..26773475 100644 --- a/src/alire/alire.ads +++ b/src/alire/alire.ads @@ -287,6 +287,9 @@ package Alire with Preelaborate is function Log (Text : String; Level : Trace.Levels := Info) return String; -- A convenience to be able to log inside declarative blocks. Returns Text. + function New_Line return String; + -- Returns the proper \n sequence based on the platform + --------------- -- Constants -- --------------- diff --git a/src/alire/os_freebsd/alire-platforms-folders__freebsd.adb b/src/alire/os_freebsd/alire-platforms-folders__freebsd.adb index 41020bd6..e3768ccc 100644 --- a/src/alire/os_freebsd/alire-platforms-folders__freebsd.adb +++ b/src/alire/os_freebsd/alire-platforms-folders__freebsd.adb @@ -1,3 +1,5 @@ +with Ada.Directories; + with Alire.Platforms.Common; package body Alire.Platforms.Folders is @@ -22,4 +24,11 @@ package body Alire.Platforms.Folders is function Home return Absolute_Path is (Common.Unix_Home_Folder); + ---------- + -- Temp -- + ---------- + + function Temp return Absolute_Path + is (Ada.Directories.Full_Name (Common.Unix_Temp_Folder)); + end Alire.Platforms.Folders; diff --git a/src/alire/os_linux/alire-platforms-folders__linux.adb b/src/alire/os_linux/alire-platforms-folders__linux.adb index 41020bd6..e3768ccc 100644 --- a/src/alire/os_linux/alire-platforms-folders__linux.adb +++ b/src/alire/os_linux/alire-platforms-folders__linux.adb @@ -1,3 +1,5 @@ +with Ada.Directories; + with Alire.Platforms.Common; package body Alire.Platforms.Folders is @@ -22,4 +24,11 @@ package body Alire.Platforms.Folders is function Home return Absolute_Path is (Common.Unix_Home_Folder); + ---------- + -- Temp -- + ---------- + + function Temp return Absolute_Path + is (Ada.Directories.Full_Name (Common.Unix_Temp_Folder)); + end Alire.Platforms.Folders; diff --git a/src/alire/os_macos/alire-platforms-folders__macos.adb b/src/alire/os_macos/alire-platforms-folders__macos.adb index 3fbc8b10..679d454e 100644 --- a/src/alire/os_macos/alire-platforms-folders__macos.adb +++ b/src/alire/os_macos/alire-platforms-folders__macos.adb @@ -1,3 +1,5 @@ +with Ada.Directories; + with Alire.Platforms.Common; package body Alire.Platforms.Folders is @@ -22,4 +24,11 @@ package body Alire.Platforms.Folders is function Home return Absolute_Path is (Common.Unix_Home_Folder); + ---------- + -- Temp -- + ---------- + + function Temp return Absolute_Path + is (Ada.Directories.Full_Name (Common.Unix_Temp_Folder)); + end Alire.Platforms.Folders; diff --git a/src/alire/os_windows/alire-platforms-folders__windows.adb b/src/alire/os_windows/alire-platforms-folders__windows.adb index 7a70bd39..7992940e 100644 --- a/src/alire/os_windows/alire-platforms-folders__windows.adb +++ b/src/alire/os_windows/alire-platforms-folders__windows.adb @@ -1,3 +1,5 @@ +with Ada.Directories; + with Alire.OS_Lib; package body Alire.Platforms.Folders is @@ -23,4 +25,13 @@ package body Alire.Platforms.Folders is function Config return Absolute_Path is (Home / ".config" / "alire"); + ---------- + -- Temp -- + ---------- + + function Temp return Absolute_Path + is (Ada.Directories.Full_Name + (OS_Lib.Getenv ("TEMP", + OS_Lib.Getenv ("TMP", ".")))); + end Alire.Platforms.Folders; diff --git a/src/alr/alr-commands-publish.adb b/src/alr/alr-commands-publish.adb index 2f883e0d..c5fbd2de 100644 --- a/src/alr/alr-commands-publish.adb +++ b/src/alr/alr-commands-publish.adb @@ -21,11 +21,12 @@ package body Alr.Commands.Publish is Options : constant Alire.Publish.All_Options := Alire.Publish.New_Options - (Manifest => + (Manifest => (if Cmd.Manifest.all /= "" then Cmd.Manifest.all else Alire.Roots.Crate_File_Name), - Skip_Build => Cmd.Skip_Build); + Skip_Build => Cmd.Skip_Build, + Skip_Submit => Cmd.Skip_Submit); begin if Alire.Utils.Count_True ((Cmd.Tar, Cmd.Print_Trusted)) > 1 or else @@ -110,6 +111,12 @@ package body Alr.Commands.Publish is "", "--manifest=", "Selects a manifest file other than ./alire.toml"); + Define_Switch + (Config, + Cmd.Skip_Submit'Access, + "", "--skip-submit", + "Do not create the online pull request onto the community index"); + Define_Switch (Config, Cmd.Tar'Access, diff --git a/src/alr/alr-commands-publish.ads b/src/alr/alr-commands-publish.ads index 8eef81a6..d7e12830 100644 --- a/src/alr/alr-commands-publish.ads +++ b/src/alr/alr-commands-publish.ads @@ -51,7 +51,8 @@ package Alr.Commands.Publish is overriding function Usage_Custom_Parameters (Cmd : Command) return String - is ("[--skip-build] [--tar] [--manifest ] [ [commit]]]"); + is ("[--skip-build] [--skip-submit] [--tar] " + & "[--manifest ] [ [commit]]]"); private @@ -64,6 +65,9 @@ private Skip_Build : aliased Boolean := False; -- Skip the build check + Skip_Submit : aliased Boolean := False; + -- Stop after generation instead of asking the user to continue + Tar : aliased Boolean := False; -- Start the assistant from a local folder to be tar'ed and uploaded end record; diff --git a/testsuite/drivers/alr.py b/testsuite/drivers/alr.py index 55276c11..f572e522 100644 --- a/testsuite/drivers/alr.py +++ b/testsuite/drivers/alr.py @@ -458,7 +458,7 @@ def add_action(type, command, name="", directory=""): manifest.write(f"directory = '{directory}'\n") -def alr_submit(manifest, index_path): +def alr_copy_to_index(manifest, index_path): """ Move a manifest with origin into its proper location in an index """ @@ -483,18 +483,25 @@ def alr_submit(manifest, index_path): def alr_publish(name, version="0.0.0", - submit=True, + copy_to_index=True, + create_pr=False, index_path=os.path.join("..", "my_index"), quiet=True): """ Run `alr publish` at the current location and optionally move the produced manifest to its intended location in a local index. """ - p = run_alr("publish", force=True, quiet=quiet) + + args = ["publish"] + if not create_pr: + args.append("--skip-submit") + + p = run_alr(*args, force=True, quiet=quiet) # Force due to missing optional crate info by `alr init` - if submit: - alr_submit(os.path.join("alire", "releases", f"{name}-{version}.toml"), - index_path) + if copy_to_index: + alr_copy_to_index( + os.path.join("alire", "releases", f"{name}-{version}.toml"), + index_path) return p diff --git a/testsuite/run.py b/testsuite/run.py index b7e2956c..43843648 100755 --- a/testsuite/run.py +++ b/testsuite/run.py @@ -38,13 +38,19 @@ class Testsuite(e3.testsuite.Testsuite): def set_up(self): super().set_up() os.environ['ALR_PATH'] = self.main.args.alr_path + # Some alr commands spawn another `alr` which must be found in path. # This way we ensure the same alr being tested is used. os.environ["PATH"] = \ f"{os.path.dirname(self.main.args.alr_path)}{os.pathsep}{os.environ['PATH']}" + # Some tests rely on an initially empty GPR_PROJECT_PATH variable os.environ.pop('GPR_PROJECT_PATH', None) + # Define a flag so that we don't run potentially dangerous actions + # during the tests (e.g. submitting a release by accident) + os.environ["ALR_TESTSUITE"] = "TRUE" + def _alr_path(self, alr_file): alr_path = os.path.abspath(alr_file) if not os.path.isfile(alr_path): diff --git a/testsuite/tests/monorepo/subdir-in-tar/test.py b/testsuite/tests/monorepo/subdir-in-tar/test.py index 2995e041..fe5ce4c3 100644 --- a/testsuite/tests/monorepo/subdir-in-tar/test.py +++ b/testsuite/tests/monorepo/subdir-in-tar/test.py @@ -2,7 +2,7 @@ Test that "subdir" is rejected for source archive origins """ -from drivers.alr import init_local_crate, run_alr, alr_submit +from drivers.alr import init_local_crate, run_alr, alr_copy_to_index from glob import glob from shutil import copyfile from subprocess import run @@ -16,7 +16,7 @@ init_local_crate("xxx", enter=True) # Publish it. We need to give input to alr, so we directly call it. We use the # generated location as the "online" location, and this works because we are # forcing. -p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--tar"], +p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--skip-submit", "--tar"], input=f"file:{os.getcwd()}/alire/archives/xxx-0.1.0-dev.tbz2\n".encode()) p.check_returncode() @@ -26,7 +26,7 @@ with open("alire/releases/xxx-0.1.0-dev.toml", "at") as file: # Submit manifest to index os.chdir("..") -alr_submit("xxx/alire/releases/xxx-0.1.0-dev.toml", "my_index") +alr_copy_to_index("xxx/alire/releases/xxx-0.1.0-dev.toml", "my_index") # Should complain on subdir field p = run_alr("show", "xxx", complain_on_error=False) diff --git a/testsuite/tests/publish/check-properties/test.py b/testsuite/tests/publish/check-properties/test.py index 41e1223f..c4dd2cc6 100644 --- a/testsuite/tests/publish/check-properties/test.py +++ b/testsuite/tests/publish/check-properties/test.py @@ -10,13 +10,13 @@ from drivers.helpers import init_git_repo # and the other is missing optional tags. # Attempt with crate missing maintainer -p = run_alr("publish", "nomaint.tgz", +p = run_alr("publish", "nomaint.tgz", "--skip-submit", complain_on_error=False, force=True) assert_match(".*Missing required properties: maintainers.*", p.out) # Attempt with crate missing optional recommended properties. No quiet or the # warning on optional properties is silenced. -p = run_alr("publish", "notags.tgz", +p = run_alr("publish", "notags.tgz", "--skip-submit", quiet=False, force=True) assert_match(".*Missing optional recommended properties:" " authors, licenses, tags, website.*", diff --git a/testsuite/tests/publish/check-trusted/test.py b/testsuite/tests/publish/check-trusted/test.py index 77ba881a..2159af1b 100644 --- a/testsuite/tests/publish/check-trusted/test.py +++ b/testsuite/tests/publish/check-trusted/test.py @@ -9,6 +9,7 @@ from drivers.asserts import assert_match for domain in ["badsite.com", "ggithub.com", "github.comm"]: p = run_alr("publish", f"http://{domain}/repo.git", "deadbeefdeadbeefdeadbeefdeadbeefdeadbeef", + "--skip-submit", complain_on_error=False) assert_match(f".*Origin is hosted on unknown site: {domain}.*", p.out) @@ -18,6 +19,7 @@ for domain in ["badsite.com", "ggithub.com", "github.comm"]: for creds in ["user", "user:passwd"]: p = run_alr("publish", f"http://{creds}@{domain}/repo.git", "deadbeefdeadbeefdeadbeefdeadbeefdeadbeef", + "--skip-submit", complain_on_error=False) assert_match(f".*Origin is hosted on unknown site: {domain}.*", p.out) diff --git a/testsuite/tests/publish/local-repo-branched/test.py b/testsuite/tests/publish/local-repo-branched/test.py index 0ac7c46a..00eb44f7 100644 --- a/testsuite/tests/publish/local-repo-branched/test.py +++ b/testsuite/tests/publish/local-repo-branched/test.py @@ -29,6 +29,6 @@ assert run(["git", "commit", "-m", "commit-msg"]).returncode == 0 assert run(["git", "push", "-u", "origin", "devel"]).returncode == 0 # Check that the publishing assistant completes without complaining -run_alr("--force", "publish") +run_alr("--force", "publish", "--skip-submit") print('SUCCESS') diff --git a/testsuite/tests/publish/local-repo-nonstd/test.py b/testsuite/tests/publish/local-repo-nonstd/test.py index 239a1413..759050dc 100644 --- a/testsuite/tests/publish/local-repo-nonstd/test.py +++ b/testsuite/tests/publish/local-repo-nonstd/test.py @@ -33,20 +33,20 @@ assert run(["git", "config", "user.email", "alr@testing.com"]).returncode == 0 assert run(["git", "config", "user.name", "Alire Testsuite"]).returncode == 0 # Tests with different default arguments that must all succeed -run_alr("--force", "publish", "--manifest", "xxx.toml") +run_alr("--force", "publish", "--skip-submit", "--manifest", "xxx.toml") verify_manifest() -run_alr("--force", "publish", ".", "--manifest", "xxx.toml") +run_alr("--force", "publish", "--skip-submit", ".", "--manifest", "xxx.toml") verify_manifest() -run_alr("--force", "publish", ".", "master", "--manifest", "xxx.toml") +run_alr("--force", "publish", "--skip-submit", ".", "master", "--manifest", "xxx.toml") verify_manifest() -run_alr("--force", "publish", ".", "HEAD", "--manifest", "xxx.toml") +run_alr("--force", "publish", "--skip-submit", ".", "HEAD", "--manifest", "xxx.toml") verify_manifest() # Test that not setting the custom manifest results in failure -p = run_alr("--force", "publish", complain_on_error=False) +p = run_alr("--force", "publish", "--skip-submit", complain_on_error=False) assert_match(".*No Alire workspace found.*", p.out) print('SUCCESS') diff --git a/testsuite/tests/publish/local-repo/test.py b/testsuite/tests/publish/local-repo/test.py index 63dc87e4..009a73db 100644 --- a/testsuite/tests/publish/local-repo/test.py +++ b/testsuite/tests/publish/local-repo/test.py @@ -31,16 +31,16 @@ assert run(["git", "config", "user.email", "alr@testing.com"]).returncode == 0 assert run(["git", "config", "user.name", "Alire Testsuite"]).returncode == 0 # Tests with different default arguments that must all succeed -run_alr("--force", "publish") +run_alr("--force", "publish", "--skip-submit") verify_manifest() -run_alr("--force", "publish", ".") +run_alr("--force", "publish", "--skip-submit", ".") verify_manifest() -run_alr("--force", "publish", ".", "master") +run_alr("--force", "publish", "--skip-submit", ".", "master") verify_manifest() -run_alr("--force", "publish", ".", "HEAD") +run_alr("--force", "publish", "--skip-submit", ".", "HEAD") verify_manifest() # Verify that a dirty repo precludes publishing @@ -49,13 +49,13 @@ with open("lasagna", "wt") as file: assert run(["git", "add", "lasagna"]).returncode == 0 -p = run_alr("--force", "publish", complain_on_error=False) +p = run_alr("--force", "publish", "--skip-submit", complain_on_error=False) assert_match(".*You have unstaged changes.*", p.out) # Even if changes are committed but not pushed assert run(["git", "add", "."]).returncode == 0 assert run(["git", "commit", "-a", "-m", "please"]).returncode == 0 -p = run_alr("--force", "publish", complain_on_error=False) +p = run_alr("--force", "publish", "--skip-submit", complain_on_error=False) assert_match(".*Your branch is ahead of remote.*", p.out) print('SUCCESS') diff --git a/testsuite/tests/publish/pin-removal/test.py b/testsuite/tests/publish/pin-removal/test.py index 879cfb04..9956fdad 100644 --- a/testsuite/tests/publish/pin-removal/test.py +++ b/testsuite/tests/publish/pin-removal/test.py @@ -38,7 +38,7 @@ assert_match(".*\[\[pins\]\].*", content_of(alr_manifest())) # We publish with the pin in the manifest p = alr_publish(crate, "0.1.0-dev", index_path=os.path.join(start_dir, "my_index"), - submit=False, + copy_to_index=False, quiet=False) # Verify warning during publishing diff --git a/testsuite/tests/publish/remote-origin-nonstd/test.py b/testsuite/tests/publish/remote-origin-nonstd/test.py index 13f874e0..f891f7e8 100644 --- a/testsuite/tests/publish/remote-origin-nonstd/test.py +++ b/testsuite/tests/publish/remote-origin-nonstd/test.py @@ -39,7 +39,7 @@ head_commit = init_git_repo("xxx") # A "remote" source archive. We force to allow the test to skip the remote # check. Curl requires an absolute path to work. target = os.path.join(os.getcwd(), "xxx.zip") -run_alr("publish", f"file:{target}", "--manifest", "xxx.toml", force=True) +run_alr("publish", "--skip-submit", f"file:{target}", "--manifest", "xxx.toml", force=True) # Should complete without error, check the generated file is in place verify_manifest() @@ -48,7 +48,7 @@ rmtree("alire") # Same test, using directly the source repository target = os.path.join(os.getcwd(), "xxx") -run_alr("publish", f"git+file:{target}", head_commit, +run_alr("publish", "--skip-submit", f"git+file:{target}", head_commit, "--manifest", "xxx.toml", force=True) verify_manifest() diff --git a/testsuite/tests/publish/remote-origin/test.py b/testsuite/tests/publish/remote-origin/test.py index 9c2e69af..0e87ece0 100644 --- a/testsuite/tests/publish/remote-origin/test.py +++ b/testsuite/tests/publish/remote-origin/test.py @@ -37,7 +37,7 @@ head_commit = init_git_repo("xxx") # A "remote" source archive. We force to allow the test to skip the remote # check. Curl requires an absolute path to work. target = os.path.join(os.getcwd(), "xxx.zip") -run_alr("publish", f"file:{target}", force=True) +run_alr("publish", f"file:{target}", "--skip-submit", force=True) # Should complete without error, check the generated file is in place verify_manifest() @@ -46,7 +46,7 @@ rmtree("alire") # Same test, using directly the source repository target = os.path.join(os.getcwd(), "xxx") -run_alr("publish", f"git+file:{target}", head_commit, force=True) +run_alr("publish", f"git+file:{target}", head_commit, "--skip-submit", force=True) verify_manifest() # Copy the new index manifest into the index diff --git a/testsuite/tests/publish/tarball-plaindir-nonstd/test.py b/testsuite/tests/publish/tarball-plaindir-nonstd/test.py index e2c61a29..b6730ec5 100644 --- a/testsuite/tests/publish/tarball-plaindir-nonstd/test.py +++ b/testsuite/tests/publish/tarball-plaindir-nonstd/test.py @@ -24,7 +24,7 @@ with open(os.path.join("alire", canary), "wt") as file: # Publish it. We need to give input to alr, so we directly call it. We use the # generated location as the "online" location, and this works because we are # forcing. -p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--tar", +p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--skip-submit", "--tar", "--manifest", "xxx.toml"], input=f"file:{os.getcwd()}/alire/archives/xxx-0.1.0-dev.tbz2\n".encode()) p.check_returncode() diff --git a/testsuite/tests/publish/tarball-plaindir/test.py b/testsuite/tests/publish/tarball-plaindir/test.py index 863b929c..4716e102 100644 --- a/testsuite/tests/publish/tarball-plaindir/test.py +++ b/testsuite/tests/publish/tarball-plaindir/test.py @@ -22,7 +22,7 @@ with open(os.path.join("alire", canary), "wt") as file: # Publish it. We need to give input to alr, so we directly call it. We use the # generated location as the "online" location, and this works because we are # forcing. -p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--tar"], +p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--skip-submit", "--tar"], input=f"file:{os.getcwd()}/alire/archives/xxx-0.1.0-dev.tbz2\n".encode()) p.check_returncode() diff --git a/testsuite/tests/publish/tarball-repo-nonstd/test.py b/testsuite/tests/publish/tarball-repo-nonstd/test.py index 4e99b4f0..ad482832 100644 --- a/testsuite/tests/publish/tarball-repo-nonstd/test.py +++ b/testsuite/tests/publish/tarball-repo-nonstd/test.py @@ -25,7 +25,7 @@ os.chdir("xxx") # Publish it. We need to give input to alr, so we directly call it. We use the # generated location as the "online" location, and this works because we are # forcing. ".tgz" is used, as bzip2 is not supported by `git archive`. -p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--tar", +p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--skip-submit", "--tar", "--manifest", "xxx.toml"], input=f"file:{os.getcwd()}/alire/archives/xxx-0.1.0-dev.tgz\n".encode()) p.check_returncode() diff --git a/testsuite/tests/publish/tarball-repo/test.py b/testsuite/tests/publish/tarball-repo/test.py index 4d86f346..2dc953bc 100644 --- a/testsuite/tests/publish/tarball-repo/test.py +++ b/testsuite/tests/publish/tarball-repo/test.py @@ -24,7 +24,7 @@ os.chdir("xxx") # Publish it. We need to give input to alr, so we directly call it. We use the # generated location as the "online" location, and this works because we are # forcing. ".tgz" is used, as bzip2 is not supported by `git archive`. -p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--tar"], +p = run(["alr", "-q", "-f", "-n", "publish", "--skip-build", "--skip-submit", "--tar"], input=f"file:{os.getcwd()}/alire/archives/xxx-0.1.0-dev.tgz\n".encode()) p.check_returncode() -- 2.39.5