Add relocatable option to dune install

  - But since findlib loads all the dependencies even the one already linked it
  is not sufficient to copy only the META of the dependencies not linked in the
  binary which are the one really needed

Signed-off-by: François Bobot <[email protected]>

bin/install_uninstall.ml

@@ -69,6 +69,7 @@ module type File_operations = sig
     -> special_file:Special_file.t option
     -> package:Package.Name.t
     -> get_location:(Dune.Section.t -> Package.Name.t -> Stdune.Path.t)
+    -> is_relocatable:(Path.t option)
     -> unit Fiber.t
 
   val mkdir_p : Path.t -> unit
@@ -83,7 +84,8 @@ module type Workspace = sig
 end
 
 module File_ops_dry_run : File_operations = struct
-  let copy_file ~src ~dst ~executable ~special_file:_ ~package:_ ~get_location:_ =
+  let copy_file ~src ~dst ~executable ~special_file:_ ~package:_ ~get_location:_
+    ~is_relocatable:_ =
     Format.printf "Copying %s to %s (executable: %b)\n"
       (Path.to_string_maybe_quoted src)
       (Path.to_string_maybe_quoted dst)
@@ -219,7 +221,8 @@ module File_ops_real (W : Workspace) : File_operations = struct
               Format.pp_print_cut ppf ());
           Format.pp_close_box ppf ())
 
-  let copy_file ~src ~dst ~executable ~special_file ~package ~get_location =
+  let copy_file ~src ~dst ~executable ~special_file ~package ~get_location
+    ~is_relocatable =
     let chmod =
       if executable then
         fun _ ->
@@ -244,6 +247,7 @@ module File_ops_real (W : Workspace) : File_operations = struct
               get_vcs;
               get_location;
               get_localPath=(fun _ -> None);
+              is_relocatable;
             }
             ~input:(input ic)
             ~output:(output oc))
@@ -356,6 +360,11 @@ let install_uninstall ~what =
         value & flag
         & info [ "dry-run" ]
             ~doc:"Only display the file operations that would be performed.")
