move config and associated functions from context toplevel to state

The `Context` toplevel should only store relatively static info that
applies globally, like the secrets.

When we accommodate multiple repos, a particular repo's config
should be moved out of the global toplevel context to the runtime
`State`, where it can coexist with other dynamic, repo-specific info
like pipeline status.

Author: yasunariw

lib/action.ml

@@ -87,13 +87,13 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     if List.is_empty matched_channel_names then default else matched_channel_names
 
   let partition_status (ctx : Context.t) (n : status_notification) =
-    let cfg = Context.get_config_exn ctx in
+    let cfg = State.find_repo_config_exn ctx.state in
     let pipeline = n.context in
     let current_status = n.state in
     let rules = cfg.status_rules.rules in
     let action_on_match (branches : branch list) =
       let default = Option.to_list cfg.prefix_rules.default_channel in
-      let () = Context.refresh_pipeline_status ~pipeline ~branches ~status:current_status ctx in
+      let () = State.set_repo_pipeline_status ~pipeline ~branches ~status:current_status ctx.state in
       match List.is_empty branches with
       | true -> Lwt.return []
       | false ->
@@ -111,7 +111,7 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
         | Ok commit -> Lwt.return @@ partition_commit cfg commit.files
         )
     in
-    if Context.is_pipeline_allowed ctx ~pipeline then begin
+    if State.is_pipeline_allowed ctx.state ~pipeline then begin
       match Rule.Status.match_rules ~rules n with
       | Some Ignore | None -> Lwt.return []
       | Some Allow -> action_on_match n.branches
@@ -130,7 +130,7 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     else Lwt.return []
 
   let partition_commit_comment (ctx : Context.t) n =
-    let cfg = Context.get_config_exn ctx in
+    let cfg = State.find_repo_config_exn ctx.state in
     match n.comment.commit_id with
     | None -> action_error "unable to find commit id for this commit comment event"
     | Some sha ->
@@ -149,7 +149,7 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
       )
 
   let generate_notifications (ctx : Context.t) req =
-    let cfg = Context.get_config_exn ctx in
+    let cfg = State.find_repo_config_exn ctx.state in
     match req with
     | Github.Push n ->
       partition_push cfg n |> List.map ~f:(fun (channel, n) -> generate_push_notification n channel) |> Lwt.return
@@ -186,12 +186,12 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
       let repo = Github.repo_of_notification notification in
       match%lwt Github_api.get_config ~ctx ~repo with
       | Ok config ->
-        ctx.config <- Some config;
+        ctx.state.config <- Some config;
         Context.print_config ctx;
         Lwt.return @@ Ok ()
       | Error e -> action_error e
     in
-    match ctx.config with
+    match ctx.state.config with
     | None -> fetch_config ()
     | Some _ ->
     match notification with

lib/context.ml

@@ -11,21 +11,20 @@ type t = {
   secrets_filepath : string;
   state_filepath : string option;
   mutable secrets : Config_t.secrets option;
-  mutable config : Config_t.config option;
   state : State_t.state;
 }
 
-let default : t =
+let default () : t =
   {
     config_filename = "monorobot.json";
     secrets_filepath = "secrets.json";
     state_filepath = None;
     secrets = None;
-    config = None;
-    state = State.empty;
+    state = State.empty ();
   }
 
 let make ?config_filename ?secrets_filepath ?state_filepath () =
+  let default = default () in
   let config_filename = Option.value config_filename ~default:default.config_filename in
   let secrets_filepath = Option.value secrets_filepath ~default:default.secrets_filepath in
   { default with config_filename; secrets_filepath; state_filepath }
@@ -35,31 +34,12 @@ let get_secrets_exn ctx =
   | None -> context_error "secrets is uninitialized"
   | Some secrets -> secrets
 
-let get_config_exn ctx =
-  match ctx.config with
-  | None -> context_error "config is uninitialized"
-  | Some config -> config
-
 let hook_of_channel ctx channel_name =
   let secrets = get_secrets_exn ctx in
   match List.find secrets.slack_hooks ~f:(fun webhook -> String.equal webhook.channel channel_name) with
   | Some hook -> Some hook.url
   | None -> None
 
