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

This commit is contained in:
Robur 2021-06-30 12:47:30 +00:00
parent 5285872865
commit 009fa49e9e
9 changed files with 156 additions and 26 deletions

View file

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

View file

@ -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) ()

View file

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

View file

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

View file

@ -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 ->
Views.job job_name builds |> string_of_html |> Dream.html |> Lwt_result.ok
>>= fun (readme, builds) ->
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) ->
Views.job_build job_name build artifacts latest_uuid previous_build |> string_of_html |> Dream.html
>>= fun (readme, build, artifacts, latest_uuid, previous_build) ->
Views.job_build job_name readme build artifacts latest_uuid previous_build |> string_of_html |> Dream.html
|> Lwt_result.ok
in

View file

@ -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))

View file

@ -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 >|=
List.map (fun (_id, meta, main_binary) -> (meta, main_binary))
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)
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 ()
| Some section_v -> add_or_update section_id section_v) >>= fun () ->
| None -> Lwt_result.return ()
| Some section_v -> add_or_update section_id section_v) >>= fun () ->
(match snd sec_syn with
| None, _-> Lwt_result.return ()
| Some synopsis_v, _ -> add_or_update synopsis_id synopsis_v) >>= fun () ->
| None, _-> Lwt_result.return ()
| Some synopsis_v, _ -> add_or_update synopsis_id synopsis_v) >>= fun () ->
(match snd sec_syn with
| _, None -> Lwt_result.return ()
| _, Some descr_v -> add_or_update descr_id descr_v) >>= fun () ->
| _, None -> Lwt_result.return ()
| _, 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 () ->

View file

@ -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 ->
((Builder_db.Build.Meta.t * Builder_db.file option) list, [> error ]) result Lwt.t
val readme : string -> Caqti_lwt.connection ->
(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

View file

@ -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)
[ h1 [txtf "Job build %s %a" name pp_ptime start];
layout ~title:(Fmt.strf "Job %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