Resolve relative references to pages

src/odoc/bin/main.ml

@@ -700,8 +700,16 @@ end = struct
     (if is_page then current_package_of_page ~current_package page_roots output
      else validate_current_package page_roots current_package)
     >>= fun current_package ->
+    let current_dir = Fs.File.dirname output in
     let roots =
-      Some { Resolver.page_roots; lib_roots; current_lib; current_package }
+      Some
+        {
+          Resolver.page_roots;
+          lib_roots;
+          current_lib;
+          current_package;
+          current_dir;
+        }
     in
     let resolver =
       Resolver.create ~important_digests:false ~directories ~open_modules ~roots

src/odoc/fs.ml

@@ -103,6 +103,8 @@ module File = struct
     | "" :: rest -> of_segs_tl (Fpath.v "/") rest
     | first :: rest -> of_segs_tl (Fpath.v first) rest
 
+  let append_segs path segs = of_segs_tl path segs
+
   module Table = Hashtbl.Make (struct
     type nonrec t = t
 
@@ -136,6 +138,8 @@ module Directory = struct
           invalid_arg "Odoc.Fs.Directory.create: not a directory";
         path
 
+  let contains ~parentdir f = Fpath.is_rooted ~root:parentdir f
+
   let mkdir_p dir =
     let mkdir d =
       try Unix.mkdir (Fpath.to_string d) 0o755 with
@@ -157,6 +161,8 @@ module Directory = struct
     | Result.Error (`Msg e) -> invalid_arg ("Odoc.Fs.Directory.of_string: " ^ e)
     | Result.Ok p -> Fpath.to_dir_path p
 
+  let of_file f = Fpath.to_dir_path f
+
   let fold_files_rec ?(ext = "") f acc d =
     let fold_non_dirs ext f acc files =
       let is_dir d = try Sys.is_directory d with Sys_error _ -> false in

src/odoc/fs.mli

@@ -36,8 +36,12 @@ module Directory : sig
   val reach_from : dir:t -> string -> t
   (** @raises Invalid_argument if [parent/name] exists but is not a directory. *)
 
+  val contains : parentdir:t -> file -> bool
+
   val mkdir_p : t -> unit
 
+  val of_file : file -> t
+
   val of_string : string -> t
 
   val to_string : t -> string
@@ -93,5 +97,8 @@ module File : sig
   (** [of_segs segs] Returns an absolute path if [segs] starts with an empty
       segment. Raises [Invalid_argument] if [segs] is empty. *)
 
+  val append_segs : t -> string list -> t
+  (** Append a list of segments to a path. Do not raise. *)
+
   module Table : Hashtbl.S with type key = t
 end

src/odoc/resolver.ml

@@ -163,6 +163,32 @@ end = struct
     Hashtbl.find_all t name
 end
 
+module Hierarchy : sig
+  (** Represent a file hierarchy and allow file path manipulations that do not
+      escape it. *)
+
+  type t
+
+  type error = [ `Escape_hierarchy ]
+
+  val make : current_package:Fs.Directory.t -> current_dir:Fs.Directory.t -> t
+
+  val resolve_relative : t -> Fs.File.t -> (Fs.File.t, error) result
+  (** [resolve_relative h relpath] resolve [relpath] relatively to the current
+      directory, making sure not to escape the hierarchy. *)
+end = struct
+  type t = { current_package : Fs.Directory.t; current_dir : Fs.Directory.t }
+
+  type error = [ `Escape_hierarchy ]
+
+  let make ~current_package ~current_dir = { current_package; current_dir }
+
+  let resolve_relative t relpath =
+    let path = Fs.File.append t.current_dir relpath in
+    if Fs.Directory.contains ~parentdir:t.current_package path then Ok path
+    else Error `Escape_hierarchy
+end
+
 module StringMap = Map.Make (String)
 
 let build_imports_map imports =
@@ -392,41 +418,51 @@ let add_unit_to_cache u =
   in
   Hashtbl.add unit_cache target_name [ u ]
 
-let lookup_path _ap ~pages ~libs:_ (kind, tag, path) =
+let lookup_path _ap ~pages ~libs:_ ~hierarchy (kind, tag, path) =
   let module Env = Odoc_xref2.Env in
   let ( >>= ) x f = match x with Some x' -> f x' | None -> None in
   let page_path_to_path path =
     (* Turn [foo/bar] into [foo/page-bar.odoc]. *)
-    match List.rev path with
-    | [] -> []
-    | name :: rest -> List.rev (("page-" ^ name ^ ".odoc") :: rest)
+    let segs =
+      match List.rev path with
+      | [] -> []
+      | name :: rest -> List.rev (("page-" ^ name ^ ".odoc") :: rest)
+    in
+    Fs.File.of_segs segs
   in
   let find_by_path ?root named_roots path =
     match Named_roots.find_by_path ?root named_roots ~path with
     | Ok x -> x
     | Error (NoPackage | NoRoot) -> None
   in
+  let load_page path =
+    match load_unit_from_file path with
+    | Some (Odoc_file.Page_content page) -> Env.Path_page page
+    | _ -> Env.Path_not_found
+  in
   let find_page ?root path =
-    ( pages >>= fun pages ->
-      find_by_path ?root pages path >>= fun path ->
-      load_unit_from_file path >>= function
-      | Odoc_file.Page_content page -> Some page
-      | _ -> None )
-    |> function
-    | Some page -> Env.Path_page page
+    (pages >>= fun pages -> find_by_path ?root pages path) |> function
+    | Some path -> load_page path
+    | None -> Env.Path_not_found
+  in
+  let find_page_in_hierarchy path =
+    match hierarchy with
+    | Some hierarchy -> (
+        match Hierarchy.resolve_relative hierarchy path with
+        | Ok path -> load_page path
+        | Error `Escape_hierarchy ->
+            Env.Path_not_found (* TODO: propagate more information *))
     | None -> Env.Path_not_found
   in
   match (kind, tag) with
   | `Page, `TCurrentPackage ->
       (* [path] is within the current package root. *)
-      let path = Fs.File.of_segs (page_path_to_path path) in
-      find_page path
+      find_page (page_path_to_path path)
   | `Page, `TAbsolutePath -> (
       match path with
-      | root :: path ->
-          let path = Fs.File.of_segs (page_path_to_path path) in
-          find_page ~root path
+      | root :: path -> find_page ~root (page_path_to_path path)
       | [] -> Env.Path_not_found)
+  | `Page, `TRelativePath -> find_page_in_hierarchy (page_path_to_path path)
   | _ -> Env.Path_not_found
 
 type t = {
@@ -435,32 +471,50 @@ type t = {
   pages : Named_roots.t option;
   libs : Named_roots.t option;
   open_modules : string list;
+  hierarchy : Hierarchy.t option;
 }
 
 type roots = {
   page_roots : (string * Fs.Directory.t) list;
   lib_roots : (string * Fs.Directory.t) list;
   current_lib : string option;
   current_package : string option;
+  current_dir : Fs.Directory.t;
 }
 
 let create ~important_digests ~directories ~open_modules ~roots =
   let ap = Accessible_paths.create ~directories in
-  let pages, libs =
+  let pages, libs, hierarchy =
     match roots with
-    | None -> (None, None)
-    | Some { page_roots; lib_roots; current_lib; current_package } ->
-        ( Some (Named_roots.create ~current_root:current_package page_roots),
-          Some (Named_roots.create ~current_root:current_lib lib_roots) )
+    | None -> (None, None, None)
+    | Some { page_roots; lib_roots; current_lib; current_package; current_dir }
+      ->
+        let pages = Named_roots.create ~current_root:current_package page_roots
+        and libs = Named_roots.create ~current_root:current_lib lib_roots in
+        let hierarchy =
+          match Named_roots.find_by_path pages ~path:(Fpath.v ".") with
+          | Ok (Some current_package) ->
+              let current_package = Fs.Directory.of_file current_package in
+              Some (Hierarchy.make ~current_package ~current_dir)
+          | Ok None | Error _ -> None
+        in
+        (Some pages, Some libs, hierarchy)
   in
-  { important_digests; ap; open_modules; pages; libs }
+  { important_digests; ap; open_modules; pages; libs; hierarchy }
 
 (** Helpers for creating xref2 env. *)
 
 open Odoc_xref2
 
 let build_compile_env_for_unit
-    { important_digests; ap; open_modules = open_units; pages; libs } m =
+    {
+      important_digests;
+      ap;
+      open_modules = open_units;
+      pages;
+      libs;
+      hierarchy = _;
+    } m =
   add_unit_to_cache (Odoc_file.Unit_content m);
   let imports_map = build_imports_map m.imports in
   let lookup_unit = lookup_unit ~important_digests ~imports_map ~libs ap
@@ -476,11 +530,12 @@ let build_compile_env_for_unit
 
 (** [important_digests] and [imports_map] only apply to modules. *)
 let build ?(imports_map = StringMap.empty)
-    { important_digests; ap; open_modules = open_units; pages; libs } =
+    { important_digests; ap; open_modules = open_units; pages; libs; hierarchy }
+    =
   let lookup_unit = lookup_unit ~libs ~important_digests ~imports_map ap
   and lookup_page = lookup_page ~pages ap
   and lookup_impl = lookup_impl ap
-  and lookup_path = lookup_path ap ~pages ~libs in
+  and lookup_path = lookup_path ap ~pages ~libs ~hierarchy in
   { Env.open_units; lookup_unit; lookup_page; lookup_impl; lookup_path }
 
 let build_compile_env_for_impl t i =

src/odoc/resolver.mli

@@ -24,8 +24,10 @@ type t
 type roots = {
   page_roots : (string * Fs.Directory.t) list;
   lib_roots : (string * Fs.Directory.t) list;
-  current_lib : string option;
-  current_package : string option;
+  current_lib : string option;  (** Name of the current [-L]. *)
+  current_package : string option;  (** Name of the current [-P]. *)
+  current_dir : Fs.Directory.t;
+      (** Directory containing the output for the current unit. *)
 }
 
 val create :

test/xref2/path_references.t/run.t

@@ -9,6 +9,8 @@
 
   $ odoc link -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/doc/subdir/page-dup.odoc
   $ odoc link -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/doc/subdir/page-bar.odoc
+  File "h/pkg/doc/subdir/page-Test.odoc":
+  File does not exist
   File "doc/subdir/bar.mld", line 12, characters 49-56:
   Warning: Failed to resolve reference unresolvedroot(Test) Couldn't find "Test"
   File "doc/subdir/bar.mld", line 12, characters 39-48:
@@ -17,14 +19,12 @@
   Warning: Failed to resolve reference /pkg/libname/Test Path '/pkg/libname/Test' not found
   File "doc/subdir/bar.mld", line 12, characters 0-17:
   Warning: Failed to resolve reference //libname/Test Path '//libname/Test' not found
-  File "doc/subdir/bar.mld", line 10, characters 35-43:
-  Warning: Failed to resolve reference ./dup Path 'dup' not found
-  File "doc/subdir/bar.mld", line 6, characters 42-50:
-  Warning: Failed to resolve reference ./bar Path 'bar' not found
   File "doc/subdir/bar.mld", line 4, characters 21-27:
   Warning: Failed to resolve reference unresolvedroot(foo) Couldn't find "foo"
   $ odoc link -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/doc/page-dup.odoc
   $ odoc link -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/doc/page-foo.odoc
+  File "h/pkg/doc/page-Test.odoc":
+  File does not exist
   File "doc/foo.mld", line 12, characters 49-56:
   Warning: Failed to resolve reference unresolvedroot(Test) Couldn't find "Test"
   File "doc/foo.mld", line 12, characters 39-48:
@@ -33,18 +33,8 @@
   Warning: Failed to resolve reference /pkg/libname/Test Path '/pkg/libname/Test' not found
   File "doc/foo.mld", line 12, characters 0-17:
   Warning: Failed to resolve reference //libname/Test Path '//libname/Test' not found
-  File "doc/foo.mld", line 10, characters 35-48:
-  Warning: Failed to resolve reference ./subdir/dup Path 'subdir/dup' not found
-  File "doc/foo.mld", line 8, characters 21-29:
-  Warning: Failed to resolve reference ./dup Path 'dup' not found
-  File "doc/foo.mld", line 6, characters 56-71:
-  Warning: Failed to resolve reference ./subdir/bar Path 'subdir/bar' not found
-  File "doc/foo.mld", line 6, characters 42-55:
-  Warning: Failed to resolve reference ./subdir/bar Path 'subdir/bar' not found
   File "doc/foo.mld", line 6, characters 35-41:
   Warning: Failed to resolve reference unresolvedroot(bar) Couldn't find "bar"
-  File "doc/foo.mld", line 4, characters 28-36:
-  Warning: Failed to resolve reference ./foo Path 'foo' not found
   $ odoc link --current-package pkg -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/lib/libname/test.odoc
   File "test.ml", line 12, characters 42-51:
   Warning: Failed to resolve reference ./Test Path 'Test' not found
@@ -69,21 +59,21 @@ Helper that extracts references in a compact way. Headings help to interpret the
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"foo"]}}},[]]}
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"foo"]}}},[]]}
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"foo"]}}},[]]}
-  {"`Reference":[{"`Any_path":["`TRelativePath",["foo"]]},[]]}
+  {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"foo"]}}},[]]}
   ["Page","subdir/bar"]
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]}
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]}
   {"`Reference":[{"`Root":["bar","`TUnknown"]},[]]}
