Add basic support for white-listing tests to run on new PRs.

Currently, the only working option is to say "ok to test" to allow
a PR to be tested.

Signed-off-by: Thomas Gazagnaire <thomas@gazagnaire.org>

src/PR_state.ml

@@ -0,0 +1,85 @@
+open Datakit_ci
+open Datakit_github
+open Lwt.Infix
+open Astring
+
+let ( >>*= ) x f =
+  x >>= function
+  | Ok x    -> f x
+  | Error e -> Utils.failf "Unexpected DB error: %a" DK.pp_error e
+
+
+let ( // ) = Datakit_client.Path.Infix.( / )
+
+type v = [
+  | `OkToTest
+  | `InWhiteList
+  | `NotAuthorized
+]
+
+let cached_file = Cache.Path.(value // "state")
+
+let string_of_v = function
+  | `OkToTest      -> "ok-to-test"
+  | `InWhiteList   -> "in-whitelist"
+  | `NotAuthorized -> "not-authorized"
+
+let v_of_string = function
+  | "ok-to-test"     -> `OkToTest
+  | "in-whitelist"   -> `InWhiteList
+  | "not-authorized" -> `NotAuthorized
+  | _ -> `NotAuthorized
+
+(* to accept this pull request for testing *)
+let ok_to_test = "ok to test"
+
+module Builder = struct
+  module Key = struct
+    type t = Whitelist.v
+  end
+  type t = unit
+  type value = v
+  type context = Datakit_github.PR.t
+
+  let name _ = "LinuxKit PR state"
+  let title _ _ = "Computing the PR state"
+
+  let generate () ~switch:_ ~log:_ tr pr whitelist =
+    let in_whitelist user = Whitelist.mem (User.name user) whitelist in
+    let contains x body =
+      let re = Re.compile Re.(seq [rep space; str x; rep space]) in
+      Re.execp re body
+    in
+    let state =
+      if in_whitelist (PR.owner pr) then `InWhiteList
+      else
+        let is_ok_to_test c =
+          (* The user doing the comment is in the whitelist and he/she
+             says "test this" *)
+          in_whitelist (Comment.user c) && contains ok_to_test (Comment.body c)
+        in
+        let comments = Array.to_list (PR.comments pr) in
+        if List.exists is_ok_to_test comments then `OkToTest else `NotAuthorized
+    in
+    let file = Cstruct.of_string (string_of_v state ^ "\n") in
+    DK.Transaction.create_file tr cached_file file >>*= fun () ->
+    Lwt.return (Ok state)
+
+  let load () tree _ =
+    DK.Tree.read_file tree cached_file >>*= fun file ->
+    let state = v_of_string (String.trim @@ Cstruct.to_string file) in
+    Lwt.return state
+
+  let branch () whitelist = "state-" ^ Whitelist.hash whitelist
+
+end
+
+module Result_cache = Cache.Make(Builder)
+
+type t = Result_cache.t
+
+let v t whitelist pr =
+  let open! Term.Infix in
+  Result_cache.find t pr whitelist
+
+let make ~logs = Result_cache.create ~logs ()

src/PR_state.mli

@@ -0,0 +1,20 @@
+(** Manage pull-request state. *)
+
+open Datakit_ci
+
+type t
+(** The type for pull-request state manager. *)
+
+val make: logs:Live_log.manager -> t
+(** [make ~logs] create a new pull-request manager. *)
+
+(** The type for pull-request state. *)
+type v = [
+  | `OkToTest
+  | `InWhiteList
+  | `NotAuthorized
+]
+
+val v: t -> Whitelist.v -> Datakit_github.PR.t -> v Term.t
+(** [v t ~whitelist pr] is a term which evaluates to state of the
+    pull-request [pr] using the given [whitelist]. *)

src/ci.ml

@@ -25,14 +25,23 @@ let vms =
   in
   Gcp.make ~state:"/ci-state/gcloud-vms" ~prefix
 
-(* Our local Git clone of the LinuxKit source repository. *)
-let src_repo =
+let repo project =
+  (* Our local Git clone of the source repository. *)
   let remote =
     match profile with
-    | `Production -> "https://github.com/linuxkit/linuxkit.git"
-    | `Localhost -> "/fake-remote/linuxkit"       (* Pull from our local "remote" *)
+    | `Production -> Fmt.strf "https://github.com/linuxkit/%s.git" project
+    | `Localhost  -> "/fake-remote/" ^ project  (* local "remote" *)
   in
-  Git.v ~logs ~remote "/repos/linuxkit"
+  Git.v ~logs ~remote ("/repos/" ^ project)
+
+(* Our local Git clone of the LinuxKit source repository. *)
+let src_repo = repo "linuxkit"
+
+(* The repository and branch where the whitelist is stored *)
+let whitelist_repo = repo "linuxkit-ci"
+let whitelist_ref =
+  `Ref (Datakit_github.(Repo.v ~user:(User.v "linuxkit") ~repo:"linuxkit-ci"),
+        ["master"])
 
 (* Cache of built images. Can be deleted without too much trouble, but e.g. if you try to
    re-run the tests after deleting the image it will fail and you'll have to rebuild the
@@ -42,12 +51,30 @@ let build_cache = Disk_cache.make ~path:"/build-cache"
 module Builder = struct
   open Term.Infix
 
+  let whitelist = Whitelist.make ~logs
+  let pr_state = PR_state.make ~logs
   let builder = Linuxkit_build.make ~logs ~pool ~google_pool ~vms ~build_cache
   let tester = Linuxkit_test.make ~logs ~google_pool ~vms ~build_cache
 
-  (* To build, "git fetch" the head of the branch, tag or PR being tested, then use [builder]. *)
-  let build repo ~builder ~target =
-    Git.fetch_head repo target >>=
+  (* read the whitelist *)
+  let read_whitelist =
+    Git.fetch_head whitelist_repo whitelist_ref >>=
+    Whitelist.v whitelist
+
+  (* check if the target can be tested *)
+  let should_be_tested ~target whitelist =
+    Term.target target >>= function
+    | `Ref _ -> Term.return true
+    | `PR pr ->
+      PR_state.v pr_state whitelist pr >|= function
+      | `OkToTest
+      | `InWhiteList   -> true
+      | `NotAuthorized -> false
+
+  (* To build, "git fetch" the head of the branch, tag or PR being
+     tested, then use [builder]. *)
+  let build ~target =
+    Git.fetch_head src_repo target >>=
     Linuxkit_build.build builder ~target
 
   (* How to test the various images we produce. *)
@@ -58,13 +85,19 @@ module Builder = struct
       | None -> Term.fail "Output %s not found" x
     in
     Term.wait_for_all [
-      "GCP", get "test.img.tar.gz" >>= Linuxkit_test.gcp tester;
+      "GCP", get "test.img.tar.gz" >>=
+      Linuxkit_test.gcp tester
     ]
     >|= fun () -> "All tests passed"
 
-  (* The "linuxkit-ci" status for a target is the result of building it and then testing the images. *)
+  (* The "linuxkit-ci" status for a target is the result of building
+     it and then testing the images. *)
   let status target = [
-    "linuxkit-ci", build src_repo ~builder ~target >>= test_images
+    "linuxkit-ci",
+    read_whitelist >>=
+    should_be_tested ~target >>= function
+    | false -> Term.return "Not authorized"
+    | true  -> build ~target >>= test_images
   ]
 
   (* For the "linuxkit/linuxkit" GitHub repository, use [status]. *)

src/whitelist.ml

@@ -0,0 +1,66 @@
+open Datakit_ci
+open Lwt.Infix
+open Astring
+
+let ( // ) = Datakit_client.Path.Infix.( / )
+let ( / ) = Filename.concat
+
+let ( >>*= ) x f =
+  x >>= function
+  | Ok x    -> f x
+  | Error e -> Utils.failf "Unexpected DB error: %a" DK.pp_error e
+
+let cached_file = Cache.Path.(value // "whitelist")
+
+type v = string list
+
+module Builder = struct
+  module Key = struct
+    type t = Git.commit
+  end
+  type t = unit
+  type value = string list
+  type context = job_id
+  let name _ = "LinuxKit whitelist"
+  let title _ _ = "Reading the whitelist"
+
+  let generate () ~switch:_ ~log  tr job_id head =
+    Git.with_clone ~log ~job_id head (fun path ->
+        let file = path / "whitelist" in
+        (if not (Sys.file_exists file) then Lwt.return []
+         else
+           Lwt_io.open_file ~mode:Lwt_io.Input file >>= fun ic ->
+           Lwt_stream.to_list (Lwt_io.read_lines ic)
+        ) >>= fun lines ->
+        let lines = List.map String.trim lines in
+        let file = Cstruct.of_string (String.concat ~sep:"\n" lines ^ "\n") in
+        DK.Transaction.create_file tr cached_file file >>*= fun () ->
+        Lwt.return (Ok lines)
+      )
+
+  let load () tree _head =
+    DK.Tree.read_file tree cached_file >>*= fun file ->
+    let lines = String.cuts ~empty:false ~sep:"\n" (Cstruct.to_string file) in
+    Lwt.return lines
+
+  let branch () head = "whitelist-" ^ Git.hash head
+
+end
+
+module Result_cache = Cache.Make(Builder)
+
+type t = Result_cache.t
+
+let v t src =
+  let open! Term.Infix in
+  Term.job_id >>= fun job_id ->
+  Result_cache.find t job_id src
+
+let mem = List.mem
+
+let make ~logs = Result_cache.create ~logs ()
+
+let hash t =
+  let t = List.sort String.compare t in
+  let `Hex h = Hex.of_string (String.concat ~sep:" ? " t) in
+  h

src/whitelist.mli

@@ -0,0 +1,22 @@
+(** Manage whitelists *)
+
+open Datakit_ci
+
+type t
+(** The type for whitelist managers. *)
+
+val make: logs:Live_log.manager -> t
+(** [make ~logs] create a new whitelist manager. *)
+
+type v
+(** The type for whitelists. *)
+
+val v: t -> Git.commit -> v Term.t
+(** [v t c] is the whitelist stored at the root of the commit [c]. *)
+
+val mem: string -> v -> bool
+(** [mem name w] checks whether [name] belongs to the whitelist
+    [w]. *)
+
+val hash: v -> string
+(** [hash w] is a deterministic hash of the whitelist [w]. *)