render README from latest build (preserved as a tag value in job_tag table)

bin/migrations/builder_migrations.ml

@@ -121,5 +121,6 @@ let () =
         actions (module M20210609);
         actions (module M20210625);
         actions (module M20210629);
+        actions (module M20210630);
       ])
   |> Cmdliner.Term.exit

bin/migrations/m20210630.ml

@@ -0,0 +1,88 @@
+let new_version = 10L and old_version = 9L
+let identifier = "2021-06-30"
+let migrate_doc = "add readme.md tag"
+let rollback_doc = "remove readme.md tag"
+
+let jobs =
+  Caqti_request.collect
+    Caqti_type.unit
+    Builder_db.Rep.id
+    "SELECT id FROM job"
+
+let latest_successful_build =
+  Caqti_request.find
+    Builder_db.Rep.id
+    Builder_db.Rep.id
+    {| SELECT b.id
+       FROM build b
+       WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0
+       ORDER BY b.start_d DESC, b.start_ps DESC
+       LIMIT 1
+    |}
+
+let build_artifacts =
+  Caqti_request.collect
+    Builder_db.Rep.id
+    Caqti_type.(tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath)
+    {| SELECT a.filepath, a.localpath
+       FROM build_artifact a
+       WHERE a.build = ?
+    |}
+
+let insert_tag =
+   Caqti_request.exec
+     Caqti_type.string
+     "INSERT INTO tag (tag) VALUES (?)"
+
+let insert_job_tag =
+   Caqti_request.exec
+     Caqti_type.(tup3 Builder_db.Rep.id string Builder_db.Rep.id)
+     "INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"
+
+let find_tag =
+   Caqti_request.find
+     Caqti_type.string
+     Builder_db.Rep.id
+     "SELECT id FROM tag where tag = ?"
+
+let remove_job_tag =
+   Caqti_request.exec
+     Builder_db.Rep.id
+     "DELETE FROM job_tag where tag = ?"
+
+let remove_tag =
+   Caqti_request.exec
+     Builder_db.Rep.id
+     "DELETE FROM tag where id = ?"
+
+open Rresult.R.Infix
+
+let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
+  Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
+  Db.exec insert_tag "readme.md" >>= fun () ->
+  Db.find find_tag "readme.md" >>= fun readme_id ->
+  Db.collect_list jobs () >>= fun jobs ->
+  Grej.list_iter_result (fun job ->
+    Db.find latest_successful_build job >>= fun build ->
+    Db.collect_list build_artifacts build >>= fun artifacts ->
+    List.fold_left (fun acc (fpath, lpath) ->
+        acc >>= fun acc ->
+        Bos.OS.File.read Fpath.(append datadir lpath) >>= fun data ->
+        Ok ((fpath, data) :: acc))
+      (Ok [])
+      artifacts >>= fun files ->
+    (match List.find_opt (fun (p, _) -> Fpath.(equal (v "README.md") p)) files with
+     | None -> Ok ()
+     | Some (_, data) -> Db.exec insert_job_tag (readme_id, data, job)))
+    jobs >>= fun () ->
+  Db.exec (Grej.set_version new_version) ()
+
+let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
+  Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
+  Db.find find_tag "readme.md" >>= fun readme_id ->
+  Db.exec remove_job_tag readme_id >>= fun () ->
+  Db.exec remove_tag readme_id >>= fun () ->
+  Db.exec (Grej.set_version old_version) ()
+
+
+

builder-web.opam

@@ -43,6 +43,7 @@ depends: [
   "cmdliner"
   "uri"
   "fmt"
+  "omd"
 ]
 
 synopsis: "Web interface for builder"

db/builder_db.ml

@@ -4,7 +4,7 @@ open Rep
 let application_id = 1234839235l
 
 (* Please update this when making changes! *)
-let current_version = 9L
+let current_version = 10L
 
 type id = Rep.id
 

lib/builder_web.ml

@@ -111,11 +111,11 @@ let add_routes datadir =
 
   let job req =
     let job_name = Dream.param "job" req in
-    Dream.sql req (Model.job job_name)
+    Dream.sql req (Model.job_and_readme job_name)
     |> if_error "Error getting job"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