-  {"`Reference":[{"`Any_path":["`TRelativePath",["subdir","bar"]]},[]]}
-  {"`Reference":[{"`Any_path":["`TRelativePath",["subdir","bar"]]},[]]}
+  {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]}
+  {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]}
   ["Page","dup"]
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]}
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]}
-  {"`Reference":[{"`Any_path":["`TRelativePath",["dup"]]},[]]}
+  {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]}
   ["Page","subdir/dup"]
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]}
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]}
-  {"`Reference":[{"`Any_path":["`TRelativePath",["subdir","dup"]]},[]]}
+  {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]}
   ["Module","Test"]
   {"`Reference":[{"`Any_path":["`TCurrentPackage",["libname","Test"]]},[]]}
   {"`Reference":[{"`Any_path":["`TAbsolutePath",["pkg","libname","Test"]]},[]]}
@@ -100,14 +90,14 @@ Helper that extracts references in a compact way. Headings help to interpret the
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]}
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]}
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]}
-  {"`Reference":[{"`Any_path":["`TRelativePath",["bar"]]},[]]}
+  {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]}
   ["Page","dup"]
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]}
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]}
   ["Page","subdir/dup"]
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]}
   {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]}
-  {"`Reference":[{"`Any_path":["`TRelativePath",["dup"]]},[]]}
+  {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]}
   ["Module","Test"]
   {"`Reference":[{"`Any_path":["`TCurrentPackage",["libname","Test"]]},[]]}
   {"`Reference":[{"`Any_path":["`TAbsolutePath",["pkg","libname","Test"]]},[]]}