From 5f8325b60b9e2b99d49497ce694b37a650e003f3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= <reynir@reynir.dk>
Date: Mon, 14 Dec 2020 08:18:13 +0100
Subject: [PATCH] Add SHA256 & SHA512 digests of build artifacts

---
 lib/builder_web.ml |  6 +++---
 lib/model.ml       | 37 ++++++++++++++++++++++++++++++-------
 lib/model.mli      |  8 ++++++++
 lib/views.ml       | 13 +++++++++++++
 4 files changed, 54 insertions(+), 10 deletions(-)

diff --git a/lib/builder_web.ml b/lib/builder_web.ml
index 4b02450..1196881 100644
--- a/lib/builder_web.ml
+++ b/lib/builder_web.ml
@@ -50,14 +50,14 @@ let routes (t : Model.t) =
     let+ job_run =
       Lwt_result.lift (safe_seg job) >>= fun job ->
       Lwt_result.lift (safe_seg run) >>= fun run ->
-      Model.read_full t job run in
+      Model.read_full_with_digests t job run in
     match job_run with
     | Error (`Msg e) ->
       Log.warn (fun m -> m "Error getting job run: %s" e);
       Response.of_plain_text ~status:`Internal_server_error
         "Error getting job run"
-    | Ok job_run ->
-      Views.job_run job_run |> Response.of_html
+    | Ok (job_run, digests) ->
+      Views.job_run job_run digests |> Response.of_html
   in
 
   [
diff --git a/lib/model.ml b/lib/model.ml
index 9594b63..c422c28 100644
--- a/lib/model.ml
+++ b/lib/model.ml
@@ -24,12 +24,18 @@ type job_run_info = {
   data : (Fpath.t * string) list
 }
 
-type t = {
-  dir : Fpath.t;
-  mutable cache : job_run_meta RunMap.t
+type digest = {
+  sha256 : string;
+  sha512 : string;
 }
 
-let init dir = { dir; cache = RunMap.empty; }
+type t = {
+  dir : Fpath.t;
+  mutable meta_cache : job_run_meta RunMap.t;
+  mutable digest_cache : (Fpath.t * digest) list RunMap.t
+}
+
+let init dir = { dir; meta_cache = RunMap.empty; digest_cache = RunMap.empty; }
 
 type job = {
   path : Fpath.t;
@@ -46,17 +52,34 @@ let read_full t path run =
   Builder.Asn.exec_of_cs (Cstruct.of_string s)
   >>| fun (job_info, uuid, out, start, finish, result, data) ->
   let meta = { job_info; uuid; start; finish; result } in
-  t.cache <- RunMap.add (path, run) meta t.cache;
+  t.meta_cache <- RunMap.add (path, run) meta t.meta_cache;
   { meta; out; data }
 
+let digest (path, data) =
+  let module H = Mirage_crypto.Hash in
+  let data = Cstruct.of_string data in
+  (path, {
+      sha256 = H.SHA256.digest data |> Cstruct.to_string;
+      sha512 = H.SHA512.digest data |> Cstruct.to_string;
+    })
+
+let read_full_with_digests t path run =
+  read_full t path run >|= fun ({ data; _ } as full) ->
+  match RunMap.find_opt (path, run) t.digest_cache with
+  | Some digests -> full, digests
+  | None ->
+    let digests = List.map digest data in
+    t.digest_cache <- RunMap.add (path, run) digests t.digest_cache;
+    full, digests
+
 let read_full_meta t path run =
-  match RunMap.find_opt (path, run) t.cache with
+  match RunMap.find_opt (path, run) t.meta_cache with
   | Some meta ->
     Lwt_result.lift (Bos.OS.File.exists Fpath.(t.dir // path // run / "full")) >>= fun exists ->
     if exists
     then Lwt_result.return meta
     else
-      (t.cache <- RunMap.remove (path, run) t.cache;
+      (t.meta_cache <- RunMap.remove (path, run) t.meta_cache;
        Lwt_result.fail (`Msg "no such file"))
   | None ->
     read_full t path run >|= fun { meta; out = _; data = _ }  ->
diff --git a/lib/model.mli b/lib/model.mli
index 638e005..8058aa5 100644
--- a/lib/model.mli
+++ b/lib/model.mli
@@ -8,6 +8,11 @@ type job_run_meta = {
   result : Builder.execution_result;
 }
 
+type digest = {
+  sha256 : string;
+  sha512 : string;
+}
+
 type job_run_info = {
   meta : job_run_meta;
   out : (int * string) list;
@@ -25,5 +30,8 @@ val job_name : job -> string
 
 val read_full : t -> Fpath.t -> Fpath.t -> (job_run_info, [> `Msg of string ]) result Lwt.t
 
+val read_full_with_digests : t -> Fpath.t -> Fpath.t ->
+  (job_run_info * (Fpath.t * digest) list, [> `Msg of string ]) result Lwt.t
+
 val job : t -> Fpath.t -> (job, [> `Msg of string]) result Lwt.t
 val jobs : t -> (Fpath.t list, [> `Msg of string ]) result Lwt.t
diff --git a/lib/views.ml b/lib/views.ml
index b784c6d..505fd3e 100644
--- a/lib/views.ml
+++ b/lib/views.ml
@@ -84,6 +84,7 @@ let job_run
           Model.job_info = { Builder.name; _ };
           start; finish; uuid = _; result };
       out; data = _ }
+    digests
   =
   let ptime_pp = Ptime.pp_human () in
   let delta = Ptime.diff finish start in
@@ -91,6 +92,18 @@ let job_run
     [ h1 [txtf "Job build %s %a" name ptime_pp start];
       p [txtf "Build took %a." Ptime.Span.pp delta ];
       p [txtf "Execution result: %a." Builder.pp_execution_result result];
+      h3 [txt "Digests of build artifacts"];
+      dl (List.concat_map
+            (fun (path, { Model.sha256; sha512 }) -> [
+                 dt [code [txtf "%a" Fpath.pp path];
+                     txt "(SHA256)"];
+                 dd [code [txtf "%s" (Base64.encode_string sha256)]];
+                 dt [code [txtf "%a" Fpath.pp path];
+                     txt "(SHA512)"];
+                 dd [code [txtf "%s" (Base64.encode_string sha512)]];
+               ])
+            digests);
+      h3 [txt "Build log"];
       table
         (List.mapi (fun idx (ts, line) ->
              let ts_id = "L" ^ string_of_int idx in