feat: improve URI recognition (#1736)

* Improve origin URI recognition

- Consolidate a number of separate ad hoc tests for recognising URIs into Alire.URI.URI_Kind
- Add support for origin URLs with scheme "ssh://"
- Add bitbucket.org to the list of hosts recognised as git only
- Treat ".git/" suffix the same as ".git"
- Change publish command to raise errors on URLs with "file:" scheme (sidestepping a bug where the whole URL was treated as a relative path)
- Change various error messages
- Change handling of some obscure edge cases

* Fix source archives hosted on GitHub or similar

* Fix test when ssh command is unavailable

* Workaround for GNAT 10 bug

* Further improve URI recognition

* Fix existing test

* Add test for local indexes

* Add test for 'clean --cache' command

* Fix on Windows

* Fix on MacOS

* Clean up local-index-not-found test

* Consolidate 'Host' implementations

* Fix Fragment for local URLs

* Fix test

* Improve publishing test

* Fix documentation

* Remove redundant test

* Fix tests

* Fix typos

* Switch to US English

* Use crate_dirname

* Use less fragile test for git failure

* Add clarifying comments

* Treat http with non-empty userinfo as private

* Fix typo

doc/catalog-format-spec.md

@@ -447,6 +447,13 @@ static, i.e. they cannot depend on the context.
    the following fields:
 
       - `url`: mandatory string which points to a source file or repository.
+        If it points to a repository, this should be apparent from the URL;
+        the prefixes `git+`, `hg+` or `svn+` can be prepended to the scheme
+        (e.g. `git+https://`) to make this explicit, though a `.git` suffix or
+        the hosts `github.com`, `gitlab.com` or `bitbucket.org` will also be
+        recognized. For crates submitted to the community index, origins should
+        be publicly accessible (i.e. should not require private ssh keys or
+        other authentication).
 
       - `hashes`: mandatory string array for source archives.  An array
         of "kind:digest" fields that specify a hash kind and its value.  Kinds
@@ -466,7 +473,7 @@ static, i.e. they cannot depend on the context.
         several crates from the same repository (sometimes referred to as a
         *monorepo*).
 
-      - `binary`: optional (defauts to false) boolean used to design the origin
+      - `binary`: optional (defaults to false) boolean used to design the origin
         as binary. Binary origins are not compiled and can optionally use dynamic
         expressions to narrow down the platform to which they apply. An origin
         using a dynamic expression must be tagged as binary; see the

src/alire/alire-index_on_disk-directory.adb

@@ -6,8 +6,7 @@ package body Alire.Index_On_Disk.Directory is
 
    overriding
    function Index_Directory (This : Index) return String
-   is (This.Origin
-       (This.Origin'First + File_Prefix'Length .. This.Origin'Last));
+   is (URI.Local_Path (This.Origin));
 
    -----------------
    -- New_Handler --

src/alire/alire-index_on_disk-directory.ads

@@ -1,3 +1,5 @@
+with Alire.URI;
+
 package Alire.Index_On_Disk.Directory is
 
    --  A local index that is taken from a local filesystem path
@@ -8,18 +10,17 @@ package Alire.Index_On_Disk.Directory is
    function New_Handler (From   : URL;
                          Name   : Restricted_Name;
                          Parent : Any_Path) return Index with
-     Pre => AAA.Strings.Has_Prefix (From, "file://")
-              and then
-            Check_Absolute_Path (From (From'First + 7 .. From'Last));
-   --  file:// + absolute path
+     Pre => Alire.URI.URI_Kind (From) in Alire.URI.File
+       and then Check_Absolute_Path (Alire.URI.Local_Path (From));
+   --  From must be a "file:" URL with an absolute path
 
    overriding
    function Add (This : Index) return Outcome is (Outcome_Success);
    --  Nothing to do because general checks are done in Features.Index.Add
 
    overriding
    function Index_Directory (This : Index) return String;
-   --  A file:// index is already on disk, so we reuse its path
+   --  A "file:" index is already on disk, so we reuse its path
 
    overriding
    function Update (This : Index) return Outcome is (Outcome_Success);

src/alire/alire-index_on_disk-git.adb

@@ -7,9 +7,11 @@ package body Alire.Index_On_Disk.Git is
    ---------
 
    overriding
-   function Add (This : Index) return Outcome is
-     (VCSs.Git.Handler.Clone
-        (VCSs.Repo_And_Commit (This.Origin), This.Index_Directory));
+   function Add (This : Index) return Outcome
+   is (VCSs.Git.Handler.Clone
+         (VCSs.Repo_URL (This.Origin),
+          This.Index_Directory,
+          VCSs.Commit (This.Origin)));
 
    -----------------
    -- New_Handler --

src/alire/alire-index_on_disk-git.ads

@@ -1,3 +1,5 @@
+with Alire.URI;
+
 package Alire.Index_On_Disk.Git is
 
    --  Local management of remote indexes stored in git repositories
@@ -8,8 +10,7 @@ package Alire.Index_On_Disk.Git is
    function New_Handler (Origin : URL;
                          Name   : Restricted_Name;
                          Parent : Any_Path) return Index with
-     Pre => AAA.Strings.Has_Prefix (Origin, "git+") or else
-            AAA.Strings.Has_Prefix (Origin, "git@");
+     Pre => URI.URI_Kind (Origin) in URI.Git_URIs;
 
    overriding
    function Add (This : Index) return Outcome;

src/alire/alire-index_on_disk.adb

@@ -8,7 +8,7 @@ with Alire.Index_On_Disk.Git;
 with Alire.Index_On_Disk.Loading;
 with Alire.TOML_Index;
 with Alire.TOML_Keys;
-with Alire.VCSs;
+with Alire.URI;
 
 with GNAT.OS_Lib;
 
@@ -158,95 +158,100 @@ package body Alire.Index_On_Disk is
                          Priority :     Priorities := Default_Priority)
                          return Index'Class
    is
-      function Process_Local_Index (Path : String) return Index'Class;
-      --  Check that Path designates a readable directory and create the
-      --  corresponding index handler for it. If something goes wrong, set
-      --  Result to contain the corresponding error message and return
-      --  New_Invalid_Index.
+      Origin_Kind : constant URI.URI_Kinds := URI.URI_Kind (Origin);
 
-      -------------------------
-      -- Process_Local_Index --
-      -------------------------
+      function Abs_Path (This : String) return String;
+      --  Return the absolute path to which a local origin path/URL points
 
-      function Process_Local_Index (Path : String) return Index'Class is
+      function Is_Valid_Local_Origin (Path : String) return Boolean;
+      --  Return whether Path designates a readable directory suitable for an
+      --  index origin (i.e. not inside Alire's config path). If something goes
+      --  wrong, set Result to contain the corresponding error message.
+
+      --------------
+      -- Abs_Path --
+      --------------
+
+      function Abs_Path (This : String) return String
+      is (Ada.Directories.Full_Name (URI.Local_Path (Origin)));
+
+      ---------------------------
+      -- Is_Valid_Local_Origin --
+      ---------------------------
+
+      function Is_Valid_Local_Origin (Path : String) return Boolean is
          use GNATCOLL.VFS;
          Dir : constant Virtual_File := Create (+Path);
       begin
+         --  Ensure the path exists and is a directory
+
          if not Dir.Is_Directory then
             Result := Outcome_Failure ("Not a readable directory: " & Path);
-            return New_Invalid_Index;
+            return False;
          end if;
 
          --  Ensure the given path is not one of our own configured indexes
 
          if AAA.Strings.Has_Prefix (Path, Parent) then
             Result := Outcome_Failure
               ("Given index path is inside Alire configuration path");
-            return New_Invalid_Index;
+            return False;
          end if;
 
-         --  Ensure the created Index wrapper has absolute path
-
-         Result := Outcome_Success;
-         return Directory.New_Handler
-           (File_Prefix & Ada.Directories.Full_Name (Path),
-            Name,
-            Parent).With_Priority (Priority);
-      end Process_Local_Index;
+         return True;
+      end Is_Valid_Local_Origin;
 
    begin
       if not Is_Valid_Name (Name) then
          Result := Outcome_Failure (Error_In_Name (Name));
          return New_Invalid_Index;
       end if;
 
-      --  Warn about http[s]:// URLs being not supported and suggest git+http
-      --  instead.
-
-      if AAA.Strings.Has_Prefix (Origin, HTTP_Prefix) then
-         Result := Outcome_Failure
-           ("HTTP/HTTPS URLs are not valid index origins. "
-            & "You may want git+" & Origin & " instead.");
-         return New_Invalid_Index;
-      end if;
-
-      --  Process "file://" URLs and anything that looks like a file name as a
-      --  local index.
-
-      if AAA.Strings.Has_Prefix (Origin, File_Prefix) then
-         return Process_Local_Index
-           (Origin (Origin'First + File_Prefix'Length ..  Origin'Last));
-      elsif Origin (Origin'First) = '/'
-        or else not (AAA.Strings.Contains (Origin, "@")
-                     or else AAA.Strings.Contains (Origin, "+"))
+      if Origin_Kind in URI.Local_URIs
+        and then not Is_Valid_Local_Origin (URI.Local_Path (Origin))
       then
-         return Process_Local_Index (Origin);
-      end if;
-
-      --  Process "git+ssh://" as git over ssh and suggest for "ssh://"
-
-      if AAA.Strings.Has_Prefix (Origin, SSH_Prefix) then
-         Result := Outcome_Failure
-           ("ssh:// URLs are not valid index origins. "
-            & "You may want git+" & Origin & " instead.");
+         --  Result is already set to Outcome_Failure by Is_Valid_Local_Origin
          return New_Invalid_Index;
-      elsif AAA.Strings.Has_Prefix (Origin, "git+" & SSH_Prefix) then
-         Result := Outcome_Success;
-         return Index_On_Disk.Git
-           .New_Handler (Origin, Name, Parent)
-           .With_Priority (Priority);
       end if;
 
-      --  Process other paths as VCSs
-
-      case VCSs.Kind (Origin) is
-         when VCSs.VCS_Git =>
+      case Origin_Kind is
+         when URI.Local_Other =>
+            --  Process path or "file:" URL as a local index.
             Result := Outcome_Success;
-            return Index_On_Disk.Git.New_Handler (Origin, Name, Parent)
-                                    .With_Priority (Priority);
-         when VCSs.VCS_Unknown =>
+            return Index_On_Disk.Directory.New_Handler
+                     (URI.To_URL (Abs_Path (Origin)), Name, Parent)
+                     .With_Priority (Priority);
+
+         when URI.Git_URIs =>
+            --  A recognized Git repo; create a clone in the config directory.
+            declare
+               --  Ensure `git+file:` origin is an absolute path
+               From : constant String :=
+                 (if Origin_Kind in URI.Local_Git
+                  then URI.Make_VCS_Explicit (Abs_Path (Origin), URI.Git)
+                  else Origin);
+            begin
+               Result := Outcome_Success;
+               return Index_On_Disk.Git.New_Handler (From, Name, Parent)
+                                       .With_Priority (Priority);
+            end;
+
+         when URI.Hg_URIs | URI.SVN_URIs =>
+            --  Other VCSs are not currently supported.
             Result := Outcome_Failure ("Unknown index kind: " & Origin);
             return New_Invalid_Index;
+
+         when URI.HTTP_Other | URI.SSH_Other =>
+            --  Warn that URL is not recognized and suggest 'git+http' or
+            --  'git+ssh' instead.
+            Result := Outcome_Failure
+              ("Unrecognized index URL. Did you mean 'git+"
+               & Origin & "' instead?");
+            return New_Invalid_Index;
+
+         when others =>
+            Result := Outcome_Failure ("Unrecognized index URL: " & Origin);
+            return New_Invalid_Index;
       end case;
    end New_Handler;
 

src/alire/alire-index_on_disk.ads

@@ -13,17 +13,14 @@ package Alire.Index_On_Disk is
    --  Index metadata are stored in the <config>/indexes/<unique_id>/index.toml
    --  Actual index is stored in <config>/indexes/<name>/repo
 
-   --  URLs given to New_Handler functions must be complete, commit optional:
+   --  URLs given to New_Handler functions must be complete, optionally with a
+   --  commit (except for 'file:' URLs, where path can contain literal '#'):
    --  E.g.: git+https://path/to/server/and/project[#commit]
-   --  E.g.: file:///path/to/local/folder
+   --  E.g.: file:/path/to/local/folder
 
    Checkout_Directory : constant String := "repo";
    Metadata_Filename  : constant String := "index.toml";
 
-   File_Prefix        : constant String := "file://";
-   HTTP_Prefix        : constant String := "http";
-   SSH_Prefix         : constant String := "ssh://";
-
    subtype Priorities is Integer; -- Lower is loaded before
 
    Default_Priority   : constant := 1;

src/alire/alire-origins-deployers-git.adb

@@ -13,7 +13,7 @@ package body Alire.Origins.Deployers.Git is
    overriding
    function Deploy (This : Deployer; Folder : String) return Outcome is
    begin
-      VCSs.Git.Handler.Clone (This.Base.URL_With_Commit, Folder).Assert;
+      VCSs.Git.Handler.Clone (This.Base.URL, Folder, This.Base.Commit).Assert;
 
       if Settings.Builtins.Dependencies_Git_Keep_Repository.Get then
 

src/alire/alire-origins-deployers-hg.adb

@@ -9,7 +9,7 @@ package body Alire.Origins.Deployers.Hg is
    overriding
    function Deploy (This : Deployer; Folder : String) return Outcome is
    begin
-      return VCSs.Hg.Handler.Clone (This.Base.URL_With_Commit, Folder);
+      return VCSs.Hg.Handler.Clone (This.Base.URL, Folder, This.Base.Commit);
    end Deploy;
 
    -----------

src/alire/alire-origins-deployers-source_archive.adb

@@ -138,7 +138,7 @@ package body Alire.Origins.Deployers.Source_Archive is
       --  linux also for local files, something funny is going on Windows which
       --  is difficult to pinpoint.
 
-      if URI.Scheme (This.Base.Archive_URL) in URI.File_Schemes then
+      if URI.URI_Kind (This.Base.Archive_URL) in URI.Local_Other then
          if not Dirs.Exists (Folder) then
             Alire.Directories.Create_Tree (Folder);
          end if;

src/alire/alire-origins-deployers-svn.adb

@@ -9,7 +9,7 @@ package body Alire.Origins.Deployers.SVN is
    overriding
    function Deploy (This : Deployer; Folder : String) return Outcome is
    begin
-      return VCSs.SVN.Handler.Clone (This.Base.URL_With_Commit, Folder);
+      return VCSs.SVN.Handler.Clone (This.Base.URL, Folder, This.Base.Commit);
    end Deploy;
 
    -----------

src/alire/alire-origins-tweaks.adb

@@ -37,10 +37,10 @@ package body Alire.Origins.Tweaks is
 
       function Fix_VCS return Origin is
          use Ada.Directories;
-         URL : constant String := This.URL; -- Doesn't include #commit
+         URL : constant String := This.URL;
       begin
-         --  Check for "xxx+file://" or return as-is:
-         if URI.Scheme (URL) not in URI.File_Schemes then
+         --  Return as-is unless local path:
+         if URI.URI_Kind (URL) not in URI.Local_URIs then
             return This;
          end if;
 
@@ -55,7 +55,7 @@ package body Alire.Origins.Tweaks is
 
             --  Rebuild the filesystem path as absolute for the VCS in hand:
             Absolute.Data.Repo_URL := + -- Unbounded string
-              (Prefix_File & Full_Name (TOML_Path / Rel_Path));
+              (Full_Name (TOML_Path / Rel_Path));
 
             return Absolute;
          end;