diff --git a/bin/migrations/builder_migrations.ml b/bin/migrations/builder_migrations.ml index 24d9624..5f86b21 100644 --- a/bin/migrations/builder_migrations.ml +++ b/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 diff --git a/bin/migrations/m20210630.ml b/bin/migrations/m20210630.ml new file mode 100644 index 0000000..b0ad15f --- /dev/null +++ b/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) () + + + diff --git a/builder-web.opam b/builder-web.opam index e90e6f4..813a144 100644 --- a/builder-web.opam +++ b/builder-web.opam @@ -43,6 +43,7 @@ depends: [ "cmdliner" "uri" "fmt" + "omd" ] synopsis: "Web interface for builder" diff --git a/db/builder_db.ml b/db/builder_db.ml index 54c958e..c7e1d30 100644 --- a/db/builder_db.ml +++ b/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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 11548e7..573bf72 100644 --- a/lib/builder_web.ml +++ b/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 -> - 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 diff --git a/lib/dune b/lib/dune index e0cf3e7..836101f 100644 --- a/lib/dune +++ b/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)) diff --git a/lib/model.ml b/lib/model.ml index 05ab72c..b2952f9 100644 --- a/lib/model.ml +++ b/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 >|= - 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 () -> diff --git a/lib/model.mli b/lib/model.mli index d02fed4..735ed7c 100644 --- a/lib/model.mli +++ b/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 -> - ((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 diff --git a/lib/views.ml b/lib/views.ml index a09ed4d..9746583 100644 --- a/lib/views.ml +++ b/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) - [ 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