Fix bug where dev repo urls ending with a "/" would result in opam monorepo pull placing package source code directly inside the duniverse directory instead of in a subdirectory of the duniverse directory

CHANGES.md

@@ -16,6 +16,11 @@
 - Read the `compiler` flag from OPAM metadata thus classifying more packages
   correctly as base packages (#328, @Leonidas-from-XIV)
 
+- Fix bug where dev repo urls ending with a "/" would result in
+  `opam monorepo pull` placing package source code directly inside the duniverse
+  directory instead of in a subdirectory of the duniverse directory (#359,
+  @gridbugs)
+
 ### Removed
 
 ### Security

lib/dev_repo.ml

@@ -6,17 +6,25 @@ let compare = String.compare
 let from_string s = s
 let to_string t = t
 
+let rec repeat_while_some x ~f =
+  match f x with None -> x | Some x -> repeat_while_some x ~f
+
+(* Attempt to split a string by calling [split s], then choose a side of the
+   result with [side], returning [s] if a split is not possible *)
+let try_split_side s ~(split : string -> (string * string) option) ~side =
+  Option.map_default (split s) ~f:side ~default:s
+
 let repo_name t =
-  let uri = Uri.of_string t in
-  let path = Uri.path uri in
-  let last_path_component =
-    match String.rsplit2 ~on:'/' path with
-    | None -> path
-    | Some (_, last_path_component) -> last_path_component
-  in
-  match String.lsplit2 ~on:'.' last_path_component with
-  | None -> last_path_component
-  | Some (repo_name, _ext) -> repo_name
+  Uri.of_string t |> Uri.path
+  |> repeat_while_some ~f:(Base.String.chop_suffix ~suffix:"/")
+  |> try_split_side ~split:(String.rsplit2 ~on:'/') ~side:snd
+  |> repeat_while_some ~f:(Base.String.chop_prefix ~prefix:".")
+  |> try_split_side ~split:(String.lsplit2 ~on:'.') ~side:fst
+  |> function
+  | "" ->
+      Rresult.R.error_msgf
+        "unexpected empty string while computing name for dev_repo: \"%s\"" t
+  | non_empty -> Ok non_empty
 
 module Map = Map.Make (struct
   type nonrec t = t

lib/dev_repo.mli

@@ -5,9 +5,18 @@ type t
 val from_string : string -> t
 val to_string : t -> string
 
-val repo_name : t -> string
-(** Returns the name of the repo given the dev-repo.
+val repo_name : t -> (string, Rresult.R.msg) result
+(** Computes a name for the repo by applying the following method:
+  1. Start with the path component of the repo's uri
+  2. Remove any trailing "/" characters
+  3. Take the substring to the right of the right-most "/" character to obtain
+     the final part of the path
+  4. Remove any leading "." characters
+  5. Take the substring to the left of the left-most "." character
+
     E.g. [repo_name (from_string "https://github.com/ocamllabs/opam-monorepo.git")]
-    returns ["opam-monorepo"]. *)
+    returns ["opam-monorepo"].
+
+    Returns an error if the result would be the empty string. *)
 
 module Map : Map.S with type key = t

lib/duniverse.ml

@@ -132,11 +132,13 @@ module Repo = struct
   end)
 
   let dir_name_from_dev_repo dev_repo =
-    match Dev_repo.repo_name dev_repo with "dune" -> "dune_" | name -> name
+    Dev_repo.repo_name dev_repo
+    |> Result.map ~f:(function "dune" -> "dune_" | name -> name)
 
   let from_packages ~dev_repo (packages : Package.t list) =
+    let open Result.O in
     let provided_packages = List.map packages ~f:(fun p -> p.Package.opam) in
-    let dir = dir_name_from_dev_repo dev_repo in
+    let+ dir = dir_name_from_dev_repo dev_repo in
     let urls =
       let add acc p =
         Unresolved_url_map.set acc p.Package.url p.Package.hashes
@@ -227,12 +229,10 @@ let from_dependency_entries ~get_default_branch dependencies =
   let* pkg_opts = Result.List.all results in
   let pkgs = List.filter_opt pkg_opts in
   let dev_repo_map = dev_repo_map_from_packages pkgs in
-  let repos =
-    Dev_repo.Map.fold dev_repo_map ~init:[]
-      ~f:(fun ~key:dev_repo ~data:pkgs acc ->
-        Repo.from_packages ~dev_repo pkgs :: acc)
-  in
-  Ok repos
+  Dev_repo.Map.fold dev_repo_map ~init:[]
+    ~f:(fun ~key:dev_repo ~data:pkgs acc ->
+      Repo.from_packages ~dev_repo pkgs :: acc)
+  |> Result.List.all
 
 let resolve ~resolve_ref t =
   Parallel.map ~f:(Repo.resolve ~resolve_ref) t |> Result.List.all

lib/duniverse.mli

@@ -48,7 +48,10 @@ module Repo : sig
       (t option, [ `Msg of string ]) result
   end
 
-  val from_packages : dev_repo:Dev_repo.t -> Package.t list -> unresolved t
+  val from_packages :
+    dev_repo:Dev_repo.t ->
+    Package.t list ->
+    (unresolved t, Rresult.R.msg) result
 
   (**/**)
 end

lib/pull.ml

@@ -1,21 +1,40 @@
 open Import
 
+(* Check that [output_dir] is strictly a descendant of [duniverse_dir] *)
+let is_in_universe_dir ~duniverse_dir ~output_dir =
+  Fpath.(is_prefix (normalize duniverse_dir) (normalize output_dir))
+  && not (String.equal (Fpath.filename output_dir) "")
+
+(* Delete version control metadata and vendor subdirectory *)
+let do_trim_clone output_dir =
+  let open Result.O in
+  let* () =
+    Bos.OS.Dir.delete ~must_exist:false ~recurse:true
+      Fpath.(output_dir / ".git")
+  in
+  Bos.OS.Dir.delete ~recurse:true Fpath.(output_dir // Config.vendor_dir)
+
 let pull ?(trim_clone = false) ~global_state ~duniverse_dir src_dep =
   let open Result.O in
   let open Duniverse.Repo in
   let { dir; url; hashes; _ } = src_dep in
   let output_dir = Fpath.(duniverse_dir / dir) in
-  let url = Url.to_opam_url url in
-  let open OpamProcess.Job.Op in
-  Opam.pull_tree ~url ~hashes ~dir:output_dir global_state @@| fun result ->
-  let* () = result in
-  if trim_clone then
-    let* () =
-      Bos.OS.Dir.delete ~must_exist:false ~recurse:true
-        Fpath.(output_dir / ".git")
+  if is_in_universe_dir ~duniverse_dir ~output_dir then
+    let url = Url.to_opam_url url in
+    let open OpamProcess.Job.Op in
+    Opam.pull_tree ~url ~hashes ~dir:output_dir global_state @@| fun result ->
+    let* () = result in
+    if trim_clone then do_trim_clone output_dir else Ok ()
+  else
+    let error =
+      Rresult.R.error_msgf
+        "Refusing to pull %s into directory %s as it is not inside the \
+         directory %s"
+        (Url.to_string url)
+        (Fpath.to_string output_dir)
+        (Fpath.to_string duniverse_dir)
     in
-    Bos.OS.Dir.delete ~recurse:true Fpath.(output_dir // Config.vendor_dir)
-  else Ok ()
+    Done error
 
 let pull_source_dependencies ?trim_clone ~global_state ~duniverse_dir src_deps =
   let open Result.O in

stdext/string.ml

@@ -40,12 +40,6 @@ let drop_prefix s ~prefix =
     else Some (sub s ~pos:(length prefix) ~len:(length s - length prefix))
   else None
 
-let drop_suffix s ~suffix =
-  if is_suffix s ~suffix then
-    if length s = length suffix then Some s
-    else Some (sub s ~pos:0 ~len:(length s - length suffix))
-  else None
-
 let index = index_opt
 let rindex = rindex_opt
 

stdext/string.mli

@@ -10,6 +10,5 @@ val extract_blank_separated_words : string -> string list
 val is_prefix : string -> prefix:string -> bool
 val is_suffix : string -> suffix:string -> bool
 val drop_prefix : string -> prefix:string -> string option
-val drop_suffix : string -> suffix:string -> string option
 
 module Map : Map.S with type key = string

test/bin/pull-invalid-path.t/lockfile-refers-to-duniverse-directory.opam.locked

@@ -0,0 +1,21 @@
+opam-version: "2.0"
+synopsis: "opam-monorepo generated lockfile"
+maintainer: "opam-monorepo"
+depends: [
+  "foo" {= "1" & ?vendor}
+  "ocaml" {= "4.14.0"}
+]
+pin-depends: [
+  ["foo.1" "https://foo.com/foo.tbz"]
+]
+x-opam-monorepo-duniverse-dirs: [
+  [
+    "https://foo.com/foo.tbz"
+    "" # <--------------------------- repo name is the empty string
+    [
+      "sha256=0000000000000000000000000000000000000000000000000000000000000000"
+    ]
+  ]
+]
+x-opam-monorepo-root-packages: ["foo"]
+x-opam-monorepo-version: "0.3"

test/bin/pull-invalid-path.t/lockfile-refers-to-parent-directory.opam.locked

@@ -0,0 +1,21 @@
+opam-version: "2.0"
+synopsis: "opam-monorepo generated lockfile"
+maintainer: "opam-monorepo"
+depends: [
+  "foo" {= "1" & ?vendor}
+  "ocaml" {= "4.14.0"}
+]
+pin-depends: [
+  ["foo.1" "https://foo.com/foo.tbz"]
+]
+x-opam-monorepo-duniverse-dirs: [
+  [
+    "https://foo.com/foo.tbz"
+    ".." # <--------------------------- repo name is ".."
+    [
+      "sha256=0000000000000000000000000000000000000000000000000000000000000000"
+    ]
+  ]
+]
+x-opam-monorepo-root-packages: ["foo"]
+x-opam-monorepo-version: "0.3"

test/bin/pull-invalid-path.t/run.t

@@ -0,0 +1,18 @@
+Running `opam monorepo pull` uses dev repo names (usually derived from the
+dev_repo field in the package's opam file) to name the directories that will
+contain the source code of packages inside the "duniverse" directory. We want to
+make sure that adversarial dev repo names don't cause files to be created or
+deleted outside the duniverse directory.
+
+Attempt to pull with a lockfile containing a package whose name is the empty
+string:
+  $ opam-monorepo pull --lockfile=lockfile-refers-to-duniverse-directory.opam.locked
+  ==> Using lockfile lockfile-refers-to-duniverse-directory.opam.locked
+  opam-monorepo: [ERROR] Refusing to pull https://foo.com/foo.tbz into directory $TESTCASE_ROOT/duniverse/ as it is not inside the directory $TESTCASE_ROOT/duniverse
+  [1]
+
+Attempt to pull with a lockfile containing a package whose name is "..":
+  $ opam-monorepo pull --lockfile=lockfile-refers-to-parent-directory.opam.locked
+  ==> Using lockfile lockfile-refers-to-parent-directory.opam.locked
+  opam-monorepo: [ERROR] Refusing to pull https://foo.com/foo.tbz into directory $TESTCASE_ROOT/duniverse/.. as it is not inside the directory $TESTCASE_ROOT/duniverse
+  [1]

test/lib/test_dev_repo.ml

@@ -3,17 +3,44 @@ let test_repo_name =
     let test_name = Printf.sprintf "repo_name: %s" dev_repo in
     let test_fun () =
       let actual = Duniverse_lib.Dev_repo.(repo_name (from_string dev_repo)) in
-      Alcotest.(check string) test_name expected actual
+      Alcotest.(check (result string Testable.r_msg)) test_name expected actual
     in
     (test_name, `Quick, test_fun)
   in
   [
     make_test ~dev_repo:"git://github.com/ocamllabs/opam-monorepo"
-      ~expected:"opam-monorepo" ();
+      ~expected:(Ok "opam-monorepo") ();
     make_test ~dev_repo:"git://github.com/ocamllabs/opam-monorepo.git"
-      ~expected:"opam-monorepo" ();
+      ~expected:(Ok "opam-monorepo") ();
     make_test ~dev_repo:"git+https://github.com/ocamllabs/opam-monorepo.git"
-      ~expected:"opam-monorepo" ();
+      ~expected:(Ok "opam-monorepo") ();
+    make_test ~dev_repo:"git+https://github.com/ocamllabs/opam-monorepo/"
+      ~expected:(Ok "opam-monorepo") ();
+    make_test ~dev_repo:"git+https://github.com/ocamllabs/opam-monorepo.1/"
+      ~expected:(Ok "opam-monorepo") ();
   ]
+  |> List.append
+       (let invalid_repos =
+          [
+            "";
+            ".";
+            "/";
+            "./.";
+            "...";
+            "///";
+            "https://github.com";
+            "https://github.com/";
+          ]
+        in
+        let make_test_error dev_repo =
+          make_test ~dev_repo
+            ~expected:
+              (Rresult.R.error_msgf
+                 "unexpected empty string while computing name for dev_repo: \
+                  \"%s\""
+                 dev_repo)
+            ()
+        in
+        List.map make_test_error invalid_repos)
 
 let suite = ("Dev_repo", List.concat [ test_repo_name ])