Create tarball from Alire workspace (#529)

* Create tarball from alire workspace

* Tests for tarball creation

* Code review fixes

* Workaround for macOS BSD tar

* Document `alr publish --tar` changes.

* Fix tar regular expr and improve related test

It seems GNAT's Normalize_Arguments does its own escaping, so we do not need to
do it ourselves. Also, the test checks that indeed the `alire` folder is
excluded when tar'ing manually.

doc/publishing.md

@@ -165,8 +165,15 @@ URL to do so.
 
 ### Starting with a local source folder
 
-Assisting with the creation and upload of a source archive from local sources, as
-a pre-step to the case just presented, is in the roadmap.
+Invoking `alr publish --tar` inside an Alire workspace will result in the
+creation of a source archive at `${CRATE_ROOT}/alire/archives/`. This archive
+must be manually uploaded (for now) by the user to a publicly accessible
+hosting service.
+
+After the upload, the user can supply the URL to fetch this archive to the
+publishing assistant (which will be waiting for this information), and the
+assistant will resume as if it had been invoked with `alr publish <URL>`
+(see #starting-with-a-remote-source-archive).
 
 ### Support for complex projects whose sources become multiple Alire crates
 

doc/user-changes.md

@@ -4,6 +4,15 @@ This document is a development diary summarizing changes in `alr` that notably
 affect the user experience. It is intended as a one-stop point for users to
 stay on top of `alr` new features.
 
+### Assistance to generate and publish as tarball
+
+PR [#529](https://github.com/alire-project/alire/pull/529).
+
+By using `alr publish --tar`, the publishing assistant starts with the
+creation of a tarball of the sources in an Alire workspace. The user must
+upload this tarball to an online location, after which the assistant proceeds
+as if it had been invoked with `alr publish http[s]://url/to/tarball.tgz`.
+
 ### First publishing assistant
 
 PR [#527](https://github.com/alire-project/alire/pull/527).

src/alire/alire-directories.adb

@@ -61,6 +61,10 @@ package body Alire.Directories is
                                 else File & ".prev");
    begin
       if Exists (File) then
+         if not Exists (Base_Dir) then
+            Create_Directory (Base_Dir);
+         end if;
+
          Trace.Debug ("Backing up " & File
                       & " with base dir: " & Base_Dir);
          Copy_File (File, Dst, "mode=overwrite");

src/alire/alire-publish.adb

@@ -24,6 +24,8 @@ with Alire.Utils.TTY;
 with Alire.Utils.User_Input;
 with Alire.VCSs.Git;
 
+with GNATCOLL.OS.Constants;
+
 with Semantic_Versioning;
 
 with TOML.File_IO;
@@ -48,10 +50,52 @@ package body Alire.Publish is
       Origin : Origins.Origin := Origins.New_External ("undefined");
       --  We use external as "undefined" until a proper origin is provided.
 
+      Revision : UString := +"HEAD";
+      --  A particular revision for publishing from a git repo
+
+      Root   : Roots.Optional.Root;
+      --  Some steps require or can use a detected root
+
       Tmp_Deploy_Dir : Directories.Temp_File;
       --  Place to check the sources
    end record;
 
+   ---------------
+   -- Git_Error --
+   ---------------
+
+   procedure Git_Error (Msg : String; Path : Any_Path) is
+   begin
+      if Path /= "." then
+         Raise_Checked_Error (TTY.URL (Path) & ": " & Msg);
+      else
+         Raise_Checked_Error (Msg);
+      end if;
+   end Git_Error;
+
+   ---------------------
+   -- Check_Git_Clean --
+   ---------------------
+
+   procedure Check_Git_Clean (Path : Any_Path) is
+      use all type VCSs.Git.States;
+      Git  : constant VCSs.Git.VCS := VCSs.Git.Handler;
+   begin
+      case Git.Status (Path) is
+         when Clean =>
+            Log_Success ("Local repository is clean.");
+         when Ahead =>
+            Git_Error ("Your branch is ahead of remote" & ASCII.LF &
+                         "Please push local commits to the remote branch.",
+                       Path);
+         when Dirty =>
+            Git_Error (TTY.Emph ("git status") &
+                         " You have unstaged changes. " &
+                         "Please commit or stash them.",
+                       Path);
+      end case;
+   end Check_Git_Clean;
+
    -----------------
    -- STEP BODIES --
    -----------------
@@ -227,6 +271,166 @@ package body Alire.Publish is
       end;
    end Generate_Index_Manifest;
 
+   ---------------------
+   -- Prepare_Archive --
+   ---------------------
+
+   procedure Prepare_Archive (Context : in out Data) with
+     Pre => Context.Root.Is_Valid;
+
+   procedure Prepare_Archive (Context : in out Data) is
+      use Utils;
+      Target_Dir : constant Relative_Path :=
+                     Paths.Working_Folder_Inside_Root / "archives";
+      Root       : Roots.Root renames Context.Root.Value;
+      Milestone  : constant String :=
+                     TOML_Index.Manifest_File (Root.Release.Name,
+                                               Root.Release.Version,
+                                               With_Extension => False);
+      Git        : constant VCSs.Git.VCS := VCSs.Git.Handler;
+      Is_Repo    : constant Boolean := Git.Is_Repository (Root.Path);
+      Archive    : constant Relative_Path :=
+                     Target_Dir
+                       / (Milestone
+                          & (if Is_Repo
+                             then ".tgz"
+                             else ".tbz2"));
+      use Utils.User_Input;
+
+      -----------------
+      -- Git_Archive --
+      -----------------
+
+      procedure Git_Archive is
+      begin
+         OS_Lib.Subprocess.Checked_Spawn
+           ("git",
+            Empty_Vector
+            & "archive"
+            & "-o" & Archive
+            --  Destination file at alire/archives/crate-version.tar.gz
+
+            & String'("--prefix=" & Milestone & "/")
+            --  Prepend empty milestone dir name as required for our tars
+
+            & (+Context.Revision));
+      end Git_Archive;
+
+      -----------------
+      -- Tar_Archive --
+      -----------------
+
+      procedure Tar_Archive is
+      begin
+         pragma Warnings (Off, "condition is always");
+         --  To silence our below check for macOS
+
+         OS_Lib.Subprocess.Checked_Spawn
+           ("tar",
+            Empty_Vector
+            & "cfj"
+            & Archive --  Destination file at alire/archives/crate-version.tbz2
+
+            & String'("--exclude=./alire")
+            --  Exclude top-level alire folder, before applying prefix
+
+            --  exclude .git and the like, with workaround for macOS bsd tar
+            & (if GNATCOLL.OS.Constants.OS in GNATCOLL.OS.MacOS
+               then Empty_Vector
+                    & "--exclude=./.git"
+                    & "--exclude=./.hg"
+                    & "--exclude=./.svn"
+                    & String'("-s,^./," & Milestone & "/,")
+                    --  Prepend empty milestone dir as required for our tars)
+              else Empty_Vector
+                    & "--exclude-backups"      -- exclude .#* *~ #*# patterns
+                    & "--exclude-vcs"          -- exclude .git, .hg, etc
+                    & "--exclude-vcs-ignores"  -- exclude from .gitignore, etc
+                    & String'("--transform=s,^./," & Milestone & "/,"))
+                    --  Prepend empty milestone dir as required for our tars
+
+            & ".");
+         pragma Warnings (On);
+      end Tar_Archive;
+
+   begin
+      if Is_Repo then
+         Check_Git_Clean (Root.Path);
+      else
+         Trace.Warning ("Not in a git repository, assuming plain sources.");
+      end if;
+
+      --  Create a tarball with our required nested structure, and excluding
+      --  the alire folder and our own temporary.
+
+      if not Ada.Directories.Exists (Target_Dir) then
+         Ada.Directories.Create_Path (Target_Dir);
+      end if;
+
+      if Is_Repo then
+         Git_Archive;
+      else
+         Tar_Archive;
+      end if;
+
+      Log_Success ("Source archive created successfully.");
+
+      declare
+
+         --------------
+         -- Is_Valid --
+         --------------
+
+         function Is_Valid (Remote_URL : String) return Boolean is
+         begin
+            Trace.Always ("");
+            Trace.Always ("The URL is: " & TTY.URL (Remote_URL));
+
+            Context.Origin := Origins.New_Source_Archive
+              (Remote_URL,
+               Ada.Directories.Simple_Name (Archive));
+            --  This origin creation may raise if URL is improper
+
+            return True;
+         exception
+            when E : others =>
+               Errors.Pretty_Print
+                 (Errors.Wrap
+                    ("The URL does not seem to be valid:",
+                     Errors.Get (E)));
+               return False;
+         end Is_Valid;
+
+         -----------------
+         -- Get_Default --
+         -----------------
+
+         function Get_Default (Remote_URL : String)
+                               return User_Input.Answer_Kind
+         is (if Force or else URI.Scheme (Remote_URL) in URI.HTTP
+             then Yes
+             else No);
+
+         --  We don't use the following answer because the validation function
+         --  already stores the information we need.
+
+         Unused : constant User_Input.Answer_With_Input :=
+                    User_Input.Validated_Input
+                      (Question =>
+                          "Please upload the archive generated"
+                          & " at " & TTY.URL (Archive)
+                          & " to its definitive online storage location."
+                          & ASCII.LF
+                          & "Once you have uploaded the file, enter its URL:",
+                       Prompt   => "Enter URL> ",
+                       Valid    => (Yes | No => True, others => False),
+                       Default  => Get_Default'Access,
+                       Is_Valid => Is_Valid'Access);
+      begin
+         null; -- Nothing to do, everything happens at Answer_With_Input
+      end;
+   end Prepare_Archive;
+
    ----------------------
    -- Show_And_Confirm --
    ----------------------
@@ -377,21 +581,24 @@ package body Alire.Publish is
 
    --  Step names must be in order of execution:
    type Step_Names is
-     (Step_Verify_Origin,
+     (Step_Prepare_Archive,
+      Step_Verify_Origin,
       Step_Deploy_Sources,
       Step_Check_Build,
       Step_Show_And_Confirm,
       Step_Generate_Index_Manifest);
 
    Steps : constant array (Step_Names) of Step_Subprogram :=
-             (Step_Verify_Origin           => Verify_Origin'Access,
+             (Step_Prepare_Archive         => Prepare_Archive'Access,
+              Step_Verify_Origin           => Verify_Origin'Access,
               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);
 
    function Step_Description (Step : Step_Names) return String
    is (case Step is
+          when Step_Prepare_Archive         => "Prepare remote source archive",
           when Step_Verify_Origin           => "Verify origin URL",
           when Step_Deploy_Sources          => "Deploy sources",
           when Step_Check_Build             => "Build release",
@@ -422,6 +629,31 @@ package body Alire.Publish is
       end loop;
    end Start_At;
 
+   -------------------
+   -- Directory_Tar --
+   -------------------
+
+   procedure Directory_Tar (Path     : Any_Path := ".";
+                            Revision : String   := "HEAD";
+                            Options  : All_Options := (others => <>))
+   is
+      Context : Data :=
+                  (Options        => Options,
+                   Origin         => <>,
+                   Revision       => +Revision,
+                   Root           =>
+                     Roots.Optional.Search_Root (Path),
+                   Tmp_Deploy_Dir => <>);
+
+      Guard   : Directories.Guard (Directories.Enter (Context.Root.Value.Path))
+        with Unreferenced;
+   begin
+      --  TODO: start with filling-in/checking the local manifest. For now,
+      --  start directly with the archive creation.
+
+      Start_At (Step_Prepare_Archive, Context);
+   end Directory_Tar;
+
    ----------------------
    -- Local_Repository --
    ----------------------
@@ -431,44 +663,20 @@ package body Alire.Publish is
                                Options  : All_Options := (others => <>))
    is
       Root : constant Roots.Optional.Root := Roots.Optional.Search_Root (Path);
-      use all type VCSs.Git.States;
       Git  : constant VCSs.Git.VCS := VCSs.Git.Handler;
 
-      ---------------
-      -- Git_Error --
-      ---------------
-
-      procedure Git_Error (Msg : String) is
-      begin
-         if Path /= "." then
-            Raise_Checked_Error (TTY.URL (Path) & ": " & Msg);
-         else
-            Raise_Checked_Error (Msg);
-         end if;
-      end Git_Error;
-
    begin
       if not Root.Is_Valid then
          Raise_Checked_Error ("No Alire workspace found at " & TTY.URL (Path));
       end if;
 
       if not Git.Is_Repository (Root.Value.Path) then
-         Git_Error ("no git repository found");
+         Git_Error ("no git repository found", Root.Value.Path);
       end if;
 
       --  Do not continue if the local repo is dirty
 
-      case Git.Status (Root.Value.Path) is
-         when Clean =>
-            Log_Success ("Local repository is clean.");
-         when Ahead =>
-            Git_Error ("Your branch is ahead of remote" & ASCII.LF &
-                         "Please push local commits to the remove branch.");
-         when Dirty =>
-            Git_Error (TTY.Emph ("git status") &
-                         " You have unstaged changes. " &
-                         "Please commit or stash them.");
-      end case;
+      Check_Git_Clean (Root.Value.Path);
 
       --  If given a revision, extract commit and verify it exists locally
 
@@ -569,6 +777,10 @@ package body Alire.Publish is
                          else
                             Origins.New_Source_Archive (URL)),
 
+                      Revision => +Commit,
+
+                      Root => <>, -- Invalid root, as we are working remotely
+
                       Tmp_Deploy_Dir => <>);
       begin
          Start_At (Step_Verify_Origin, Context);