-    >>= fun builds ->
+    >>= fun (readme, builds) ->
-    Views.job job_name builds |> string_of_html |> Dream.html |> Lwt_result.ok
+    Views.job job_name readme builds |> string_of_html |> Dream.html |> Lwt_result.ok
   in
 
   let redirect_latest req =
@@ -134,15 +134,16 @@ let add_routes datadir =
     let job_name = Dream.param "job" req
     and build = Dream.param "build" req in
     get_uuid build >>= fun uuid ->
-    (Dream.sql req (Model.build uuid) >>= fun (build_id, build) ->
+    (Dream.sql req (Model.readme job_name) >>= fun readme ->
+     Dream.sql req (Model.build uuid) >>= fun (build_id, build) ->
      Dream.sql req (Model.build_artifacts build_id) >>= fun artifacts ->
      Dream.sql req (Model.latest_successful_build_uuid build.job_id) >>= fun latest_uuid ->
      Dream.sql req (Model.previous_successful_build build_id) >|= fun previous_build ->
-         (build, artifacts, latest_uuid, previous_build))
+         (readme, build, artifacts, latest_uuid, previous_build))
     |> if_error "Error getting job build"
       ~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
-    >>= fun (build, artifacts, latest_uuid, previous_build) ->
+    >>= fun (readme, build, artifacts, latest_uuid, previous_build) ->
-    Views.job_build job_name build artifacts latest_uuid previous_build |> string_of_html |> Dream.html
+    Views.job_build job_name readme build artifacts latest_uuid previous_build |> string_of_html |> Dream.html
     |> Lwt_result.ok
   in
 

lib/dune

@@ -1,3 +1,3 @@
 (library
  (name builder_web)
- (libraries builder builder_db dream tyxml bos rresult duration hex caqti-lwt opamdiff ptime.clock.os))
+ (libraries builder builder_db dream tyxml bos rresult duration hex caqti-lwt opamdiff ptime.clock.os omd))

lib/model.ml

@@ -80,10 +80,17 @@ let main_binary id main_binary (module Db : CONN) =
 let job_id job_name (module Db : CONN) =
   Db.find_opt Builder_db.Job.get_id_by_name job_name
 
-let job job (module Db : CONN) =
+let readme job (module Db : CONN) =
   job_id job (module Db) >>= not_found >>= fun job_id ->
-  Db.collect_list Builder_db.Build.get_all_meta job_id >|=
+  Db.find Builder_db.Tag.get_id_by_name "readme.md" >>= fun readme_id ->
-  List.map (fun (_id, meta, main_binary) -> (meta, main_binary))
+  Db.find_opt Builder_db.Job_tag.get_value (readme_id, job_id)
+
+let job_and_readme job (module Db : CONN) =
+  job_id job (module Db) >>= not_found >>= fun job_id ->
+  Db.find Builder_db.Tag.get_id_by_name "readme.md" >>= fun readme_id ->
+  Db.find_opt Builder_db.Job_tag.get_value (readme_id, job_id) >>= fun readme ->
+  Db.collect_list Builder_db.Build.get_all_meta job_id >|= fun builds ->
+  readme, List.map (fun (_id, meta, main_binary) -> (meta, main_binary)) builds
 
 let jobs (module Db : CONN) =
   Db.collect_list Builder_db.Job.get_all ()
@@ -265,6 +272,9 @@ let add_build
     let descr_tag = "description" in
     Db.exec Tag.try_add descr_tag >>= fun () ->
     Db.find Tag.get_id_by_name descr_tag >>= fun descr_id ->
+    let readme_tag = "readme.md" in
+    Db.exec Tag.try_add readme_tag >>= fun () ->
+    Db.find Tag.get_id_by_name readme_tag >>= fun readme_id ->
     Db.exec Build.add { Build.uuid; start; finish; result;
                         console; script = job.Builder.script;
                         main_binary = None; user_id; job_id } >>= fun () ->
