Merge pull request #365 from Leonidas-from-XIV/canonical-url

Normalize Github URLs before comparing

CHANGES.md

@@ -10,6 +10,10 @@
 
 ### Changed
 
+- Canonicalize the URLs of the OPAM `dev-repo` fields to be able to detect more
+  semantically equivalent URLs, this should reduce the risk of build failures
+  due to duplicate code pulled (#118, #365 @TheLortex, @Leonidas-from-XIV)
+
 ### Deprecated
 
 ### Fixed

lib/duniverse.ml

@@ -53,16 +53,25 @@ module Repo = struct
   end
 
   module Package = struct
+    module Dev_repo = struct
+      type t = string
+
+      let equal a b =
+        let a = a |> Uri.of_string |> Uri_utils.Normalized.of_uri in
+        let b = b |> Uri.of_string |> Uri_utils.Normalized.of_uri in
+        Uri_utils.Normalized.equal a b
+    end
+
     type t = {
       opam : OpamPackage.t;
-      dev_repo : string;
+      dev_repo : Dev_repo.t;
       url : unresolved Url.t;
       hashes : OpamHash.t list;
     }
 
     let equal t t' =
       OpamPackage.equal t.opam t'.opam
-      && String.equal t.dev_repo t'.dev_repo
+      && Dev_repo.equal t.dev_repo t'.dev_repo
       && Url.equal Git.Ref.equal t.url t'.url
 
     let pp fmt { opam; dev_repo; url; hashes } =

lib/uri_utils.ml

@@ -1,9 +1,29 @@
 open Import
 
-let has_git_extension uri =
-  let open Result.O in
-  let ext_res =
-    let+ path = Fpath.of_string (Uri.path uri) in
-    Fpath.get_ext ~multi:true path
-  in
-  match ext_res with Ok ".git" -> true | Ok _ | Error _ -> false
+module Normalized = struct
+  type t = Github of { user : string; repo : string } | Other of Uri.t
+
+  let of_uri uri =
+    match Uri.host uri with
+    | Some "github.com" -> (
+        let path = Uri.path uri in
+        match Base.String.lsplit2 path ~on:'/' with
+        | None -> Other uri
+        | Some (user, gitrepo) -> (
+            match Base.String.rsplit2 gitrepo ~on:'.' with
+            | None -> Github { user; repo = gitrepo }
+            | Some (repo, "git") -> Github { user; repo }
+            | Some _ -> Other uri))
+    | Some _ | None -> Other uri
+
+  let equal a b =
+    match (a, b) with
+    | Other a, Other b -> Uri.equal a b
+    | Github { user; repo }, Github { user = user'; repo = repo' } ->
+        String.equal user user' && String.equal repo repo'
+    | _, _ -> false
+
+  let pp ppf = function
+    | Github { user; repo } -> Fmt.pf ppf "<Github user=%s repo=%s>" user repo
+    | Other uri -> Fmt.pf ppf "<Other %a>" Uri.pp uri
+end

lib/uri_utils.mli

@@ -1,2 +1,15 @@
-val has_git_extension : Uri.t -> bool
-(** Returns [true] if the given URI's path component has the .git extension *)
+(** One way normalization of URIs.
+    Not meant to expose the normalized value of the URI again *)
+module Normalized : sig
+  type t
+  (** Abstracts away the actual value which is not to be used directly *)
+
+  val of_uri : Uri.t -> t
+  (** Returns a canonical representation of the URI *)
+
+  val equal : t -> t -> bool
+  (** Determines whether two normalized URIs are equal *)
+
+  val pp : t Fmt.t
+  (** Pretty printer for normalized URLs. *)
+end

test/lib/test_uri_utils.ml

@@ -1,16 +1,54 @@
-let test_has_git_extension =
-  let make_test ~uri_str ~expected () =
-    let test_name = Printf.sprintf "has_git_extension: %s" uri_str in
-    let uri = Uri.of_string uri_str in
+module Normalized = Duniverse_lib.Uri_utils.Normalized
+
+let test_canonical_uri =
+  let make_test ~supplied:(a, b) ~expected =
+    let a = Uri.of_string a in
+    let a' = Normalized.of_uri a in
+    let b = Uri.of_string b in
+    let b' = Normalized.of_uri b in
+    let test_name = Fmt.str "Comparing %a and %a" Uri.pp a Uri.pp b in
     let test_fun () =
-      let actual = Duniverse_lib.Uri_utils.has_git_extension uri in
+      let actual = Normalized.equal a' b' in
       Alcotest.(check bool) test_name expected actual
     in
     (test_name, `Quick, test_fun)
   in
   [
-    make_test ~uri_str:"https://host.com/path/to/repo.git" ~expected:true ();
-    make_test ~uri_str:"https://host.com/path/to/repo" ~expected:false ();
+    make_test
+      ~supplied:
+        ( "git+https://github.com/mirage/mirage-clock.git",
+          "git+https://github.com/mirage/mirage-clock.git" )
+      ~expected:true;
+    make_test
+      ~supplied:
+        ( "git://github.com/mirage/mirage-clock.git",
+          "git+https://github.com/mirage/mirage-clock.git" )
+      ~expected:true;
+    make_test
+      ~supplied:
+        ( "https://github.com/mirage/mirage-clock.git",
+          "git+https://github.com/mirage/mirage-clock.git" )
+      ~expected:true;
+    make_test
+      ~supplied:
+        ( "git+https://github.com/mirage/mirage-clock.git#master",
+          "git+https://github.com/mirage/mirage-clock.git" )
+      ~expected:true;
+    make_test
+      ~supplied:
+        ( "git+https://github.com/mirage/mirage-clock",
+          "git+https://github.com/mirage/mirage-clock.git" )
+      ~expected:true;
+    make_test
+      ~supplied:
+        ( "git+https://github.com/mirage/mirage-foo.git",
+          "git+https://github.com/mirage/mirage-bar.git" )
+      ~expected:false;
+    make_test
+      ~supplied:
+        ( "git+https://github.com/mirage/mirage.git",
+          "git+https://github.com/anchorage/mirage.git" )
+      ~expected:false;
   ]
 
-let suite = ("Uri_utils", test_has_git_extension)
+let suite = ("Uri_utils", test_canonical_uri)