investigate differences in build, install, and uri when opam file differed (#48)

compare environment and system packages as well

investigate differences in build, install, and uri when opam file differed

Co-authored-by: Robur <team@robur.coop>
Reviewed-on: https://git.robur.io/robur/builder-web/pulls/48
Co-Authored-By: hannes <hannes@mehnert.org>
Co-Committed-By: hannes <hannes@mehnert.org>

lib/builder_web.ml

@@ -232,17 +232,32 @@ let add_routes datadir =
      Dream.sql req (Model.build build_right) >>= fun (_id, build_right) ->
      Dream.sql req (Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "opam-switch")) >>=
      Model.build_artifact_data datadir >>= fun switch_left ->
+     Dream.sql req (Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "build-environment")) >>=
+     Model.build_artifact_data datadir >>= fun build_env_left ->
+     Dream.sql req (Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "system-packages")) >>=
+     Model.build_artifact_data datadir >>= fun system_packages_left ->
      Dream.sql req (Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "opam-switch")) >>=
      Model.build_artifact_data datadir >>= fun switch_right ->
+     Dream.sql req (Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "build-environment")) >>=
+     Model.build_artifact_data datadir >>= fun build_env_right ->
+     Dream.sql req (Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "system-packages")) >>=
+     Model.build_artifact_data datadir >>= fun system_packages_right ->
      Dream.sql req (Model.job_name build_left.job_id) >>= fun job_left ->
      Dream.sql req (Model.job_name build_right.job_id) >|= fun job_right ->
-     (job_left, job_right, build_left, build_right, switch_left, switch_right))
+     (job_left, job_right, build_left, build_right,
+      switch_left, build_env_left, system_packages_left,
+      switch_right, build_env_right, system_packages_right))
     |> if_error "Internal server error"
-    >>= fun (job_left, job_right, build_left, build_right, switch_left, switch_right) ->
+    >>= fun (job_left, job_right, build_left, build_right,
+             switch_left, build_env_left, system_packages_left,
+             switch_right, build_env_right, system_packages_right) ->
+    let env_diff = Utils.compare_env build_env_left build_env_right
+    and pkg_diff = Utils.compare_pkgs system_packages_left system_packages_right
+    in
     let switch_left = OpamFile.SwitchExport.read_from_string switch_left
     and switch_right = OpamFile.SwitchExport.read_from_string switch_right in
     Opamdiff.compare switch_left switch_right
-    |> Views.compare_opam job_left job_right build_left build_right
+    |> Views.compare_opam job_left job_right build_left build_right env_diff pkg_diff
     |> string_of_html |> Dream.html |> Lwt_result.ok
   in
 

lib/utils.ml

@@ -6,3 +6,41 @@ module String_map = struct
     update key (function None -> Some [ v ] | Some xs -> Some (v :: xs)) t
 end
 
+let diff_map a b =
+  let diff a b =
+    String_map.fold (fun k v acc ->
+      if not (String_map.mem k b) then (k, v) :: acc else acc)
+      a []
+  in
+  let added = diff b a
+  and removed = diff a b
+  and changed =
+    String_map.fold (fun k v acc ->
+      match String_map.find_opt k b with
+      | None -> acc
+      | Some v' -> if String.equal v v' then acc else (k, v, v') :: acc)
+    a []
+  in
+  (added, removed, changed)
+
+let compare_env env1 env2 =
+  let parse_env e =
+    List.fold_left (fun m s ->
+      match Astring.String.cut ~sep:"=" s with
+      | Some (key, value) -> String_map.add key value m
+      | None -> String_map.add s "" m)
+    String_map.empty (Astring.String.cuts ~sep:"\n" e)
+  in
+  diff_map (parse_env env1) (parse_env env2)
+
+let compare_pkgs p1 p2 =
+  let parse_pkgs p =
+    List.fold_left (fun m s ->
+      match Astring.String.cut ~sep:"=" s with
+      | Some (name, version) -> String_map.add name version m
+      | None -> match Astring.String.cut ~sep:"-" s with
+        | Some (name, version) -> String_map.add name version m
+        | None -> String_map.add s "" m)
+    String_map.empty (Astring.String.cuts ~sep:"\n" p)
+  in
+  diff_map (parse_pkgs p1) (parse_pkgs p2)

lib/views.ml

@@ -226,7 +226,7 @@ let job_build
        | Some previous_build when successful_build ->
          p [
            a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch"
-                   Uuidm.pp uuid Uuidm.pp previous_build.Builder_db.Build.Meta.uuid]
+                   Uuidm.pp previous_build.Builder_db.Build.Meta.uuid Uuidm.pp uuid]
              [txt "Compare opam-switch with previous build"];
          ]
        | _ -> txt "");
@@ -267,6 +267,12 @@ let job_build
         ];
     ])
 
+let key_values xs =
+  List.concat_map (fun (k, v) -> [ txtf "%s %s" k v ; br () ]) xs
+
+let key_value_changes xs =
+  List.concat_map (fun (k, v, v') -> [ txtf "%s %s->%s" k v v' ; br () ]) xs
+
 let packages packages =
   OpamPackage.Set.elements packages
   |> List.concat_map (fun p -> [
@@ -281,12 +287,44 @@ let package_diffs diffs =
       ])
     diffs
 
