From ecb55ba3780ca3ef3d86cef9f35d3c7fa09ef10e Mon Sep 17 00:00:00 2001 From: PizieDust Date: Tue, 14 Jan 2025 14:12:47 +0100 Subject: [PATCH] Initial commit as a package --- .gitignore | 3 + .ocamlformat | 13 ++ CHANGES.md | 0 LICENSE.md | 23 ++++ README.md | 3 + dune | 3 + dune-project | 2 + opamdiff.ml | 360 ++++++++++++++++++++++++++++++++++++++++++++++++++ opamdiff.mli | 52 ++++++++ opamdiff.opam | 27 ++++ 10 files changed, 486 insertions(+) create mode 100644 .gitignore create mode 100644 .ocamlformat create mode 100644 CHANGES.md create mode 100644 LICENSE.md create mode 100644 README.md create mode 100644 dune create mode 100644 dune-project create mode 100644 opamdiff.ml create mode 100644 opamdiff.mli create mode 100644 opamdiff.opam diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..7606110 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +_opam +_build +.vscode diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..9db5b95 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,13 @@ +version=0.27.0 +exp-grouping=preserve +break-infix=wrap-or-vertical +break-collection-expressions=wrap +break-sequences=false +break-infix-before-func=false +dock-collection-brackets=true +break-separators=before +field-space=tight +if-then-else=compact +break-sequences=false +sequence-blank-line=compact +exp-grouping=preserve diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..e69de29 diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..b2f8a9b --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,23 @@ +Copyright (c) 2024, Robur Coop +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..f08a05b --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# Opamdiff + +This package provides the types and JSON parsing functions used by Builder Web and Mollymawk. diff --git a/dune b/dune new file mode 100644 index 0000000..fc5561d --- /dev/null +++ b/dune @@ -0,0 +1,3 @@ +(library + (name opamdiff) + (libraries opam-core opam-format yojson)) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..aa5ad36 --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 2.7) +(name opamdiff) diff --git a/opamdiff.ml b/opamdiff.ml new file mode 100644 index 0000000..25923a8 --- /dev/null +++ b/opamdiff.ml @@ -0,0 +1,360 @@ +module Set = OpamPackage.Set + +let packages (switch : OpamFile.SwitchExport.t) = + assert (Set.cardinal switch.selections.sel_pinned = 0); + assert (Set.cardinal switch.selections.sel_compiler = 0); + assert (Set.subset switch.selections.sel_roots switch.selections.sel_installed); + switch.selections.sel_installed + +let duniverse_dir = "x-opam-monorepo-duniverse-dirs" + +module M = Map.Make (String) + +let duniverse_dirs_data = + (* the representation in the file is [ URL DIR [ HASH* ] ] *) + let open OpamParserTypes.FullPos in + let ( let* ) = Result.bind in + let string ~ctx = function + | { pelem= String s; _ } -> Ok s + | _ -> Error (`Msg ("couldn't find a string " ^ ctx)) + in + let extract_data = function + | { pelem= List { pelem= [ url; dir; hashes ]; _ }; _ } -> + let* url = string ~ctx:"url" url in + let* hashes = + match hashes with + | { pelem= List { pelem= hashes; _ }; _ } -> + List.fold_left + (fun acc hash -> + let* acc = acc in + let* hash = string ~ctx:"hash" hash in + let* h = + match OpamHash.of_string_opt hash with + | Some h -> Ok OpamHash.(kind h, contents h) + | None -> + Error (`Msg ("couldn't decode opam hash in " ^ hash)) + in + Ok (h :: acc)) + (Ok []) hashes + | _ -> Error (`Msg "couldn't decode hashes") + in + let* dir = string ~ctx:"directory" dir in + Ok (url, dir, List.rev hashes) + | { pelem= List { pelem= [ url; dir ]; _ }; _ } -> + let* url = string ~ctx:"url" url in + let* dir = string ~ctx:"directory" dir in + Ok (url, dir, []) + | _ -> Error (`Msg "expected a list of URL, DIR, [HASHES]") + in + function + | { pelem= List { pelem= lbody; _ }; _ } -> + List.fold_left + (fun acc v -> + let* acc = acc in + let* url, dir, hashes = extract_data v in + Ok (M.add dir (url, hashes) acc)) + (Ok M.empty) lbody + | _ -> Error (`Msg "expected a list or a nested list") + +let duniverse (switch : OpamFile.SwitchExport.t) = + let root = switch.OpamFile.SwitchExport.selections.OpamTypes.sel_roots in + if OpamPackage.Set.cardinal root = 1 then + let root = OpamPackage.Set.choose root in + match + OpamPackage.( + Name.Map.find_opt root.name switch.OpamFile.SwitchExport.overlays) + with + | None -> Error (`Msg "opam switch export doesn't contain the main package") + | Some opam -> ( + match OpamFile.OPAM.extended opam duniverse_dir duniverse_dirs_data with + | None -> Ok None + | Some (Error e) -> Error e + | Some (Ok v) -> Ok (Some v)) + else Error (`Msg "not a single root package found in opam switch export") + +type duniverse_diff = { + name: string + ; urls: string * string option + ; hash: (OpamHash.kind * string option * string option) list +} + +let pp_duniverse_diff ppf { name; urls; hash } = + let opt_hash = Option.value ~default:"NONE" in + Format.fprintf ppf "%s (%s%s) %s" name (fst urls) + (Option.fold ~none:"" ~some:(fun url -> "->" ^ url) (snd urls)) + (String.concat ", " + (List.map + (fun (h, l, r) -> + OpamHash.string_of_kind h ^ " " ^ opt_hash l ^ "->" ^ opt_hash r) + hash)) + +let pp_duniverse_dir ppf (dir, url) = Format.fprintf ppf "%s (%s)" dir url + +let duniverse_diff l r = + let l = Option.value l ~default:M.empty + and r = Option.value r ~default:M.empty in + let keys_l_only = ref [] and keys_r_only = ref [] and diff = ref [] in + let equal_hashes l r = + (* l and r are lists of pairs, with the hash kind and its value *) + (* for a git remote, the hashes are empty lists *) + (match l with [] -> false | _ -> true) + && (match r with [] -> false | _ -> true) + && List.for_all + (fun (h, v) -> + match List.assoc_opt h r with + | None -> false + | Some v' -> String.equal v v') + l + && List.for_all + (fun (h, v) -> + match List.assoc_opt h l with + | None -> false + | Some v' -> String.equal v v') + r + in + let _ = + M.merge + (fun key l r -> + match (l, r) with + | None, Some _ -> + keys_r_only := key :: !keys_r_only; + None + | Some _, None -> + keys_l_only := key :: !keys_l_only; + None + | None, None -> None + | Some (_, l), Some (_, r) when equal_hashes l r -> None + | Some (url1, []), Some (url2, []) when String.equal url1 url2 -> None + | Some l, Some r -> + diff := (key, l, r) :: !diff; + None) + l r + in + let dir_only keys map = + let only = M.filter (fun k _ -> List.mem k keys) map |> M.bindings in + List.map (fun (key, (url, _)) -> (key, url)) only + in + let l_only = dir_only !keys_l_only l + and r_only = dir_only !keys_r_only r + and diff = + List.map + (fun (name, (url_l, hashes_l), (url_r, hashes_r)) -> + let urls = + if String.equal url_l url_r then (url_l, None) else (url_l, Some url_r) + in + let hash = + List.fold_left + (fun acc (h, v) -> + match List.assoc_opt h hashes_r with + | None -> (h, Some v, None) :: acc + | Some v' -> + if String.equal v v' then acc else (h, Some v, Some v') :: acc) + [] hashes_l + in + let hash = + List.fold_left + (fun acc (h', v') -> + match List.assoc_opt h' hashes_l with + | None -> (h', None, Some v') :: acc + | Some _ -> acc) + hash hashes_r + in + { name; urls; hash }) + !diff + in + (l_only, r_only, diff) + +type version_diff = { + name: OpamPackage.Name.t + ; version_left: OpamPackage.Version.t + ; version_right: OpamPackage.Version.t +} + +let pp_opampackage ppf p = Format.fprintf ppf "%s" (OpamPackage.to_string p) + +let pp_version_diff ppf { name; version_left; version_right } = + Format.fprintf ppf "%s.%s->%s" + (OpamPackage.Name.to_string name) + (OpamPackage.Version.to_string version_left) + (OpamPackage.Version.to_string version_right) + +type opam_diff = { + pkg: OpamPackage.t + ; build: (OpamTypes.command list * OpamTypes.command list) option + ; install: (OpamTypes.command list * OpamTypes.command list) option + ; url: (OpamFile.URL.t option * OpamFile.URL.t option) option + ; otherwise_equal: bool +} + +let commands_to_strings (l, r) = + let v a = OpamPrinter.FullPos.value (OpamPp.print OpamFormat.V.command a) in + (List.map v l, List.map v r) + +let opt_url_to_string (l, r) = + let url_to_s = function + | None -> "" + | Some u -> OpamFile.URL.write_to_string u + in + (url_to_s l, url_to_s r) + +let pp_opam_diff ppf { pkg; otherwise_equal; _ } = + Format.fprintf ppf "%a%s" pp_opampackage pkg + (if otherwise_equal then "" else " (and additional changes)") + +let rec strip_common_prefix a b = + match (a, b) with + | hd :: tl, hd' :: tl' -> + if hd = hd' then strip_common_prefix tl tl' else (a, b) + | a, b -> (a, b) + +let detailed_opam_diff pkg l r = + let no_build_install_url p = + OpamFile.OPAM.with_url_opt None + (OpamFile.OPAM.with_install [] (OpamFile.OPAM.with_build [] p)) + in + let otherwise_equal = + OpamFile.OPAM.effectively_equal (no_build_install_url l) + (no_build_install_url r) + and build = + if OpamFile.OPAM.build l = OpamFile.OPAM.build r then None + else + Some (strip_common_prefix (OpamFile.OPAM.build l) (OpamFile.OPAM.build r)) + and install = + if OpamFile.OPAM.install l = OpamFile.OPAM.install r then None + else + Some + (strip_common_prefix (OpamFile.OPAM.install l) (OpamFile.OPAM.install r)) + and url = + if OpamFile.OPAM.url l = OpamFile.OPAM.url r then None + else Some (OpamFile.OPAM.url l, OpamFile.OPAM.url r) + in + { pkg; build; install; url; otherwise_equal } + +let detailed_opam_diffs left right pkgs = + OpamPackage.Set.fold + (fun p acc -> + let find = OpamPackage.Name.Map.find p.name in + let opam_left = find left.OpamFile.SwitchExport.overlays + and opam_right = find right.OpamFile.SwitchExport.overlays in + detailed_opam_diff p opam_left opam_right :: acc) + pkgs [] + +let compare left right = + let packages_left = packages left and packages_right = packages right in + let module Set = OpamPackage.Set in + let equal_name p1 p2 = + OpamPackage.Name.equal p1.OpamPackage.name p2.OpamPackage.name + in + let diff l r = Set.filter (fun p1 -> not (Set.exists (equal_name p1) r)) l in + let same_version = Set.inter packages_left packages_right in + let opam_diff = + Set.filter + (fun p -> + let find = OpamPackage.Name.Map.find p.name in + let opam_left = find left.overlays + and opam_right = find right.overlays in + not (OpamFile.OPAM.effectively_equal opam_left opam_right)) + same_version + and version_diff = + List.filter_map + (fun p1 -> + match Set.find_opt (equal_name p1) packages_right with + | Some p2 -> + if OpamPackage.Version.equal p1.version p2.version then None + else + Some + { + name= p1.OpamPackage.name + ; version_left= p1.OpamPackage.version + ; version_right= p2.OpamPackage.version + } + | None -> None) + (Set.elements packages_left) + and left_pkgs = diff packages_left packages_right + and right_pkgs = diff packages_right packages_left in + let opam_diff = detailed_opam_diffs left right opam_diff in + let duniverse_ret = + match (duniverse left, duniverse right) with + | Ok l, Ok r -> Ok (duniverse_diff l r) + | (Error _ as e), _ | _, (Error _ as e) -> e + in + (opam_diff, version_diff, left_pkgs, right_pkgs, duniverse_ret) + +let compare_to_json + (opam_diff, version_diff, left_pkgs, right_pkgs, duniverse_diff) : + Yojson.Basic.t = + let version_diff_to_json lst = + `List + (List.map + (fun { name; version_left; version_right } -> + `Assoc + [ + ("name", `String (OpamPackage.Name.to_string name)) + ; ( "version_left" + , `String (OpamPackage.Version.to_string version_left) ) + ; ( "version_right" + , `String (OpamPackage.Version.to_string version_right) ) + ]) + lst) + in + let package_set_to_json set = + `List + (Set.fold + (fun p acc -> + let json = + `Assoc + [ + ( "name" + , `String (OpamPackage.Name.to_string p.OpamPackage.name) ) + ; ( "version" + , `String (OpamPackage.Version.to_string p.OpamPackage.version) + ) + ] + in + json :: acc) + set []) + in + let opam_diff_to_json opam_diff = + `List + (List.map + (fun (diff : opam_diff) -> + `Assoc + [ + ("package_version", `String (OpamPackage.to_string diff.pkg)) + ; ("otherwise_equal", `Bool diff.otherwise_equal) + ]) + opam_diff) + in + let duniverse_to_json = function + | Ok (left, right, detailed_diff) -> + `Assoc + [ + ( "left" + , `List + (List.map + (fun (k, v) -> + `Assoc [ ("name", `String k); ("value", `String v) ]) + left) ) + ; ( "right" + , `List + (List.map + (fun (k, v) -> + `Assoc [ ("name", `String k); ("value", `String v) ]) + right) ) + ; ( "detailed_diff" + , `List + (List.map + (fun (diff : duniverse_diff) -> + `Assoc [ ("name", `String diff.name) ]) + detailed_diff) ) + ] + | Error (`Msg msg) -> `String msg + in + `Assoc + [ + ("opam_diff", opam_diff_to_json opam_diff) + ; ("version_diff", version_diff_to_json version_diff) + ; ("only_in_left", package_set_to_json left_pkgs) + ; ("only_in_right", package_set_to_json right_pkgs) + ; ("duniverse_diff", duniverse_to_json duniverse_diff) + ] diff --git a/opamdiff.mli b/opamdiff.mli new file mode 100644 index 0000000..781bf16 --- /dev/null +++ b/opamdiff.mli @@ -0,0 +1,52 @@ +type opam_diff = { + pkg: OpamPackage.t + ; build: (OpamTypes.command list * OpamTypes.command list) option + ; install: (OpamTypes.command list * OpamTypes.command list) option + ; url: (OpamFile.URL.t option * OpamFile.URL.t option) option + ; otherwise_equal: bool +} + +type version_diff = { + name: OpamPackage.Name.t + ; version_left: OpamPackage.Version.t + ; version_right: OpamPackage.Version.t +} + +type duniverse_diff = { + name: string + ; urls: string * string option + ; hash: (OpamHash.kind * string option * string option) list +} + +val pp_opampackage : Format.formatter -> OpamPackage.t -> unit +val pp_version_diff : Format.formatter -> version_diff -> unit +val pp_duniverse_diff : Format.formatter -> duniverse_diff -> unit +val pp_duniverse_dir : Format.formatter -> string * string -> unit +val pp_opam_diff : Format.formatter -> opam_diff -> unit + +val commands_to_strings : + OpamTypes.command list * OpamTypes.command list -> string list * string list + +val opt_url_to_string : + OpamFile.URL.t option * OpamFile.URL.t option -> string * string + +val compare : + OpamFile.SwitchExport.t + -> OpamFile.SwitchExport.t + -> opam_diff list + * version_diff list + * OpamPackage.Set.t + * OpamPackage.Set.t + * ( (string * string) list * (string * string) list * duniverse_diff list + , [> `Msg of string ] ) + result + +val compare_to_json : + opam_diff list + * version_diff list + * OpamPackage.Set.t + * OpamPackage.Set.t + * ( (string * string) list * (string * string) list * duniverse_diff list + , [< `Msg of string ] ) + result + -> Yojson.Basic.t diff --git a/opamdiff.opam b/opamdiff.opam new file mode 100644 index 0000000..f587d7e --- /dev/null +++ b/opamdiff.opam @@ -0,0 +1,27 @@ +opam-version: "2.0" +maintainer: "Robur " +authors: ["Robur "] +homepage: "https://github.com/robur-coop/opamdiff" +dev-repo: "git+https://github.com/robur-coop/opamdiff.git" +bug-reports: "https://github.com/robur-coop/opamdiff/issues" +license: "BSD-3-clause" + +depends: [ + "ocaml" {>= "4.13.0"} + "dune" {>= "2.7.0"} + "opam-core" + "opam-format" + "yojson" +] +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] +] + +synopsis: "" + +description: " + +" + +x-maintenance-intent: [ "(latest)" ]