-(** `is_pipeline_allowed ctx p` returns `true` if ctx.config.status_rules
-    doesn't define a whitelist of allowed pipelines, or if the list
-    contains pipeline `p`; returns `false` otherwise. *)
-let is_pipeline_allowed ctx ~pipeline =
-  match ctx.config with
-  | None -> false
-  | Some config ->
-  match config.status_rules.allowed_pipelines with
-  | Some allowed_pipelines when not @@ List.exists allowed_pipelines ~f:(String.equal pipeline) -> false
-  | _ -> true
-
-let refresh_pipeline_status ctx ~pipeline ~(branches : Github_t.branch list) ~status =
-  if is_pipeline_allowed ctx ~pipeline then State.refresh_pipeline_status ctx.state ~pipeline ~branches ~status else ()
-
 let log = Log.from "context"
 
 let refresh_secrets ctx =
@@ -91,7 +71,7 @@ let refresh_state ctx =
     else Ok ctx
 
 let print_config ctx =
-  let cfg = get_config_exn ctx in
+  let cfg = State.find_repo_config_exn ctx.state in
   let secrets = get_secrets_exn ctx in
   log#info "using prefix routing:";
   Rule.Prefix.print_prefix_routing cfg.prefix_rules.rules;

lib/state.atd

@@ -1,4 +1,5 @@
 type status_state <ocaml from="Github"> = abstract
+type config <ocaml from="Config"> = abstract
 type 'v map_as_object <ocaml from="Common"> = abstract
 
 (* A map from branch names to build statuses *)
@@ -11,5 +12,6 @@ type pipeline_statuses = branch_statuses map_as_object
 
 (* The serializable runtime state of the bot *)
 type state = {
+  ?config <ocaml mutable>: config option;
   pipeline_statuses <ocaml mutable>: pipeline_statuses
 }

lib/state.ml

@@ -2,15 +2,35 @@ open Base
 open Common
 open Devkit
 
-let empty : State_t.state = { pipeline_statuses = StringMap.empty }
+exception State_error of string
 
-let refresh_pipeline_status (state : State_t.state) ~pipeline ~(branches : Github_t.branch list) ~status =
-  let update_pipeline_status branch_statuses =
+let state_error fmt = Printf.ksprintf (fun msg -> raise (State_error msg)) fmt
+
+let empty () : State_t.state = { pipeline_statuses = StringMap.empty; config = None }
+
+let find_repo_config_exn (state : State_t.state) =
+  match state.config with
+  | None -> state_error "config is uninitialized"
+  | Some config -> config
+
+let set_repo_pipeline_status (state : State_t.state) ~pipeline ~(branches : Github_t.branch list) ~status =
+  let set_branch_status branch_statuses =
     let new_statuses = List.map branches ~f:(fun b -> b.name, status) in
     let init = Option.value branch_statuses ~default:(Map.empty (module String)) in
     List.fold_left new_statuses ~init ~f:(fun m (key, data) -> Map.set m ~key ~data)
   in
-  state.pipeline_statuses <- Map.update state.pipeline_statuses pipeline ~f:update_pipeline_status
+  state.pipeline_statuses <- Map.update state.pipeline_statuses pipeline ~f:set_branch_status
+
+(** `is_pipeline_allowed s p` returns `true` if status_rules of state
+    `s`'s config doesn't define a whitelist of allowed pipelines, or
+    if the list contains pipeline `p`; returns `false` otherwise. *)
+let is_pipeline_allowed (state : State_t.state) ~pipeline =
+  match state.config with
+  | None -> false
+  | Some config ->
+  match config.status_rules.allowed_pipelines with
+  | Some allowed_pipelines when not @@ List.exists allowed_pipelines ~f:(String.equal pipeline) -> false
+  | _ -> true
 
 let log = Log.from "state"
 

test/test.ml

@@ -30,6 +30,7 @@ let process ~(ctx : Context.t) (kind, path, state_path) =
       Lwt.return ctx
     | Ok file ->
       let state = State_j.state_of_string file in
+      state.config <- ctx.state.config;
       Lwt.return { ctx with state }
   in
   Stdio.printf "===== file %s =====\n" path;
@@ -52,7 +53,7 @@ let () =
       log#error "%s" e;
       Lwt.return_unit
     | Ok config ->
-      let ctx = { ctx with config = Some config } in
+      ctx.state.config <- Some config;
       ( match Context.refresh_secrets ctx with
       | Ok ctx -> Lwt_list.iter_s (process ~ctx) payloads
       | Error e ->