compare environment and system packages as well

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,42 @@ 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

@@ -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 -> [
@@ -313,6 +319,8 @@ let opam_diffs 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)
@@ -353,6 +361,30 @@ let compare_opam job_left job_right
           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"];
@@ -369,4 +401,16 @@ let compare_opam job_left job_right
       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);
     ])