+let opam_diffs diffs =
+  List.concat_map (fun pd ->
+        h4 [ txtf "%a" Opamdiff.pp_opam_diff pd ] ::
+        (match pd.Opamdiff.build with None -> [] | Some a ->
+          let l, r = Opamdiff.commands_to_strings a in
+          [
+            h5 [ txt "build instruction (without common prefix) modifications, old:" ] ;
+            code (List.concat_map (fun s -> [ txt s ; br () ]) l) ;
+            h5 [ txt "new" ] ;
+            code (List.concat_map (fun s -> [ txt s ; br () ]) r)
+          ]) @
+        (match pd.Opamdiff.install with None -> [] | Some a ->
+          let l, r = Opamdiff.commands_to_strings a in
+          [
+            h5 [ txt "install instruction (without common prefix) modifications, old:" ] ;
+            code (List.concat_map (fun s -> [ txt s ; br () ]) l) ;
+            h5 [ txt "new" ] ;
+            code (List.concat_map (fun s -> [ txt s ; br () ]) r)
+         ]) @
+      (match pd.Opamdiff.url with None -> [] | Some a ->
+          let l, r = Opamdiff.opt_url_to_string a in
+          [
+            h5 [ txt "URL" ] ;
+            txtf "old: %s" l;
+            br ();
+            txtf "new: %s" r
+          ]) @
+      [ br () ])
+    diffs
+
 let compare_opam job_left job_right
     (build_left : Builder_db.Build.t) (build_right : Builder_db.Build.t)
+    (added_env, removed_env, changed_env)
+    (added_pkgs, removed_pkgs, changed_pkgs)
     (same, opam_diff, version_diff, left, right) =
   layout ~title:(Fmt.strf "Comparing opam switches between builds %a and %a"
                    Uuidm.pp build_left.uuid Uuidm.pp build_right.uuid)
-    [
+    ([
       h1 [txt "Comparing opam switches"];
       h2 [
         txt "Builds ";
@@ -317,12 +355,36 @@ let compare_opam job_left job_right
         ];
         li [
           a ~a:[a_href "#packages-opam-diff"]
-            [txtf "%d packages with changes in their opam file" (OpamPackage.Set.cardinal opam_diff)]
+            [txtf "%d packages with changes in their opam file" (List.length opam_diff)]
         ];
         li [
           a ~a:[a_href "#packages-unchanged"]
             [txtf "%d packages unchanged" (OpamPackage.Set.cardinal same)]
         ];
+        li [
+         a ~a:[a_href "#env-added"]
+            [ txtf "%d environment variables added" (List.length added_env)]
+        ];
+        li [
+         a ~a:[a_href "#env-removed"]
+            [ txtf "%d environment variables removed" (List.length removed_env)]
+        ];
+        li [
+         a ~a:[a_href "#env-changed"]
+            [ txtf "%d environment variables changed" (List.length changed_env)]
+        ];
+        li [
+         a ~a:[a_href "#pkgs-added"]
+            [ txtf "%d system packages added" (List.length added_pkgs)]
+        ];
+        li [
+         a ~a:[a_href "#pkgs-removed"]
+            [ txtf "%d system packages removed" (List.length removed_pkgs)]
+        ];
+        li [
+         a ~a:[a_href "#pkgs-changed"]
+            [ txtf "%d system packages changed" (List.length changed_pkgs)]
+        ];
       ];
       h3 ~a:[a_id "packages-removed"]
         [txt "Packages removed"];
@@ -334,9 +396,21 @@ let compare_opam job_left job_right
         [txt "Packages with version changes"];
       code (package_diffs version_diff);
       h3 ~a:[a_id "packages-opam-diff"]
-        [txt "Packages with changes in their opam file"];
-      code (packages opam_diff);
+        [txt "Packages with changes in their opam file"]] @
+      opam_diffs opam_diff @ [
       h3 ~a:[a_id "packages-unchanged"]
         [txt "Unchanged packages"];
       code (packages same);
-    ]
+      h3 ~a:[a_id "env-added"] [txt "Environment variables added"];
+      code (key_values added_env);
+      h3 ~a:[a_id "env-removed"] [txt "Environment variables removed"];
+      code (key_values removed_env);
+      h3 ~a:[a_id "env-changed"] [txt "Environment variables changed"];
+      code (key_value_changes changed_env);
+      h3 ~a:[a_id "pkgs-added"] [txt "System packages added"];
+      code (key_values added_pkgs);
+      h3 ~a:[a_id "pkgs-removed"] [txt "System packages removed"];
+      code (key_values removed_pkgs);
+      h3 ~a:[a_id "pkgs-changed"] [txt "System packages changed"];
+      code (key_value_changes changed_pkgs);
+    ])

opamdiff/opamdiff.ml

@@ -23,6 +23,75 @@ let pp_version_diff ppf { name; version_left; version_right } =
     (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
@@ -53,7 +122,8 @@ let compare left right =
         | None ->
           None)
       (Set.elements packages_left)
-  and left = diff packages_left packages_right
-  and right = diff packages_right packages_left
+  and left_pkgs = diff packages_left packages_right
+  and right_pkgs = diff packages_right packages_left
   in
-  (same, opam_diff, version_diff, left, right)
+  let opam_diff = detailed_opam_diffs left right opam_diff in
+  (same, opam_diff, version_diff, left_pkgs, right_pkgs)