Wrap canonical URL in a module

This makes sure that the conversion is a one-way street and the
canonical URLs, whatever they might be will not be used for any other
purposes but `pp` and (more importantly) `equal`.

lib/duniverse.ml

@@ -57,9 +57,9 @@ module Repo = struct
       type t = string
 
       let equal a b =
-        let a = a |> Uri.of_string |> Uri_utils.canonicalize in
-        let b = b |> Uri.of_string |> Uri_utils.canonicalize in
-        Uri.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 = {

lib/uri_utils.ml

@@ -7,36 +7,47 @@ 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
 
-let canonicalize 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
+module Normalized = struct
+  type t = 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
-    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 (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
+
+  let equal = Uri.equal
+  let pp ppf v = Fmt.pf ppf "<Normalized %a>" Uri.pp v
+
+  module Private = struct
+    let unescaped = Base.Fn.id
+  end
+end

lib/uri_utils.mli

@@ -1,2 +1,25 @@
-val canonicalize : Uri.t -> Uri.t
-(** Returns a canonical representation of the URI *)
+(** 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. *)
+
+  (**/**)
+
+  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,17 +1,17 @@
-module Uri = struct
-  include Uri
+module Normalized = struct
+  include Duniverse_lib.Uri_utils.Normalized
 
   let testable = Alcotest.testable pp equal
 end
 
 let test_canonical_uri =
   let make_test ~name ~supplied ~expected =
     let supplied = Uri.of_string supplied in
-    let expected = Uri.of_string expected in
+    let expected = Uri.of_string expected |> Normalized.Private.unescaped in
     let test_name = Fmt.str "canonicizing: %s" name in
     let test_fun () =
-      let actual = Duniverse_lib.Uri_utils.canonicalize supplied in
-      Alcotest.(check Uri.testable) test_name expected actual
+      let actual = Normalized.of_uri supplied in
+      Alcotest.(check Normalized.testable) test_name expected actual
     in
     (test_name, `Quick, test_fun)
   in