Only pull packages to descendants of duniverse dir

Previously, certain adversarial dev repo names (e.g. "", "..") would
cause `opam monorepo pull` to create and delete files outside the
duniverse directory, or to place package source code directly inside the
duniverse directory instead of a subdirectory. This change adds a check
which prevents code being pulled into directories which are not
descendants of the duniverse directory.

Signed-off-by: Stephen Sherratt <stephen@sherra.tt>

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 sudbirectory *)
+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

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 containinga 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]