display visualizations from cache, generate visualizations on upload (#90)

This is #88 (reading visualiations from the cache directory), together with shell scripts that can be used as upload hooks to generate the visualizations.

Co-authored-by: rand00 <oth.rand@gmail.com>
Co-authored-by: Hannes Mehnert <hannes@mehnert.org>
Co-authored-by: Reynir Björnsson <reynir@reynir.dk>
Co-authored-by: Robur <team@robur.coop>
Reviewed-on: https://git.robur.io/robur/builder-web/pulls/90
Co-authored-by: hannes <hannes@mehnert.org>
Co-committed-by: hannes <hannes@mehnert.org>

lib/builder_web.ml

@@ -198,78 +198,41 @@ let add_routes datadir configdir =
       |> Lwt_result.ok
   in
 
-  let visualization_cmd args =
-    let cmd_list = "builder-viz" :: args in
-    let cmd = "", Array.of_list cmd_list in
-    let pin =
-      Lwt_process.open_process_in
-        ~stdin:`Dev_null ~stderr:`Dev_null
-        ~timeout:15.
-        cmd
+  let try_load_cached_visualization ~datadir ~uuid typ =
+    let fn = match typ with
+      | `Treemap -> "treemap"
+      | `Dependencies -> "dependencies"
     in
-    let* output = Lwt_io.read pin#stdout
-    and* exit_status = pin#status in
-    match exit_status with
-    | Unix.WEXITED 0 -> Lwt_result.return output
-    | Unix.WEXITED _ | Unix.WSIGNALED _ |Unix.WSTOPPED _ ->
-      let cmd_str = String.concat " " cmd_list in
-      `Msg (sprintf "Error when running cmd: '%s'" cmd_str)
-      |> Lwt_result.fail
-  in
-
-  let treemap_visualization_cmd ~debug_elf_path ~elf_size =
-    [ "treemap"; debug_elf_path; Int.to_string elf_size ]
-    |> visualization_cmd
-  in
-
-  let dependencies_visualization_cmd ~opam_switch_path =
-    [ "dependencies"; opam_switch_path ]
-    |> visualization_cmd
+    let path = Fpath.(datadir / "_cache" / Uuidm.to_string uuid + fn + "html") in
+    Lwt.return (Bos.OS.File.exists path) >>= fun cached_file_exists ->
+    if not cached_file_exists then
+      Lwt_result.fail (`Msg "Visualization does not exist")
+    else
+      Lwt_result.catch (
+        Lwt_io.with_file ~mode:Lwt_io.Input
+          (Fpath.to_string path)
+          Lwt_io.read
+      ) |> Lwt_result.map_err (fun exn -> `Msg (Printexc.to_string exn))
   in
 
   let job_build_viztreemap req =
     let _job_name = Dream.param "job" req
-    and build = Dream.param "build" req in
+    and build = Dream.param "build" req
+    and datadir = Dream.global datadir_global req in
     get_uuid build >>= fun uuid ->
-    (
-      Dream.sql req (Model.build uuid) >>= fun (_id, build) ->
-      Model.not_found build.Builder_db.Build.main_binary >>= fun main_binary_id ->
-      Dream.sql req (Model.build_artifact_by_id main_binary_id) >>= fun main_binary ->
-      let debug_binary_path = Fpath.(base main_binary.Builder_db.filepath + "debug") in
-      (* lookup debug_binary_path artifact *)
-      Dream.sql req (Model.build_artifact uuid debug_binary_path) >>= fun debug_binary ->
-      Lwt_result.return (debug_binary, main_binary))
-    |> if_error "Error getting job build"
-      ~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
-    >>= fun (debug_binary, main_binary) ->
-    let elf_size = main_binary.Builder_db.size in
-    let datadir = Dream.global datadir_global req in
-    let debug_elf_path = Fpath.(
-      datadir // debug_binary.Builder_db.localpath
-      |> to_string
-    ) in
-    treemap_visualization_cmd ~debug_elf_path ~elf_size
-    |> if_error "Failed to generate treemap visualization"
+    (try_load_cached_visualization ~datadir ~uuid `Treemap
+     |> if_error "Error getting cached visualization")
     >>= fun svg_html ->
     Lwt_result.ok (Dream.html svg_html)
   in
 
   let job_build_vizdependencies req =
     let _job_name = Dream.param "job" req
-    and build = Dream.param "build" req in
+    and build = Dream.param "build" req
+    and datadir = Dream.global datadir_global req in
     get_uuid build >>= fun uuid ->
