Apply patches when dealing with repositories via an OCaml implementation of patch

configure.ac

@@ -366,6 +366,7 @@ AC_CHECK_OCAML_PKG([jsonm])
 AC_CHECK_OCAML_PKG([uutf])
 AC_CHECK_OCAML_PKG([sha])
 AC_CHECK_OCAML_PKG([swhid_core])
+AC_CHECK_OCAML_PKG([patch])
 
 # Optional dependencies
 AC_CHECK_OCAML_PKG_AT_LEAST([mccs],[1.1+17])
@@ -414,6 +415,7 @@ AS_IF([test "x${enable_checks}" != "xno" && {
        test "x$OCAML_PKG_uutf" = "xno" ||
        test "x$OCAML_PKG_sha" = "xno" ||
        test "x$OCAML_PKG_swhid_core" = "xno" ||
+       test "x$OCAML_PKG_patch" = "xno" ||
        test "x$OCAML_PKG_mccs$MCCS_ENABLED" = "xnotrue";}],[
   AS_IF([test "x${with_vendored_deps}" != "xyes"],[
     AC_MSG_ERROR([Dependencies missing. Use --with-vendored-deps or --disable-checks])

opam-core.opam

@@ -30,6 +30,7 @@ depends: [
   "sha" {>= "1.13"}
   "jsonm"
   "swhid_core"
+  "patch" {>= "1.0.1"}
   "uutf"
   (("host-system-mingw" {os = "win32" & os-distribution != "cygwinports"} &
     "conf-mingw-w64-gcc-i686" {os = "win32" & os-distribution != "cygwinports"} &

src/client/opamInitDefaults.ml

@@ -133,7 +133,6 @@ let recommended_tools () =
 let required_tools ~sandboxing () =
   req_dl_tools () @
   [
-    ["diff"], None, None;
     ["patch"], None, Some patch_filter;
     ["gpatch"], None, Some gpatch_filter;
     ["tar"], None, Some tar_filter;
@@ -148,7 +147,8 @@ let required_tools ~sandboxing () =
 
 let required_packages_for_cygwin =
   [
-    "diffutils";
+    "diffutils"; (* TODO: not used internally anymore but used by many packages *)
+    "git"; (* XXX hg & mercurial ? *)
     "make";
     "patch";
     "tar";

src/core/dune

@@ -3,7 +3,7 @@
   (public_name opam-core)
   (synopsis    "OCaml Package Manager core internal stdlib")
   ; TODO: Remove (re_export ...) when CI uses the OCaml version that includes https://github.com/ocaml/ocaml/pull/11989
-  (libraries   re (re_export ocamlgraph) unix sha jsonm swhid_core uutf)
+  (libraries   re (re_export ocamlgraph) unix sha jsonm swhid_core uutf patch)
   (flags       (:standard
                (:include ../ocaml-flags-standard.sexp)
                (:include ../ocaml-flags-configure.sexp)

src/core/opamSystem.ml

@@ -1547,39 +1547,59 @@ let translate_patch ~dir orig corrected =
   end;
   close_in ch
 
-let gpatch = lazy begin
-  let rec search_gpatch = function
-    | [] -> None
-    | patch_cmd::patch_cmds ->
-      match OpamProcess.run (make_command ~name:"patch" patch_cmd ["--version"]) with
-      | r ->
-        (match OpamProcess.is_success r, r.OpamProcess.r_stdout with
-         | true, full::_ when
-             OpamStd.String.is_prefix_of ~from:0 ~full "GNU patch " ->
-           Some patch_cmd
-         | _ ->
-           search_gpatch patch_cmds)
-      | exception _ -> search_gpatch patch_cmds
+exception Internal_patch_error of string
+
+let internal_patch ~patch_filename ~dir diffs =
+  let fmt = Printf.sprintf in
+  let get_path file =
+    let dir = real_path dir in
+    let file = real_path (Filename.concat dir file) in
+    if not (OpamStd.String.is_prefix_of ~from:0 ~full:file dir) then
+      raise (Internal_patch_error (fmt "Patch %S tried to escape its scope." patch_filename));
+    file
   in
-  let default_cmd, other_cmds =
-    match OpamStd.Sys.os () with
-    | DragonFly
-    | FreeBSD
-    | NetBSD
-    | OpenBSD -> ("gpatch", ["patch"])
-    | Cygwin
-    | Darwin
-    | Linux
-    | Unix
-    | Win32
-    | Other _ -> ("patch", ["gpatch"])
+  let patch ~file content diff =
+    match Patch.patch ~cleanly:true content diff with
+    | Some x -> x
+    | None -> assert false
+    | exception _ ->
+      match Patch.patch ~cleanly:false content diff with
+      | Some x ->
+        OpamStd.Option.iter (write (file^".orig")) content;
+        x
+      | None -> assert false
+      | exception _ ->
+        OpamStd.Option.iter (write (file^".orig")) content;
+        write (file^".rej") (Format.asprintf "%a" Patch.pp diff);
+        raise (Internal_patch_error (fmt "Patch %S does not apply cleanly." patch_filename))
   in
-  match search_gpatch (default_cmd :: other_cmds) with
-  | Some gpatch -> gpatch
-  | None ->
-    OpamConsole.warning "Invalid patch utility. Please install GNU patch";
-    default_cmd
-end
+  let apply diff = match diff.Patch.operation with
+    | Patch.Edit (file1, file2) ->
+      (* That seems to be the GNU patch behaviour *)
+      let file =
+        let file1 = get_path file1 in
+        if Sys.file_exists file1 then
+          file1
+        else
+          get_path file2
+      in
+      let content = read file in
+      let content = patch ~file:file (Some content) diff in
+      write file content;
+    | Patch.Delete file ->
+      let file = get_path file in
+      (* TODO: apply the patch and check the file is empty *)
+      Unix.unlink file
+    | Patch.Create file ->
+      let file = get_path file in
+      let content = patch ~file None diff in
+      write file content
+    | Patch.Rename_only (src, dst) ->
+      let src = get_path src in
+      let dst = get_path dst in
+      Unix.rename src dst
+  in
+  List.iter apply diffs
 
 let patch ?(preprocess=true) ~dir p =
   if not (Sys.file_exists p) then
@@ -1593,11 +1613,12 @@ let patch ?(preprocess=true) ~dir p =
     else
       p
   in
-  let patch_cmd = Lazy.force gpatch in
-  make_command ~name:"patch" ~dir patch_cmd ["-p1"; "-i"; p'] @@> fun r ->
-    if not (OpamConsole.debug ()) then Sys.remove p';
-    if OpamProcess.is_success r then Done None
-    else Done (Some (Process_error r))
+  let content = read p' in
+  try
+    let diffs = Patch.parse ~p:1 content in
+    internal_patch ~patch_filename:p ~dir diffs;
+    Done None
+  with exn -> Done (Some exn)
 
 let register_printer () =
   Printexc.register_printer (function

src/core/opamSystem.mli

@@ -116,6 +116,9 @@ val read: string -> string
     advisory write lock to prevent concurrent reads or writes) *)
 val write: string -> string -> unit
 
+(** [get_files dir] returns the list of files inside the directory [dir]. *)
+val get_files : string -> string list
+
 (** [remove filename] removes [filename]. Works whether [filename] is
     a file or a directory *)
 val remove: string -> unit

src/repository/opamRepositoryBackend.ml

@@ -10,7 +10,7 @@
 
 open OpamTypes
 
-let log = OpamConsole.log "REPO_BACKEND"
+let log ?level fmt = OpamConsole.log "REPO_BACKEND" ?level fmt
 let slog = OpamConsole.slog
 
 type update =
@@ -73,25 +73,117 @@ let job_text name label =
        (OpamConsole.colorise `green (OpamRepositoryName.to_string name))
        label)
 
+let getfiles parent_dir dir =
+  let dir = Filename.concat (OpamFilename.Dir.to_string parent_dir) dir in
+  OpamSystem.get_files dir
+
+let get_files_for_diff parent_dir dir1 dir2 = match dir1, dir2 with
+  | None, None -> assert false
+  | Some dir, None ->
+    List.map (fun file -> Patch.Delete (Filename.concat dir file)) (getfiles parent_dir dir)
+  | None, Some dir ->
+    List.map (fun file -> Patch.Create (Filename.concat dir file)) (getfiles parent_dir dir)
+  | Some dir1, Some dir2 ->
+    let files1 = List.fast_sort String.compare (getfiles parent_dir dir1) in
+    let files2 = List.fast_sort String.compare (getfiles parent_dir dir2) in
+    let rec aux acc files1 files2 = match files1, files2 with
+      | (file1::files1 as orig1), (file2::files2 as orig2) ->
+        let cmp = String.compare file1 file2 in
+        if cmp = 0 then
+          aux (Patch.Edit (Filename.concat dir1 file1, Filename.concat dir2 file2) :: acc) files1 files2
+        else if cmp < 0 then
+          aux (Patch.Delete (Filename.concat dir1 file1) :: acc) files1 orig2
+        else
+          aux (Patch.Create (Filename.concat dir2 file2) :: acc) orig1 files2
+      | file1::files1, [] ->
+        aux (Patch.Delete (Filename.concat dir1 file1) :: acc) files1 []
+      | [], file2::files2 ->
+        aux (Patch.Create (Filename.concat dir2 file2) :: acc) [] files2
+      | [], [] ->
+        acc
+    in
+    aux [] files1 files2
+
+let readfile parent_dir file =
+  let file = Filename.concat (OpamFilename.Dir.to_string parent_dir) file in
+  OpamSystem.read file
+
+let lstat parent_dir file =
+  let file = Filename.concat (OpamFilename.Dir.to_string parent_dir) file in
+  Unix.lstat file
+
 let get_diff parent_dir dir1 dir2 =
+  let chrono = OpamConsole.timer () in
   log "diff: %a/{%a,%a}"
     (slog OpamFilename.Dir.to_string) parent_dir
     (slog OpamFilename.Base.to_string) dir1
     (slog OpamFilename.Base.to_string) dir2;
-  let patch = OpamSystem.temp_file ~auto_clean: false "patch" in
-  let patch_file = OpamFilename.of_string patch in
-  let finalise () = OpamFilename.remove patch_file in
-  OpamProcess.Job.catch (fun e -> finalise (); raise e) @@ fun () ->
-  OpamSystem.make_command
-    ~verbose:OpamCoreConfig.(!r.verbose_level >= 2)
-    ~dir:(OpamFilename.Dir.to_string parent_dir) ~stdout:patch
-    "diff"
-    [ "-ruaN";
-      OpamFilename.Base.to_string dir1;
-      OpamFilename.Base.to_string dir2; ]
-  @@> function
-  | { OpamProcess.r_code = 0; _ } -> finalise(); Done None
-  | { OpamProcess.r_code = 1; _ } as r ->
-    OpamProcess.cleanup ~force:true r;
+  let rec aux diffs dir1 dir2 =
+    let files = get_files_for_diff parent_dir dir1 dir2 in
+    let diffs =
+      List.fold_left (fun diffs operation ->
+          let file1, file2 = match operation with
+            | Patch.Delete filename -> (Some filename, None)
+            | Patch.Create filename -> (None, Some filename)
+            | Patch.Edit (file1, file2)
+            | Patch.Rename_only (file1, file2) -> (Some file1, Some file2)
+          in
+          let add_to_diffs content1 content2 diffs =
+            match Patch.diff operation content1 content2 with
+            | None -> diffs
+            | Some diff -> diff :: diffs
+          in
+          match OpamStd.Option.map (lstat parent_dir) file1, OpamStd.Option.map (lstat parent_dir) file2 with
+          | Some {Unix.st_kind = Unix.S_REG; _}, None
+          | None, Some {Unix.st_kind = Unix.S_REG; _}
+          | Some {Unix.st_kind = Unix.S_REG; _}, Some {Unix.st_kind = Unix.S_REG; _} ->
+            let content1 = Option.map (readfile parent_dir) file1 in
+            let content2 = Option.map (readfile parent_dir) file2 in
+            add_to_diffs content1 content2 diffs
+          | Some {Unix.st_kind = Unix.S_DIR; _}, None
+          | None, Some {Unix.st_kind = Unix.S_DIR; _}
+          | Some {Unix.st_kind = Unix.S_DIR; _}, Some {Unix.st_kind = Unix.S_DIR; _} ->
+            aux diffs file1 file2
+          | Some {Unix.st_kind = Unix.S_LNK; _}, None
+          | None, Some {Unix.st_kind = Unix.S_LNK; _}
+          | Some {Unix.st_kind = Unix.S_LNK; _}, Some {Unix.st_kind = Unix.S_LNK; _} ->
+            assert false (* TODO *)
+          | Some {Unix.st_kind = Unix.S_REG; _}, Some {Unix.st_kind = Unix.S_DIR; _} ->
+            assert false (* TODO *)
+          | Some {Unix.st_kind = Unix.S_DIR; _}, Some {Unix.st_kind = Unix.S_REG; _} ->
+            assert false (* TODO *)
+          | Some {Unix.st_kind = Unix.S_REG; _}, Some {Unix.st_kind = Unix.S_LNK; _} ->
+            assert false (* TODO *)
+          | Some {Unix.st_kind = Unix.S_LNK; _}, Some {Unix.st_kind = Unix.S_REG; _} ->
+            assert false (* TODO *)
+          | Some {Unix.st_kind = Unix.S_LNK; _}, Some {Unix.st_kind = Unix.S_DIR; _} ->
+            assert false (* TODO *)
+          | Some {Unix.st_kind = Unix.S_DIR; _}, Some {Unix.st_kind = Unix.S_LNK; _} ->
+            assert false (* TODO *)
+          | Some {Unix.st_kind = Unix.S_CHR; _}, _ | _, Some {Unix.st_kind = Unix.S_CHR; _} ->
+            failwith "Character devices are unsupported"
+          | Some {Unix.st_kind = Unix.S_BLK; _}, _ | _, Some {Unix.st_kind = Unix.S_BLK; _} ->
+            failwith "Block devices are unsupported"
+          | Some {Unix.st_kind = Unix.S_FIFO; _}, _ | _, Some {Unix.st_kind = Unix.S_FIFO; _} ->
+            failwith "Named pipes are unsupported"
+          | Some {Unix.st_kind = Unix.S_SOCK; _}, _ | _, Some {Unix.st_kind = Unix.S_SOCK; _} ->
+            failwith "Sockets are unsupported"
+          | None, None -> assert false)
+        diffs files
+    in
+    diffs
+  in
+  match
+    aux []
+      (Some (OpamFilename.Base.to_string dir1))
+      (Some (OpamFilename.Base.to_string dir2))
+  with
+  | [] ->
+    log "Internal diff (empty) done in %.2fs." (chrono ());
+    Done None
+  | diffs ->
+    log "Internal diff (non-empty) done in %.2fs." (chrono ());
+    let patch = OpamSystem.temp_file ~auto_clean: false "patch" in
+    let patch_file = OpamFilename.of_string patch in
+    OpamFilename.write patch_file (Format.asprintf "%a" Patch.pp_list diffs);
     Done (Some patch_file)
-  | r -> OpamSystem.process_error r

src_ext/Makefile

@@ -22,7 +22,7 @@ ifndef FETCH
   endif
 endif
 
-SRC_EXTS = cppo base64 extlib re cmdliner ocamlgraph cudf dose3 opam-file-format seq stdlib-shims spdx_licenses opam-0install-cudf 0install-solver uutf jsonm sha swhid_core
+SRC_EXTS = cppo base64 extlib re cmdliner ocamlgraph cudf dose3 opam-file-format seq stdlib-shims spdx_licenses opam-0install-cudf 0install-solver uutf jsonm sha swhid_core patch
 
 ifeq ($(MCCS_ENABLED),true)
 SRC_EXTS := $(SRC_EXTS) mccs