Merge pull request #474 from talex5/cleanups

Clean up output/state types

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

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

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)
 

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

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)

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

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

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

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

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)

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

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

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

datakit-ci.opam

@@ -34,7 +34,7 @@ depends: [
   "conduit"
   "io-page"
   "pbkdf"
-  "webmachine"
+  "webmachine" {>= "0.3.2"}
   "session" {>= "0.3.0"}
   "redis"
   "asetmap"