Add Github.commit type

This bundles the API auth with the commit, which makes it easier to set the commit status. Used this to update the GitHub app example to set commit statuses.
talex5 · Sep 2, 2019 · 9c115b4 · 9c115b4
1 parent 6261bd1
commit 9c115b4
Show file tree

Hide file tree

Showing 5 changed files with 39 additions and 15 deletions.
diff --git a/examples/github.ml b/examples/github.ml
@@ -28,15 +28,15 @@ let github_status_of_state = function
 
 let pipeline ~github ~repo () =
   let head = Github.Api.head_commit github repo in
-  let src = Git.fetch head in
+  let src = Git.fetch (Current.map Github.Api.Commit.id head) in
   let dockerfile =
     let+ base = Docker.pull ~schedule:weekly "ocurrent/opam:alpine-3.10-ocaml-4.08" in
     dockerfile ~base
   in
   Docker.build ~pull:false ~dockerfile (`Git src)
   |> Current.state
   |> Current.map github_status_of_state
-  |> Github.Api.set_commit_status github head "ocurrent"
+  |> Github.Api.set_commit_status head "ocurrent"
 
 let webhooks = [
   "github", Github.input_webhook

diff --git a/examples/github_app.ml b/examples/github_app.ml
@@ -22,6 +22,11 @@ let dockerfile ~base =
 
 let weekly = Current_cache.Schedule.v ~valid_for:(Duration.of_day 7) ()
 
+let github_status_of_state = function
+  | Ok _ -> `Success
+  | Error (`Active _) -> `Pending
+  | Error (`Msg _) -> `Failure
+
 let pipeline ~app () =
   let dockerfile =
     let+ base = Docker.pull ~schedule:weekly "ocurrent/opam:alpine-3.10-ocaml-4.08" in
@@ -32,9 +37,11 @@ let pipeline ~app () =
   let repos = Github.Installation.repositories installation in
   repos |> Current.list_iter ~pp:Github.Repo_id.pp @@ fun repo ->
   let head = Github.Api.head_commit_dyn github repo in
-  let src = Git.fetch head in
+  let src = Git.fetch (Current.map Github.Api.Commit.id head) in
   Docker.build ~pull:false ~dockerfile (`Git src)
-  |> Current.ignore_value
+  |> Current.state
+  |> Current.map github_status_of_state
+  |> Github.Api.set_commit_status head "ocurrent"
 
 let webhooks = [
   "github", Github.input_webhook

diff --git a/plugins/github/api.ml b/plugins/github/api.ml
@@ -56,8 +56,14 @@ type t = {
   get_token : unit -> token Lwt.t;
   token_lock : Lwt_mutex.t;
   mutable token : token;
-  mutable head_inputs : Current_git.Commit_id.t Current.Input.t Repo_map.t;
+  mutable head_inputs : commit Current.Input.t Repo_map.t;
 }
+and commit = t * Current_git.Commit_id.t
+
+module Commit = struct
+  type t = commit
+  let id = snd
+end
 
 let v ~get_token account =
   let head_inputs = Repo_map.empty in
@@ -182,7 +188,7 @@ let default_ref t { Repo_id.owner; name } =
 let make_head_commit_input t repo =
   let read () =
     Lwt.catch
-      (fun () -> default_ref t repo >|= Stdlib.Result.ok)
+      (fun () -> default_ref t repo >|= fun c -> Ok (t, c))
       (fun ex -> Lwt_result.fail @@ `Msg (Fmt.strf "GitHub query for %a failed: %a" Repo_id.pp repo Fmt.exn ex))
   in
   let watch refresh =
@@ -319,9 +325,9 @@ end
 
 module Set_status_cache = Current_cache.Output(Set_status)
 
-let set_commit_status t commit context status =
+let set_commit_status commit context status =
   Current.component "set_status" |>
-  let> commit = commit
+  let> (t, commit) = commit
   and> status = status in
   Set_status_cache.set t {Set_status.Key.commit; context} status
 

diff --git a/plugins/github/api.mli b/plugins/github/api.mli
@@ -1,12 +1,17 @@
 (* Public API; see Current_git.mli for details of these: *)
 
+module Commit : sig
+  type t
+  val id : t -> Current_git.Commit_id.t
+end
+
 type t
 type status = [`Error | `Failure | `Pending | `Success ]
 val of_oauth : string -> t
 val exec_graphql : ?variables:(string * Yojson.Safe.t) list -> t -> string -> Yojson.Safe.t Lwt.t
-val head_commit : t -> Repo_id.t -> Current_git.Commit_id.t Current.t
-val head_commit_dyn : t Current.t -> Repo_id.t Current.t -> Current_git.Commit_id.t Current.t
-val set_commit_status : t -> Current_git.Commit_id.t Current.t -> string -> status Current.t -> unit Current.t
+val head_commit : t -> Repo_id.t -> Commit.t Current.t
+val head_commit_dyn : t Current.t -> Repo_id.t Current.t -> Commit.t Current.t
+val set_commit_status : Commit.t Current.t -> string -> status Current.t -> unit Current.t
 val cmdliner : t Cmdliner.Term.t
 
 (* Private API *)

diff --git a/plugins/github/current_github.mli b/plugins/github/current_github.mli
@@ -20,6 +20,12 @@ module Api : sig
   type t
   (** Configuration for accessing GitHub. *)
 
+  module Commit : sig
+    type t
+
+    val id : t -> Current_git.Commit_id.t
+  end
+
   type status = [`Error | `Failure | `Pending | `Success ]
   (** GitHub commit context status type. *)
 
@@ -29,14 +35,14 @@ module Api : sig
   val exec_graphql : ?variables:(string * Yojson.Safe.t) list -> t -> string -> Yojson.Safe.t Lwt.t
   (** [exec_graphql t query] executes [query] on GitHub. *)
 
-  val head_commit : t -> Repo_id.t -> Current_git.Commit_id.t Current.t
+  val head_commit : t -> Repo_id.t -> Commit.t Current.t
   (** [head_commit t repo] evaluates to the commit at the head of the default branch in [repo]. *)
 
-  val head_commit_dyn : t Current.t -> Repo_id.t Current.t -> Current_git.Commit_id.t Current.t
+  val head_commit_dyn : t Current.t -> Repo_id.t Current.t -> Commit.t Current.t
   (** Like [head_commit], but the inputs are both currents. *)
 
-  val set_commit_status : t -> Current_git.Commit_id.t Current.t -> string -> status Current.t -> unit Current.t
-  (** [set_commit_status t commit context status] sets the status of [commit]/[context] to [status]. *)
+  val set_commit_status : Commit.t Current.t -> string -> status Current.t -> unit Current.t
+  (** [set_commit_status commit context status] sets the status of [commit]/[context] to [status]. *)
 
   val cmdliner : t Cmdliner.Term.t
   (** Command-line options to generate a GitHub configuration. *)