Normalize only on github.com URLs

lib/uri_utils.ml

@@ -1,53 +1,29 @@
 open Import
 
-let path_ok path = path |> Fpath.to_string |> Result.ok
-let flip f a b = f b a
-
-let dump_result =
-  let dump_msg ppf (`Msg s) = Fmt.pf ppf "`Msg %S" s in
-  Fmt.Dump.result ~ok:Fmt.Dump.string ~error:dump_msg
-
 module Normalized = struct
-  type t = Uri.t
+  type t = Github of { user : string; repo : string } | Other of Uri.t
 
   let of_uri uri =
-    let open Result.O in
-    let new_path =
-      let* fpath = Fpath.of_string (Uri.path uri) in
-      let fpath =
-        match Fpath.has_ext ".git" fpath with
-        | true -> fpath
-        | false -> Fpath.add_ext ".git" fpath
-      in
-      path_ok fpath
-    in
-    let new_scheme =
-      match Uri.scheme uri with
-      | Some "https" -> Ok "git+https"
-      | Some "git" -> Ok "git+https"
-      | Some ("git+https" as git_https) -> Ok git_https
-      | Some other_scheme ->
-          Fmt.error_msg "Can't canonicalize unknown scheme %s" other_scheme
-      | None -> Fmt.error_msg "No scheme provided in %a" Uri.pp uri
-    in
-    match (new_path, new_scheme) with
-    | Ok new_path, Ok new_scheme ->
-        uri
-        |> (flip Uri.with_path) new_path
-        |> (flip Uri.with_scheme) (Some new_scheme)
-        |> (flip Uri.with_fragment) None
-    | failed_path, failed_scheme ->
-        Logs.warn (fun l ->
-            l
-              "Canonicalization of URL %a failed, passing unchanged \
-               (canonicialized path: %a canonicalized scheme: %a)"
-              Uri.pp uri dump_result failed_path dump_result failed_scheme);
-        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 = Uri.equal
-  let pp ppf v = Fmt.pf ppf "<Normalized %a>" Uri.pp v
+  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
 
-  module Private = struct
-    let unescaped = Base.Fn.id
-  end
+  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

@@ -12,14 +12,4 @@ module Normalized : sig
 
   val pp : t Fmt.t
   (** Pretty printer for normalized URLs. *)
-
-  (**/**)
-
-  module Private : sig
-    val unescaped : Uri.t -> t
-    (** Convert a [Uri.t] into a [t] without escaping. Only used for testing
-        purposes, as it breaks the security guarantees. *)
-  end
-
-  (**/**)
 end

test/lib/test_uri_utils.ml

@@ -1,36 +1,54 @@
-module Normalized = struct
-  include Duniverse_lib.Uri_utils.Normalized
-
-  let testable = Alcotest.testable pp equal
-end
+module Normalized = Duniverse_lib.Uri_utils.Normalized
 
 let test_canonical_uri =
-  let make_test ~name ~supplied ~expected =
-    let supplied = Uri.of_string supplied in
-    let expected = Uri.of_string expected |> Normalized.Private.unescaped in
-    let test_name = Fmt.str "canonicizing: %s" name in
+  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 = Normalized.of_uri supplied in
-      Alcotest.(check Normalized.testable) test_name expected actual
+      let actual = Normalized.equal a' b' in
+      Alcotest.(check bool) test_name expected actual
     in
     (test_name, `Quick, test_fun)
   in
   [
-    make_test ~name:"no-op"
-      ~supplied:"git+https://github.com/mirage/mirage-clock.git"
-      ~expected:"git+https://github.com/mirage/mirage-clock.git";
-    make_test ~name:"scheme: git"
-      ~supplied:"git://github.com/mirage/mirage-clock.git"
-      ~expected:"git+https://github.com/mirage/mirage-clock.git";
-    make_test ~name:"scheme: https"
-      ~supplied:"https://github.com/mirage/mirage-clock.git"
-      ~expected:"git+https://github.com/mirage/mirage-clock.git";
-    make_test ~name:"hash"
-      ~supplied:"git+https://github.com/mirage/mirage-clock.git#master"
-      ~expected:"git+https://github.com/mirage/mirage-clock.git";
-    make_test ~name:".git suffix"
-      ~supplied:"git+https://github.com/mirage/mirage-clock"
-      ~expected:"git+https://github.com/mirage/mirage-clock.git";
+    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_canonical_uri)