From 5d33d4cfafb423359f5a97b7ca8cc00c9bb4b47b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= <reynir@reynir.dk>
Date: Tue, 7 Dec 2021 17:13:21 +0100
Subject: [PATCH] builder-db: add extract-build command

This command synthesizes a file containing the ASN.1 representation of a
Builder build.
---
 bin/builder_db_app.ml | 94 ++++++++++++++++++++++++++++++++++++++++++-
 bin/dune              |  2 +-
 2 files changed, 94 insertions(+), 2 deletions(-)

diff --git a/bin/builder_db_app.ml b/bin/builder_db_app.ml
index af5682c..b5cfb01 100644
--- a/bin/builder_db_app.ml
+++ b/bin/builder_db_app.ml
@@ -313,6 +313,81 @@ let verify_data_dir () datadir =
     files_untracked;
   or_die 1 r
 
+module Asn = struct
+  let decode_strict codec cs =
+    match Asn.decode codec cs with
+    | Ok (a, cs) ->
+      if Cstruct.length cs = 0
+      then Ok a
+      else Error "trailing bytes"
+    | Error (`Parse msg) -> Error ("parse error: " ^ msg)
+
+  let projections_of asn =
+    let c = Asn.codec Asn.der asn in
+    (decode_strict c, Asn.encode c)
+
+  let console =
+    Asn.S.(sequence_of
+             (sequence2
+                (required ~label:"delta" int)
+                (required ~label:"data" utf8_string)))
+
+  let console_of_cs, console_to_cs = projections_of console
+end
+
+let console_of_string data =
+  let lines = String.split_on_char '\n' data in
+  (* remove last empty line *)
+  let lines =
+    match List.rev lines with
+    | "" :: lines -> List.rev lines
+    | _ -> lines
+  in
+  List.map (fun line ->
+      match String.split_on_char ':' line with
+      | ts :: tail ->
+        let delta = float_of_string (String.sub ts 0 (String.length ts - 1)) in
+        Int64.to_int (Duration.of_f delta), String.concat ":" tail
+      | _ -> assert false)
+    lines
+
+let extract_full () datadir dest uuid =
+  let dbpath = datadir ^ "/builder.sqlite3" in
+  let r =
+    let* (module Db : Caqti_blocking.CONNECTION) =
+      connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    in
+    let* uuid = Uuidm.of_string uuid |> Option.to_result ~none:(`Msg "bad uuid") in
+    let* (build_id, build) =
+      Db.find_opt Builder_db.Build.get_by_uuid uuid
+      |> Fun.flip Result.bind (Option.to_result ~none:(`Msg "build not found"))
+    in
+    let { Builder_db.Build.start; finish; result;
+          job_id; console; script; platform; _ } =
+      build
+    in
+    let* job_name = Db.find Builder_db.Job.get job_id in
+    let script_path = Fpath.(v datadir // script) in
+    let* script = Bos.OS.File.read script_path in
+    let job = { Builder.name = job_name; platform; script } in
+    let console_path = Fpath.(v datadir // console) in
+    let* console = Bos.OS.File.read console_path in
+    let out = console_of_string console in
+    let* artifacts = Db.collect_list Builder_db.Build_artifact.get_all_by_build build_id in
+    let* data =
+      List.fold_left (fun acc (_, { Builder_db.filepath; localpath; _ }) ->
+          let* acc = acc in
+          let* data = Bos.OS.File.read Fpath.(v datadir // localpath) in
+          Ok ((filepath, data) :: acc))
+        (Ok [])
+        artifacts
+    in
+    let exec = (job, uuid, out, start, finish, result, data) in
+    let cs = Builder.Asn.exec_to_cs exec in
+    Bos.OS.File.write (Fpath.v dest) (Cstruct.to_string cs)
+  in
+  or_die 1 r
+
 let help man_format cmds = function
   | None -> `Help (man_format, None)
   | Some cmd ->
@@ -384,6 +459,17 @@ let job =
                 pos 1 (some string) None &
                 info ~doc ~docv:"JOB" [])
 
+let build =
+  let doc = "build uuid" in
+  Cmdliner.Arg.(required &
+                pos 0 (some string) None &
+                info ~doc ~docv:"BUILD" [])
+
+let full_dest =
+  let doc = "path to write build file" in
+  Cmdliner.Arg.(value & opt string "full" &
+                info ~doc ["dest"])
+
 let setup_log =
   let setup_log level =
     Logs.set_level level;
@@ -437,6 +523,11 @@ let job_remove_cmd =
   (Cmdliner.Term.(pure job_remove $ setup_log $ datadir $ jobname),
    Cmdliner.Term.info ~doc "job-remove")
 
+let extract_full_cmd =
+  let doc = "extract a build from the database" in
+  (Cmdliner.Term.(pure extract_full $ setup_log $ datadir $ full_dest $ build),
+   Cmdliner.Term.info ~doc "extract-build")
+
 let verify_input_id_cmd =
   let doc = "verify that the main binary hash of all builds with the same input are equal" in
   (Cmdliner.Term.(pure verify_input_id $ setup_log $ dbpath),
@@ -468,5 +559,6 @@ let () =
     [help_cmd; migrate_cmd;
      user_add_cmd; user_update_cmd; user_remove_cmd; user_list_cmd; user_disable_cmd;
      access_add_cmd; access_remove_cmd; job_remove_cmd;
-     verify_input_id_cmd; verify_data_dir_cmd ]
+     verify_input_id_cmd; verify_data_dir_cmd;
+     extract_full_cmd ]
   |> Cmdliner.Term.exit
diff --git a/bin/dune b/bin/dune
index cddf5b0..5e7be34 100644
--- a/bin/dune
+++ b/bin/dune
@@ -13,4 +13,4 @@
  (public_name builder-db)
  (name builder_db_app)
  (modules builder_db_app)
- (libraries builder_db builder_system caqti.blocking uri bos fmt logs logs.cli logs.fmt cmdliner mirage-crypto-rng.unix))
+ (libraries builder_db builder_system caqti.blocking uri bos fmt logs logs.cli logs.fmt cmdliner mirage-crypto-rng.unix builder))