-    let opam_switch_path = Fpath.(v "opam-switch") in
-    Dream.sql req (Model.build_artifact uuid opam_switch_path)
-    |> if_error "Error getting job build"
-      ~log:(fun e -> Log.warn (fun m -> m "Error getting job data: %a" pp_error e))
-    >>= fun opam_switch ->
-    let datadir = Dream.global datadir_global req in
-    let opam_switch_path = Fpath.(
-      datadir // opam_switch.Builder_db.localpath
-      |> to_string
-    ) in
-    dependencies_visualization_cmd ~opam_switch_path
-    |> if_error "Failed to generate dependencies visualization"
+    (try_load_cached_visualization ~datadir ~uuid `Dependencies
+     |> if_error "Error getting cached visualization")
     >>= fun svg_html ->
     Lwt_result.ok (Dream.html svg_html)
   in

lib/model.ml

@@ -382,25 +382,26 @@ let add_build
      match readme, readme_anywhere with
      | None, None -> Lwt_result.return ()
      | Some (_, data), _ | None, Some (_, data) -> add_or_update readme_id data) >>= fun () ->
+    (match List.partition (fun p -> Fpath.(is_prefix (v "bin/") p.filepath)) artifacts with
+     | [ main_binary ], other_artifacts ->
+       Db.exec Build_artifact.add (main_binary, id) >>= fun () ->
+       Db.find Builder_db.last_insert_rowid () >>= fun main_binary_id ->
+       Db.exec Build.set_main_binary (id, main_binary_id) >|= fun () ->
+       Some main_binary, other_artifacts
+     | [], _ ->
+       Log.debug (fun m -> m "Zero binaries for build %a" Uuidm.pp uuid);
+       Lwt_result.return (None, artifacts)
+     | xs, _ ->
+       Log.warn (fun m -> m "Multiple binaries for build %a: %a" Uuidm.pp uuid
+                    Fmt.(list ~sep:(any ",") Fpath.pp)
+                    (List.map (fun a -> a.filepath) xs));
+       Lwt_result.return (None, artifacts)) >>= fun (main_binary, remaining_artifacts_to_add) ->
     List.fold_left
       (fun r file ->
          r >>= fun () ->
          Db.exec Build_artifact.add (file, id))
       (Lwt_result.return ())
-      artifacts >>= fun () ->
-    Db.collect_list Build_artifact.get_all_by_build id >>= fun artifacts ->
-    (match List.filter (fun (_, p) -> Fpath.(is_prefix (v "bin/") p.filepath)) artifacts with
-     | [ (build_artifact_id, p) ] ->
-       Db.exec Build.set_main_binary (id, build_artifact_id) >|= fun () ->
-       Some p
-     | [] ->
-       Log.debug (fun m -> m "Zero binaries for build %a" Uuidm.pp uuid);
-       Lwt_result.return None
-     | xs ->
-       Log.warn (fun m -> m "Multiple binaries for build %a: %a" Uuidm.pp uuid
-                    Fmt.(list ~sep:(any ",") Fpath.pp)
-                    (List.map (fun (_, a) -> a.filepath) xs));
-       Lwt_result.return None) >>= fun main_binary ->
+      remaining_artifacts_to_add >>= fun () ->
     Db.commit () >>= fun () ->
     commit_files datadir staging_dir job_name uuid >|= fun () ->
     main_binary
@@ -423,13 +424,31 @@ let add_build
       Printf.sprintf "%04d%02d%02d%02d%02d%02d" y m d hh mm ss
     and job = job.name
     and platform = job.platform
+    and debug_binary =
+      let bin = Fpath.base p.localpath in
+      List.find_opt
+        (fun p -> Fpath.(equal (bin + "debug") (base p.localpath)))
+        artifacts |>
+      Option.map (fun p -> p.localpath)
+    and opam_switch =
+      List.find_opt
+        (fun p -> Fpath.(equal (v "opam-switch") (base p.localpath)))
+        artifacts |>
+      Option.map (fun p -> p.localpath)
+    in
+    let fp_str p = Fpath.(to_string (datadir // p)) in
+    let opt_str ~prefix p =
+      Option.fold ~none:[] ~some:(fun p -> [ "--" ^ prefix ^ "=" ^ fp_str p ]) p
     in
     let args =
       String.concat " "
         (List.map (fun s -> "\"" ^ String.escaped s ^ "\"")
-           [ "--build-time=" ^ time ; "--sha256=" ^ sha256 ; "--job=" ^ job ;
-             "--uuid=" ^ uuid ; "--platform=" ^ platform ;
-             Fpath.(to_string (datadir // main_binary)) ])
+           ((opt_str ~prefix:"debug-binary" debug_binary) @
+            (opt_str ~prefix:"opam-switch" opam_switch) @
+            [ "--build-time=" ^ time ; "--sha256=" ^ sha256 ; "--job=" ^ job ;
+              "--uuid=" ^ uuid ; "--platform=" ^ platform ;
+              "--cache-dir=" ^ fp_str (Fpath.v "_cache") ;
+              fp_str main_binary ]))
     in
     Log.debug (fun m -> m "executing hooks with %s" args);
     let dir = Fpath.(configdir / "upload-hooks") in

packaging/batch-viz.sh

@@ -0,0 +1,59 @@
+#!/bin/sh
+
+set -e
+
+prog_NAME=$(basename "${0}")
+
+warn()
+{
+    echo "${prog_NAME}: WARN: $*"
+}
+
+err()
+{
+    echo "${prog_NAME}: ERROR: $*" 1>&2
+}
+
+die()
+{
+    echo "${prog_NAME}: ERROR: $*" 1>&2
+    exit 1
+}
+
+usage()
+{
+    cat <<EOM 1>&2
+usage: ${prog_NAME} [ OPTIONS ] DATADIR
+Generates visualizations of all things
+EOM
+    exit 1
+}
+
+if [ $# -ne 1 ]; then
+    usage
+fi
+
+DIR="${1}"
+
+CACHE="${DIR}/_cache"
+
+for i in $(find "${DIR}" -type f -path \*output/bin\*); do
+    UUID=$(echo "${i}" | rev | cut -d '/' -f 4 | rev)
+    ARGS="--cache-dir="${CACHE}" --uuid="${UUID}""
+    FILE=$(basename "${i}")
+    DIR=$(dirname "${i}")
+    PDIR="${DIR}/.."
+    ARGS2=
+    if [ -f "${PDIR}/${FILE}.debug" ]; then
+        ARGS2="${ARGS2} --debug-binary="${PDIR}/${FILE}.debug""
+    fi
+    if [ -f "${PDIR}/opam-switch" ]; then
+        ARGS2="${ARGS2} --opam-switch="${PDIR}/opam-switch""
+    fi
+    if [ -z "${ARGS2}" ]; then
+        echo "neither debug nor opam switch found for ${UUID}"
+    else
+        ARGS="${ARGS}${ARGS2} ${i}"
+        ./visualizations.sh ${ARGS}
+    fi
+done

packaging/visualizations.sh

@@ -0,0 +1,109 @@
+#!/bin/sh
+
+set -ex
+
+prog_NAME=$(basename "${0}")
+
+warn()
+{
+    echo "${prog_NAME}: WARN: $*"
+}
+
+err()
+{
+    echo "${prog_NAME}: ERROR: $*" 1>&2
+}
+
+die()
+{
+    echo "${prog_NAME}: ERROR: $*" 1>&2
+    exit 1
+}
+
+usage()
+{
+    cat <<EOM 1>&2
+usage: ${prog_NAME} [ OPTIONS ] FILE
+Generates visualizations
+Options:
+    --debug-binary=STRING
+        Path to debug binary.
+    --opam-switch=STRING
+        Path to opam switch.
+    --uuid=STRING
+        UUID of build.
+    --cache-dir=STRING
+        Path to the cache directory.
+EOM
+    exit 1
+}
+
+DEBUG=
+OPAM=
+UUID=
+CACHE=
+
+while [ $# -gt 1 ]; do
+    OPT="$1"
+
+    case "${OPT}" in
+        --debug-binary=*)
+            DEBUG="${OPT##*=}"
+            ;;
+        --opam-switch=*)
+            OPAM="${OPT##*=}"
+            ;;
+        --uuid=*)
+            UUID="${OPT##*=}"
+            ;;
+        --cache-dir=*)
+            CACHE="${OPT##*=}"
+            ;;
+        --*)
+            warn "Ignoring unknown option: '${OPT}'"
+            ;;
+        *)
+            err "Unknown option: '${OPT}'"
+            usage
+            ;;
+    esac
+    shift
+done
+
+[ -z "${UUID}" ] && die "The --uuid option must be specified"
+[ -z "${CACHE}" ] && die "The --cache-dir option must be specified"
+[ -z "${OPAM}" ] && die "The --opam-switch option must be specified"
+
+FILENAME="${1}"
+CACHE_DIR="${CACHE}/${UUID}"
+BUILDER_VIZ="builder-viz"
+
+TMPTREE=$(mktemp -t treevis)
+TMPOPAM=$(mktemp -t opamvis)
+cleanup () {
+  rm -rf "${TMPTREE}" "${TMPOPAM}"
+}
+
+trap cleanup EXIT
+
+if [ -e "${CACHE_DIR}.dependencies.html" ]; then
+    echo "Dependency visualization already exists ${CACHE_DIR}.dependencies.html"
+else
+    if ${BUILDER_VIZ} dependencies "${OPAM}" > "${TMPOPAM}"; then
+        mv "${TMPOPAM}" "${CACHE_DIR}.dependencies.html"
+    fi
+fi
+
+SIZE="$(stat -f "%z" ${FILENAME})"
+
+if [ ! -z "${DEBUG}" ]; then
+    if [ -e "${CACHE_DIR}.treemap.html" ]; then
+        echo "Treemap visualization already exists ${CACHE_DIR}.treemap.html"
+    else
+        if ${BUILDER_VIZ} treemap "${DEBUG}" "${SIZE}" > "${TMPTREE}"; then
+            mv "${TMPTREE}" "${CACHE_DIR}.treemap.html"
+        fi
+    fi
+else
+    echo "No --debug-binary provided, not producing any treemap"
+fi