+    and+ relocatable =
+      Arg.(
+        value & flag
+        & info [ "relocatable" ]
+            ~doc:"Make the binaries relocatable (the installation directory can be moved).")
     and+ pkgs = Arg.(value & pos_all package_name [] name_)
     and+ context =
       Arg.(
@@ -465,6 +474,9 @@ let install_uninstall ~what =
                 get_dirs context ~prefix_from_command_line
                   ~libdir_from_command_line
               in
+              let is_relocatable =
+                if relocatable then Some prefix else None
+              in
               Fiber.sequential_iter entries_per_package
                 ~f:(fun (package, entries) ->
                   let paths =
@@ -496,6 +508,7 @@ let install_uninstall ~what =
                         in
                         Ops.copy_file ~src:entry.src ~dst ~executable
                           ~special_file ~package ~get_location
+                          ~is_relocatable
                       ) else (
                         Ops.remove_if_exists dst;
                         files_deleted_in := Path.Set.add !files_deleted_in dir;

otherlibs/cram/bin/sanitize.ml

@@ -15,7 +15,8 @@ let rewrite_paths =
       exit 2
     | Ok map ->
       let abs_path_re =
-        Re.(compile (seq [ char '/'; rep1 (diff any (set " \n\r\t")) ]))
+        let not_dir = Printf.sprintf " \n\r\t%c" Bin.path_sep in
+        Re.(compile (seq [ char '/'; rep1 (diff any (set not_dir)) ]))
       in
       fun s ->
         Re.replace abs_path_re s ~f:(fun g ->

otherlibs/sites_locations/src/dune

@@ -1,4 +1,10 @@
 (library
  (name sites_locations)
  (public_name dune-sites-locations)
+ (modules_without_implementation sites_locations_data)
+ ; (private_modules sites_locations_data)
+ (special_builtin_support
+  (sites_locations
+   (data_module sites_locations_data)
+ ))
 )

otherlibs/sites_locations/src/plugins/sites_locations_plugins.ml

@@ -21,10 +21,15 @@ module Private_ = struct
   let init id paths ocamlpath () =
     if !initialized_id <> id
     then
-      let env_ocamlpath =
-        String.concat Sites_locations.Private_.path_sep (paths@[ocamlpath])
-      in
-      Findlib.init ~env_ocamlpath ()
+      let ocamlpath = String.split_on_char Sites_locations.Private_.path_sep.[0] ocamlpath in
+      let search_path = (paths@ocamlpath) in
+      if Lazy.force Sites_locations.Private_.relocatable then
+        Findlib.init_manually ~search_path ~install_dir:"" ~meta_dir:"" ()
+      else
+        let env_ocamlpath =
+          String.concat Sites_locations.Private_.path_sep search_path
+        in
+        Findlib.init ~env_ocamlpath ()
 
   module Make (X:sig val paths: string list val ocamlpath: string end) : S = struct
     include X

otherlibs/sites_locations/src/sites_locations.ml

@@ -78,9 +78,31 @@ module Private_ = struct
   let get_dir ~package ~section =
     Hashtbl.find_all dirs (package,section)
 
+  let relocatable = lazy (
+    match eval Sites_locations_data.relocatable_encoded with
+    | Some "y" -> true
+    | None | Some "n" -> false
+    | Some _ -> assert false (* absurd: only y/n are generated *)
+  )
+
+  let prefix = lazy (
+    let path = Sys.executable_name in
+    let bin = Filename.dirname path in
+    let prefix = Filename.dirname bin in
+    prefix
+  )
+  let relocate_if_needed path =
+    if Lazy.force relocatable then
+      Filename.concat (Lazy.force prefix) path
+    else
+      path
+
   let site ~package ~section ~suffix ~encoded =
     let dirs = get_dir ~package ~section in
-    let dirs = match eval encoded with None -> dirs | Some d -> d::dirs in
+    let dirs = match eval encoded with
+      | None -> dirs
+      | Some d -> (relocate_if_needed d)::dirs
+    in
     List.rev_map (fun dir -> Filename.concat dir suffix) dirs
   [@@inline never]
 
@@ -103,6 +125,11 @@ module Private_ = struct
       | None | Some "" -> env
       | Some x -> x::env
     in
+    let env =
+      if Lazy.force relocatable then
+        (Filename.concat (Lazy.force prefix) "lib")::env
+      else env
+    in
     String.concat path_sep env
 
 end

otherlibs/sites_locations/src/sites_locations.mli

@@ -28,6 +28,7 @@ module Private_ : sig
   val site : package:string -> section:Section.t ->
     suffix:string -> encoded:string -> Location.t list
 
+  val relocatable: bool Lazy.t
   val ocamlpath: string -> string
   val sourceroot: string -> string option
 

otherlibs/sites_locations/src/sites_locations_data.mli

@@ -0,0 +1 @@
+val relocatable_encoded : string

otherlibs/sites_locations/test/run.t

@@ -90,6 +90,9 @@ Test embedding of sites locations information
 
   $ dune build
 
+Test with a normal installation
+--------------------------------
+
   $ dune install --prefix _install 2> /dev/null
 
 Once installed, we have the sites information:
@@ -104,6 +107,44 @@ Once installed, we have the sites information:
   b: $TESTCASE_ROOT/_install/share/b/data
   run c: b_registered:true
 
+Test with a relocatable installation
+--------------------------------
+
+  $ dune install --prefix _install_relocatable --relocatable 2> /dev/null
+
+Hack because findlib wants to load all the packages even the one already linked
+  $ mkdir _install_relocatable/lib/threads
+  $ echo 'package "posix" ( )' > _install_relocatable/lib/threads/META
+
+Once installed, we have the sites information:
+
+  $ _install_relocatable/bin/c
+  run a
+  a: $TESTCASE_ROOT/_install_relocatable/share/a/data
+  run c: a linked b_registered:false
+  no sourceroot
+  c: $TESTCASE_ROOT/_install_relocatable/share/c/data
+  run b
+  b: $TESTCASE_ROOT/_install_relocatable/share/b/data
+  run c: b_registered:true
+
+Test after moving a relocatable installation
+--------------------------------
+
+  $ mv _install_relocatable  _install_relocatable2
+
+Once installed, we have the sites information:
+
+  $ _install_relocatable2/bin/c
+  run a
+  a: $TESTCASE_ROOT/_install_relocatable2/share/a/data
+  run c: a linked b_registered:false
+  no sourceroot
+  c: $TESTCASE_ROOT/_install_relocatable2/share/c/data
+  run b
+  b: $TESTCASE_ROOT/_install_relocatable2/share/b/data
+  run c: b_registered:true
+
 Test substitution when promoting
 --------------------------------
 

src/dune/artifact_substitution.ml

@@ -36,12 +36,14 @@ type t =
   | Vcs_describe of Path.Source.t
   | Location of Section.t * Package.Name.t
   | LocalPath of localpath
+  | Relocatable
   | Repeat of int * string
 
 type conf = {
   get_vcs:(Path.Source.t -> Vcs.t option);
   get_location:(Section.t -> Package.Name.t -> Path.t);
   get_localPath:(localpath -> Path.t option);
+  is_relocatable: Path.t option;
 }
 
 let to_dyn = function
@@ -51,9 +53,17 @@ let to_dyn = function
   | LocalPath d  ->
     let v = match d with | SourceRoot -> "SourceRoot" | InstallLib -> "InstallLib" in
     Dyn.Variant ("LocalPath",[Dyn.Variant(v,[])])
+  | Relocatable ->
+    Dyn.Variant ("Relocatable",[])
   | Repeat (n, s) -> Dyn.Variant ("Repeat", [ Int n; String s ])
 
 let eval t ~conf =
+  let relocatable path =
+    (* return a relative path to the install directory in case of relocatable instead of absolute path *)
+    match conf.is_relocatable with
+    | None -> Path.to_absolute_filename path
+    | Some install -> Path.reach path ~from:install
+  in
   match t with
   | Repeat (n, s) ->
     Fiber.return (Array.make n s |> Array.to_list |> String.concat ~sep:"")
@@ -62,13 +72,15 @@ let eval t ~conf =
     | None -> Fiber.return ""
     | Some vcs -> Vcs.describe vcs )
   | Location (name,lib_name) ->
-    Fiber.return (Path.to_absolute_filename (conf.get_location name lib_name))
+    Fiber.return (relocatable (conf.get_location name lib_name))
   | LocalPath d ->
     Fiber.return
       (Option.value ~default:""
          (let open Option.O in
           let+ dir = (conf.get_localPath d) in
-          Path.to_absolute_filename dir))
+          relocatable dir))
+  | Relocatable ->
+    Fiber.return (if Option.is_some conf.is_relocatable then "y" else "n")
 
 let encode_replacement ~len ~repl:s =
   let repl = sprintf "=%u:%s" (String.length s) s in
