diff --git a/ci/self-ci/selfCI.mli b/ci/self-ci/selfCI.mli new file mode 100644 index 000000000..e69de29bb diff --git a/ci/src/cI_engine.ml b/ci/src/cI_engine.ml index e296e3efd..8ddf72bd6 100644 --- a/ci/src/cI_engine.ml +++ b/ci/src/cI_engine.ml @@ -1,5 +1,4 @@ open Datakit_github -open CI_s open CI_utils open CI_utils.Infix open Result @@ -46,7 +45,7 @@ type job = { term_lock : Lwt_mutex.t; (* Held while evaluating term *) mutable term : string CI_term.t; mutable cancel : unit -> unit; (* Cancel the previous evaluation, if any *) - mutable state : string * state; (* The last result of evaluating [term] (commit, state) *) + mutable state : string * string CI_output.t; (* The last result of evaluating [term] (commit, state) *) } and target = { mutable v : CI_target.v; @@ -199,7 +198,9 @@ let monitor t ?switch fn = let datakit_ci x = ["ci"; "datakit"; x] -let set_status t target name ~status ~descr = +let set_status t target name result = + let status = CI_result.status result in + let descr = CI_result.descr result in Prometheus.Counter.inc_one Metrics.status_updates; let commit, url = match target with @@ -287,24 +288,18 @@ let rec recalculate t job = | ex -> Lwt.return (Error (`Failure (Printexc.to_string ex)), CI_output.Empty) ) - >>= fun (result, logs) -> - let status, descr = - match result with - | Ok descr -> `Success, descr - | Error (`Pending descr) -> `Pending, descr - | Error (`Failure descr) -> `Failure, descr - in - let (old_head, old_state) = job.state in + >>= fun new_output -> + let (old_head, old_output) = job.state in let new_hash = Commit.hash (CI_target.head head) in - begin if (old_head, old_state.status, old_state.descr) <> - (new_hash, status, descr) then ( - set_status t head job.name ~status ~descr + let old_result = CI_output.result old_output in + let new_result = CI_output.result new_output in + begin if (old_head, old_result) <> (new_hash, new_result) then ( + set_status t head job.name new_result ) else ( Lwt.return () ) end >|= fun () -> - let state = (new_hash, { status; descr; logs }) in - job.state <- state + job.state <- (new_hash, new_output) let make_job t ~parent name term = let snapshot = snapshot t in @@ -313,11 +308,13 @@ let make_job t ~parent name term = Conv.status snapshot id >|= fun status -> let state = match status with None -> None | Some s -> Some (Status.state s) in let descr = match status with None -> None | Some s -> Status.description s in - let state = + let result = match state, descr with - | Some status, Some descr -> { status; descr; logs = CI_output.Empty } - | _ -> { status = `Pending; descr = "(new)"; logs = CI_output.Empty } + | Some `Error, Some descr -> CI_result.v `Failure descr + | Some (`Pending | `Success | `Failure as status), Some descr -> CI_result.v status descr + | _ -> Error (`Pending "(new)") in + let state = (result, CI_output.Empty) in let hash = Commit.hash head_commit in { name; parent; @@ -514,7 +511,7 @@ let rebuild t ~branch_name = in let check_job job = let _, state = job.state in - if check_logs state.logs then + if check_logs (CI_output.logs state) then jobs_needing_recalc := job :: !jobs_needing_recalc in let check_target target = List.iter check_job target.jobs in diff --git a/ci/src/cI_engine.mli b/ci/src/cI_engine.mli index 03a01173e..41853cae3 100644 --- a/ci/src/cI_engine.mli +++ b/ci/src/cI_engine.mli @@ -1,7 +1,6 @@ open Datakit_github open Astring open CI_utils -open CI_s type t (** A DataKit CI instance. *) @@ -44,7 +43,7 @@ val jobs : target -> job list val job_name : job -> string (** [job_name j] is the name of the GitHub status that this job computes. *) -val state : job -> state +val state : job -> string CI_output.t (** [state job] is the current state of [job]. *) val target : target -> CI_target.v diff --git a/ci/src/cI_eval.ml b/ci/src/cI_eval.ml index ef74eb831..14caf5a3e 100644 --- a/ci/src/cI_eval.ml +++ b/ci/src/cI_eval.ml @@ -8,7 +8,7 @@ module Make (C: CI_s.CONTEXT) = struct type context = C.t type 'a key = C.t -> 'a - type 'a t = C.t -> ('a or_error * L.t) Lwt.t + type 'a t = C.t -> ('a or_error * L.logs) Lwt.t let return x _ = Lwt.return (Ok x, L.Empty) diff --git a/ci/src/cI_eval.mli b/ci/src/cI_eval.mli index f682875a7..ba9fbaf32 100644 --- a/ci/src/cI_eval.mli +++ b/ci/src/cI_eval.mli @@ -3,6 +3,6 @@ module Make(C:CI_s.CONTEXT) : sig type context = C.t and type 'a key = C.t -> 'a - val run : context -> 'a t -> ('a CI_result.t * CI_output.t) Lwt.t + val run : context -> 'a t -> ('a CI_result.t * CI_output.logs) Lwt.t (** [run context term] is the result of evaluating [term] in [context]. *) end diff --git a/ci/src/cI_output.ml b/ci/src/cI_output.ml index 44c87e15d..0efdba7a5 100644 --- a/ci/src/cI_output.ml +++ b/ci/src/cI_output.ml @@ -6,8 +6,16 @@ type saved = { rebuild : unit Lwt.t Lazy.t; } -type t = +type logs = | Empty | Live of CI_live_log.t | Saved of saved - | Pair of t * t + | Pair of logs * logs + +type 'a t = 'a CI_result.t * logs + +let result = fst +let logs = snd + +let status t = CI_result.status (result t) +let descr t = CI_result.descr (result t) diff --git a/ci/src/cI_output.mli b/ci/src/cI_output.mli index 44c87e15d..2e07ba8e5 100644 --- a/ci/src/cI_output.mli +++ b/ci/src/cI_output.mli @@ -6,8 +6,15 @@ type saved = { rebuild : unit Lwt.t Lazy.t; } -type t = +type logs = | Empty | Live of CI_live_log.t | Saved of saved - | Pair of t * t + | Pair of logs * logs + +type 'a t = 'a CI_result.t * logs + +val result : 'a t -> 'a CI_result.t +val logs : 'a t -> logs +val status : _ t -> [`Success | `Pending | `Failure] +val descr : string t -> string diff --git a/ci/src/cI_result.ml b/ci/src/cI_result.ml index 72a68556d..54e23e9c7 100644 --- a/ci/src/cI_result.ml +++ b/ci/src/cI_result.ml @@ -11,3 +11,18 @@ let pp_error f = function let pp ok f = function | Ok x -> ok f x | Error e -> pp_error f e + +let descr = function + | Ok x -> x + | Error (`Failure x | `Pending x) -> x + +let v status descr = + match status with + | `Success -> Ok descr + | `Pending -> Error (`Pending descr) + | `Failure -> Error (`Failure descr) + +let status = function + | Ok _ -> `Success + | Error (`Pending _) -> `Pending + | Error (`Failure _) -> `Failure diff --git a/ci/src/cI_result.mli b/ci/src/cI_result.mli index dc587b6d6..9d0227913 100644 --- a/ci/src/cI_result.mli +++ b/ci/src/cI_result.mli @@ -6,3 +6,7 @@ type 'a t = ('a, error) result val pp_error: error Fmt.t val pp: 'a Fmt.t -> 'a t Fmt.t + +val v : [< `Success | `Pending | `Failure] -> string -> string t +val status : _ t -> [> `Success | `Pending | `Failure] +val descr : string t -> string diff --git a/ci/src/cI_s.mli b/ci/src/cI_s.mli index 002ceb71e..88a1aee9d 100644 --- a/ci/src/cI_s.mli +++ b/ci/src/cI_s.mli @@ -2,13 +2,7 @@ open CI_utils type 'a status = { result: ('a, [`Pending of string * unit Lwt.t | `Failure of string]) result; - output: CI_output.t -} - -type state = { - status: Datakit_github.Status_state.t; - logs : CI_output.t; - descr : string; + output: CI_output.logs } type job_id = CI_target.t * string diff --git a/ci/src/cI_term.mli b/ci/src/cI_term.mli index 3a82f7bb3..fe5bf2797 100644 --- a/ci/src/cI_term.mli +++ b/ci/src/cI_term.mli @@ -18,4 +18,4 @@ val run : job_id:CI_s.job_id -> recalc:(unit -> unit) -> dk:(unit -> CI_utils.DK.t Lwt.t) -> - 'a t -> ('a CI_result.t * CI_output.t) Lwt.t * (unit -> unit) + 'a t -> ('a CI_result.t * CI_output.logs) Lwt.t * (unit -> unit) diff --git a/ci/src/cI_web_templates.ml b/ci/src/cI_web_templates.ml index fc744642a..f2086e374 100644 --- a/ci/src/cI_web_templates.ml +++ b/ci/src/cI_web_templates.ml @@ -1,7 +1,6 @@ open Datakit_github open! Astring open! Tyxml.Html -open CI_s type t = { name : string; @@ -111,20 +110,18 @@ let dash_map f map targets = let status state = let colour, icon, status = - match state.status with - | `Pending -> "label-warning", "glyphicon-hourglass", "Pending" + match state with | `Success -> "label-success", "glyphicon-ok","Success" - | `Error -> "label-danger", "glyphicon-warning-sign", "Error" + | `Pending -> "label-warning", "glyphicon-hourglass", "Pending" | `Failure -> "label-danger", "glyphicon-remove", "Failure" in span ~a:[a_class ["label"; colour;]] [span ~a:[a_class ["glyphicon"; icon]] []; pcdata status] -let status_flag ?label status = +let status_flag ?label stat = let cl, icon, status = - match status with - | `Pending -> "label-warning", "glyphicon-hourglass", "pending" + match stat with | `Success -> "label-success", "glyphicon-ok","success" - | `Error -> "label-danger", "glyphicon-warning-sign", "error" + | `Pending -> "label-warning", "glyphicon-hourglass", "pending" | `Failure -> "label-danger", "glyphicon-remove", "failure" in let tooltip = @@ -140,40 +137,39 @@ let status_list jobs = jobs |> List.map (fun job -> let state = CI_engine.state job in let label = CI_engine.job_name job in - td [status_flag ~label state.status]; + td [status_flag ~label (CI_output.status state)]; ) ) ] let summarise jobs = - let states = List.map (fun j -> CI_engine.job_name j, CI_engine.state j) jobs in - let combine status states = + let outputs = List.map (fun j -> CI_engine.job_name j, CI_engine.state j) jobs in + let combine status outputs = let results = ref String.Map.empty in - states |> List.iter (fun (name, state) -> - let descr = state.descr in + outputs |> List.iter (fun (name, output) -> + let descr = CI_output.descr output in let old_names = String.Map.find descr !results |> CI_utils.default [] in results := String.Map.add descr (name :: old_names) !results ); let results = String.Map.bindings !results in let pp_group f (descr, g) = Fmt.pf f "%s (%a)" descr (Fmt.(list ~sep:(const string ", ") Fmt.string)) (List.rev g) in let descr = Fmt.strf "%a" Fmt.(list ~sep:(const string "; ") pp_group) results in - { status; descr; logs = CI_output.Empty } + CI_result.v status descr in - let pending, states = List.partition (fun (_, x) -> x.status = `Pending) states in + let pending, outputs = List.partition (fun (_, s) -> CI_output.status s = `Pending) outputs in if pending <> [] then combine `Pending pending else ( - let failed, states = List.partition (fun (_, x) -> x.status = `Failure) states in + let failed, outputs = List.partition (fun (_, s) -> CI_output.status s = `Failure) outputs in if failed <> [] then combine `Failure failed - else combine `Success states + else combine `Success outputs ) let dashboard_widget (_repo, id) ref = let state = CI_engine.jobs ref |> summarise in let cls, icon, status, comment = - match state.status with - | `Pending -> "dashboard-pending", "glyphicon-hourglass", "Pending", "... WAITING ..." + match CI_result.status state with | `Success -> "dashboard-success", "glyphicon-ok", "Succeeding", "YAY! The build is fine... Nothing to see here..." - | `Error -> "dashboard-error", "glyphicon-warning-sign", "Erroring", "OH NO! Something has gone terribly wrong" + | `Pending -> "dashboard-pending", "glyphicon-hourglass", "Pending", "... WAITING ..." | `Failure -> "dashboard-failure", "glyphicon-remove", "Failing", "SOUND THE ALARM!!! The build has been broken!" in let title = match id with @@ -197,7 +193,7 @@ let ref_job (_repo, id) ref = tr [ td [a ~a:[a_href ref_url] [pcdata (Fmt.to_to_string Ref.pp_name id)]]; td [status_list jobs]; - td [pcdata summary.descr]; + td [pcdata (CI_result.descr summary)]; ] ] @@ -212,7 +208,7 @@ let pr_job (_repo, id) open_pr = td [a ~a:[a_href pr_url] [pcdata (string_of_int id)]]; td [pcdata (CI_engine.title open_pr)]; td [status_list jobs]; - td [pcdata summary.descr]; + td [pcdata (CI_result.descr summary)]; ] ] @@ -589,11 +585,11 @@ let score_logs ~best job = | Saved saved -> LogScore.update best (`Saved saved); | Pair (a, b) -> aux a; aux b in - aux (CI_engine.state job).logs + aux (CI_engine.state job |> CI_output.logs) let logs ~csrf_token ~page_url ~selected state = let open CI_output in - let logs = state.logs in + let logs = CI_output.logs state in let last_title = ref None in let seen = ref String.Set.empty in let selected_branch = @@ -657,15 +653,18 @@ let logs ~csrf_token ~page_url ~selected state = let items = aux logs in (* Don't show the overall status if it's the same as the last log title. *) match !last_title with - | Some shown when shown = state.descr -> items - | _ -> items @ [p [status_flag state.status; pcdata state.descr]] + | Some shown when shown = CI_output.descr state -> items + | _ -> + let status = CI_output.status state in + let descr = CI_output.descr state in + items @ [p [status_flag status; pcdata descr]] let job_row ~csrf_token ~page_url ~best_log job = let state = CI_engine.state job in let job_name = CI_engine.job_name job in tr [ th [pcdata job_name]; - td [status state]; + td [status (CI_output.status state)]; td ( logs ~csrf_token ~page_url ~selected:best_log (CI_engine.state job) ); diff --git a/ci/src/datakit_ci.ml b/ci/src/datakit_ci.ml index 58321e36d..f15fd4ad9 100644 --- a/ci/src/datakit_ci.ml +++ b/ci/src/datakit_ci.ml @@ -5,7 +5,7 @@ module Output = CI_output (* FIXME: we should probably make that type abstract *) type 'a status = 'a CI_s.status = { result: ('a, [`Pending of string * unit Lwt.t | `Failure of string]) result; - output: Output.t + output: Output.logs; } type job_id = CI_s.job_id diff --git a/ci/src/datakit_ci.mli b/ci/src/datakit_ci.mli index 43d1746f7..fd4e8858c 100644 --- a/ci/src/datakit_ci.mli +++ b/ci/src/datakit_ci.mli @@ -83,22 +83,21 @@ module Output: sig type saved (** The type for {!term}'s output. *) - type t = + type logs = | Empty | Live of Live_log.t | Saved of saved - | Pair of t * t - + | Pair of logs * logs end type 'a status = { result: ('a, [`Pending of string * unit Lwt.t | `Failure of string]) result; - output: Output.t; + output: Output.logs; } (** The type for term status. It is a mix between the usual error monad, but where we also keep a local log for every computation. Morever, computation can be long-running, so there is - a new [`Pending] state and a continuation to run when the term + a new [`Pending] state with an indication of when the term is complete. *) type job_id diff --git a/datakit-ci.opam b/datakit-ci.opam index c390be8d9..509d73928 100644 --- a/datakit-ci.opam +++ b/datakit-ci.opam @@ -34,7 +34,7 @@ depends: [ "conduit" "io-page" "pbkdf" - "webmachine" + "webmachine" {>= "0.3.2"} "session" {>= "0.3.0"} "redis" "asetmap"