@@ -276,14 +286,17 @@ let add_build
       | Some _ -> Db.exec Job_tag.update (tag_id, tag_value, job_id)
     in
     (match fst sec_syn with
-    | None -> Lwt_result.return ()
+     | None -> Lwt_result.return ()
-    | Some section_v -> add_or_update section_id section_v) >>= fun () ->
+     | Some section_v -> add_or_update section_id section_v) >>= fun () ->
     (match snd sec_syn with
-    | None, _-> Lwt_result.return ()
+     | None, _-> Lwt_result.return ()
-    | Some synopsis_v, _ -> add_or_update synopsis_id synopsis_v) >>= fun () ->
+     | Some synopsis_v, _ -> add_or_update synopsis_id synopsis_v) >>= fun () ->
     (match snd sec_syn with
-    | _, None -> Lwt_result.return ()
+     | _, None -> Lwt_result.return ()
-    | _, Some descr_v -> add_or_update descr_id descr_v) >>= fun () ->
+     | _, Some descr_v -> add_or_update descr_id descr_v) >>= fun () ->
+    (match List.find_opt (fun (p, _) -> Fpath.(equal (v "README.md") p)) raw_artifacts with
+     | None -> Lwt_result.return ()
+     | Some (_, data) -> add_or_update readme_id data) >>= fun () ->
     List.fold_left
       (fun r file ->
          r >>= fun () ->

lib/model.mli

@@ -42,8 +42,11 @@ val previous_successful_build : Builder_db.id -> Caqti_lwt.connection ->
 val main_binary : Builder_db.id -> Fpath.t option -> Caqti_lwt.connection ->
   (Builder_db.file option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
 
-val job : string -> Caqti_lwt.connection ->
+val readme : string -> Caqti_lwt.connection ->
-  ((Builder_db.Build.Meta.t * Builder_db.file option) list, [> error ]) result Lwt.t
+  (string option, [> error ]) result Lwt.t
+
+val job_and_readme : string -> Caqti_lwt.connection ->
+  (string option * (Builder_db.Build.Meta.t * Builder_db.file option) list, [> error ]) result Lwt.t
 
 val job_id : string -> Caqti_lwt.connection ->
   (Builder_db.id option, [> Caqti_error.call_or_retrieve ]) result Lwt.t

lib/views.ml

@@ -151,9 +151,20 @@ let builder section_job_map =
         section_job_map
         [])
 
-let job name builds =
+let job name readme builds =
   layout ~title:(Printf.sprintf "Job %s" name)
-    [ h1 [txtf "Job %s" name];
+    ((h1 [txtf "Job %s" name] ::
+      (match readme with
+       | None -> []
+       | Some data ->
+         [
+           h2 ~a:[a_id "readme"] [txt "README"];
+           a ~a:[a_href "#builds"] [txt "Skip to builds"];
+           Unsafe.data Omd.(to_html (of_string data))
+         ])) @
+     [
+      h2 ~a:[a_id "builds"] [txt "Builds"];
+      a ~a:[a_href "#readme"] [txt "Back to readme"];
       p [
         txtf "Currently %d builds."
           (List.length builds)
@@ -176,10 +187,11 @@ let job name builds =
               ]))
           builds);
 
-    ]
+    ])
 
 let job_build
   name
+  readme
   { Builder_db.Build.uuid; start; finish; result; console; script; _ }
   artifacts
   latest_uuid
@@ -187,8 +199,19 @@ let job_build
   =
   let delta = Ptime.diff finish start in
   let successful_build = match result with Builder.Exited 0 -> true | _ -> false in
-  layout ~title:(Fmt.strf "Job build %s %a" name pp_ptime start)
+  layout ~title:(Fmt.strf "Job %s %a" name pp_ptime start)
-    [ h1 [txtf "Job build %s %a" name pp_ptime start];
+    ((h1 [txtf "Job %s" name] ::
+      (match readme with
+       | None -> []
+       | Some data ->
+         [
+           h2 ~a:[a_id "readme"] [txt "README"];
+           a ~a:[a_href "#build"] [txt "Skip to build"];
+           Unsafe.data Omd.(to_html (of_string data))
+         ])) @
+    [
+      h2 ~a:[a_id "build"] [txtf "Build %a" pp_ptime start];
+      a ~a:[a_href "#readme"] [txt "Back to readme"];
       p [txtf "Build took %a." Ptime.Span.pp delta ];
       p [txtf "Execution result: %a." Builder.pp_execution_result result];
       (match latest_uuid with
@@ -242,7 +265,7 @@ let job_build
                  ])
                 (List.rev console));
         ];
-    ]
+    ])
 
 let packages packages =
   OpamPackage.Set.elements packages