@@ -98,6 +110,8 @@ let encode ?(min_len = 0) t =
         sprintf "localpath:sourceroot:"
       | LocalPath InstallLib ->
         sprintf "localpath:installlib:"
+      | Relocatable ->
+        sprintf "relocatable"
       | Repeat (n, s) -> sprintf "repeat:%d:%d:%s" n (String.length s) s )
   in
   let len =
@@ -168,6 +182,8 @@ let decode s =
       LocalPath SourceRoot
     | "localpath" :: "installlib" :: _ ->
       LocalPath InstallLib
+    | "relocatable" :: _ ->
+      Relocatable
     | "repeat" :: repeat :: rest ->
       Repeat (parse_int repeat, read_string_payload rest)
     | _ -> fail ()

src/dune/artifact_substitution.mli

@@ -11,6 +11,7 @@ type t =
   | Vcs_describe of Path.Source.t
   | Location of Section.t * Package.Name.t
   | LocalPath of localpath
+  | Relocatable
   | Repeat of int * string
       (** [Repeat (n, s)] evaluates to [s] repeated [n] times. This substitution
           is used for unit tests. *)
@@ -19,6 +20,8 @@ type conf = {
   get_vcs:(Path.Source.t -> Vcs.t option);
   get_location:(Section.t -> Package.Name.t -> Path.t);
   get_localPath:(localpath -> Path.t option);
+  is_relocatable: Path.t option
+  (** Initial prefix of installation when relocatable chosen *)
 }
 
 val to_dyn : t -> Dyn.t

src/dune/build_system.ml

@@ -1660,6 +1660,7 @@ end = struct
                   ~conf:{ get_vcs = File_tree.nearest_vcs;
                           get_location;
                           get_localPath;
+                          is_relocatable = None;
                         }
                   ~chmod ))
     in

src/dune/dune_file.ml

@@ -2074,6 +2074,7 @@ module Generate_module = struct
     ; module_ : Module_name.t
     ; ocamlpath: bool
     ; sourceroot: bool
+    ; relocatable: bool
     ; sites : (Loc.t * Package.Name.t) list
     ; plugins : (Loc.t * (Package.Name.t * (Loc.t * Section.Site.t))) list
     }
@@ -2084,12 +2085,13 @@ module Generate_module = struct
        and+ module_ = field "module" Module_name.decode
        and+ ocamlpath = field_b "ocamlpath"
        and+ sourceroot = field_b "sourceroot"
+       and+ relocatable = field_b "relocatable"
        and+ sites = field "sites" ~default:[] (repeat (located Package.Name.decode))
        and+ plugins =
          field "plugins" ~default:[]
            (repeat (located (pair Package.Name.decode (located Section.Site.decode))))
        in
-       { loc; module_; sourceroot; ocamlpath; sites; plugins })
+       { loc; module_; sourceroot; ocamlpath; relocatable; sites; plugins })
 end
 
 type Stanza.t +=

src/dune/dune_file.mli

@@ -441,6 +441,7 @@ module Generate_module : sig
     ; module_ : Module_name.t
     ; ocamlpath: bool
     ; sourceroot: bool
+    ; relocatable: bool
     ; sites : (Loc.t * Package.Name.t) list
     ; plugins : (Loc.t * (Package.Name.t * (Loc.t * Section.Site.t))) list
     }

src/dune/generate_module_rules.ml

@@ -9,6 +9,9 @@ let sourceroot_code buf =
   pr buf "let sourceroot = Sites_locations.Private_.sourceroot %S"
     (Artifact_substitution.encode ~min_len:max_path_length (LocalPath SourceRoot))
 
+let relocatable_code buf =
+  pr buf "let relocatable = Lazy.force Sites_locations.Private_.relocatable"
+
 let ocamlpath_code buf =
   pr buf "let ocamlpath = Sites_locations.Private_.ocamlpath %S"
     (Artifact_substitution.encode ~min_len:max_path_length (LocalPath InstallLib))
@@ -59,6 +62,7 @@ let plugins_code sctx buf pkg sites =
 let setup_rules sctx ~dir (def:Dune_file.Generate_module.t) =
   let buf = Buffer.create 1024 in
   if def.sourceroot then sourceroot_code buf;
+  if def.relocatable then relocatable_code buf;
   if def.ocamlpath || List.is_non_empty def.plugins then ocamlpath_code buf;
   let sites =
     List.sort_uniq