make state a hash table mapping repo urls to repo-specific state

Repo state is namespaced by the full url of the repo, so that
so that identifiers are unique across platforms (github.com and
GH Enterprise).

Author: yasunariw

lib/action.ml

@@ -87,13 +87,14 @@ 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 = State.get_repo_config_exn ctx.state in
+    let repo = n.repository in
+    let cfg = State.find_repo_config_exn ctx.state repo.url 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 () = State.set_repo_pipeline_status ~pipeline ~branches ~status:current_status ctx.state in
+      State.set_repo_pipeline_status ctx.state repo.url ~pipeline ~branches ~status:current_status;
       match List.is_empty branches with
       | true -> Lwt.return []
       | false ->
@@ -105,18 +106,18 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
       | false -> Lwt.return default
       | true ->
         let sha = n.commit.sha in
-        let repo = n.repository in
         ( match%lwt Github_api.get_api_commit ~ctx ~repo ~sha with
         | Error e -> action_error e
         | Ok commit -> Lwt.return @@ partition_commit cfg commit.files
         )
     in
-    if State.is_pipeline_allowed ctx.state ~pipeline then begin
+    if State.is_pipeline_allowed ctx.state repo.url ~pipeline then begin
+      let repo_state = State.find_repo_exn ctx.state repo.url in
       match Rule.Status.match_rules ~rules n with
       | Some Ignore | None -> Lwt.return []
       | Some Allow -> action_on_match n.branches
       | Some Allow_once ->
-      match Map.find ctx.state.pipeline_statuses pipeline with
+      match Map.find repo_state.pipeline_statuses pipeline with
       | Some branch_statuses ->
         let has_same_status_state_as_prev (branch : branch) =
           match Map.find branch_statuses branch.name with
@@ -130,7 +131,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 = State.get_repo_config_exn ctx.state in
+    let cfg = State.find_repo_config_exn ctx.state n.repository.url in
     match n.comment.commit_id with
     | None -> action_error "unable to find commit id for this commit comment event"
     | Some sha ->
@@ -149,7 +150,8 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
       )
 
   let generate_notifications (ctx : Context.t) req =
-    let cfg = State.get_repo_config_exn ctx.state in
+    let repo = Github.repo_of_notification req in
+    let cfg = State.find_repo_config_exn ctx.state repo.url in
     match req with
     | Github.Push n ->
       partition_push cfg n |> List.map ~f:(fun (webhook, n) -> webhook, generate_push_notification n) |> Lwt.return
@@ -190,20 +192,21 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     in
     Lwt_list.iter_s notify notifications
 
-  (** `refresh_config_of_context ctx n` updates the current context if the configuration
-      hasn't been loaded yet, or if the incoming request `n` is a push
+  (** `refresh_repo_config ctx n` fetches the latest repo config if it's
+      uninitialized in state, or if the incoming request `n` is a push
       notification containing commits that touched the config file. *)
-  let refresh_config_of_context (ctx : Context.t) notification =
+  let refresh_repo_config (ctx : Context.t) notification =
+    let repo = Github.repo_of_notification notification in
     let fetch_config () =
-      let repo = Github.repo_of_notification notification in
       match%lwt Github_api.get_config ~ctx ~repo with
       | Ok config ->
-        ctx.state.config <- Some config;
-        Context.print_config ctx;
+        State.set_repo_config ctx.state ~repo_url:repo.url ~config;
+        Context.print_config ctx repo.url;
         Lwt.return @@ Ok ()
       | Error e -> action_error e
     in
-    match ctx.state.config with
+    let repo_state = State.find_or_add_repo ctx.state repo.url in
+    match repo_state.config with
     | None -> fetch_config ()
     | Some _ ->
     match notification with
@@ -220,7 +223,7 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
       match Github.parse_exn ~secret:secrets.gh_hook_token headers body with
       | exception exn -> Exn_lwt.fail ~exn "failed to parse payload"
       | payload ->
-        ( match%lwt refresh_config_of_context ctx payload with
+        ( match%lwt refresh_repo_config ctx payload with
         | Error e -> action_error e
         | Ok () ->
           let%lwt notifications = generate_notifications ctx payload in
@@ -244,4 +247,7 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     | Context.Context_error msg ->
       log#error "%s" msg;
       Lwt.return_unit
+    | State.State_error msg ->
+      log#error "%s" msg;
+      Lwt.return_unit
 end

lib/common.ml

@@ -15,6 +15,18 @@ module StringMap = struct
   let unwrap = to_list
 end
 
+module Table = struct
+  type 'a t = (string, 'a) Hashtbl.t
+
+  let to_list (l : 'a t) : (string * 'a) list = Hashtbl.to_alist l
+
+  let of_list (m : (string * 'a) list) : 'a t = Hashtbl.of_alist_exn (module String) m
+
+  let wrap = of_list
+
+  let unwrap = to_list
+end
+
 let fmt_error fmt = Printf.ksprintf (fun s -> Error s) fmt
 
 let first_line s =

lib/context.ml

@@ -20,7 +20,7 @@ let default : t =
     secrets_filepath = "secrets.json";
     state_filepath = None;
     secrets = None;
-    state = State.empty;
+    state = State.empty ();
   }
 
 let make ?config_filename ?secrets_filepath ?state_filepath () =
@@ -63,8 +63,8 @@ let refresh_state ctx =
     end
     else Ok ctx
 
-let print_config ctx =
-  let cfg = State.get_repo_config_exn ctx.state in
+let print_config ctx repo_url =
+  let cfg = State.find_repo_config_exn ctx.state repo_url 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

@@ -5,6 +5,10 @@ type 'v map_as_object =
   (string * 'v) list <json repr="object">
     wrap <ocaml module="Common.StringMap" t="'v Common.StringMap.t">
 
+type 'v table_as_object =
+  (string * 'v) list <json repr="object">
+    wrap <ocaml module="Common.Table" t="'v Common.Table.t">
+
 (* A map from branch names to build statuses *)
 type branch_statuses = status_state map_as_object
 
@@ -13,8 +17,11 @@ type branch_statuses = status_state map_as_object
    branch *)
 type pipeline_statuses = branch_statuses map_as_object
 
-(* The serializable runtime state of the bot *)
-type state = {
+(* The runtime state of a given GitHub repository *)
+type repo_state = {
   ?config <ocaml mutable>: config option;
   pipeline_statuses <ocaml mutable>: pipeline_statuses
-}
+}
+
+(* The serializable runtime state of the bot *)
+type state = repo_state table_as_object

lib/state.ml

@@ -6,26 +6,44 @@ exception State_error of string
 
 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 empty_repo_state () : State_t.repo_state = { pipeline_statuses = StringMap.empty; config = None }
 
-let get_repo_config_exn (state : State_t.state) =
-  match state.config with
-  | None -> state_error "config is uninitialized"
+let empty () : State_t.state = Hashtbl.create (module String)
+
+let find_or_add_repo (state : State_t.state) repo_url = Hashtbl.find_or_add state repo_url ~default:empty_repo_state
+
+let find_repo_exn (state : State_t.state) repo_url =
+  match Hashtbl.find state repo_url with
+  | None -> state_error "state uninitialized for repo %s" repo_url
+  | Some repo_state -> repo_state
+
+let find_repo_config_exn state repo_url =
+  match (find_repo_exn state repo_url).config with
+  | None -> state_error "config uninitialized for repo %s" repo_url
   | Some config -> config
 
-let set_repo_pipeline_status (state : State_t.state) ~pipeline ~(branches : Github_t.branch list) ~status =
+let set_repo_config (state : State_t.state) ~repo_url ~config =
+  match Hashtbl.find state repo_url with
+  | None -> state_error "state uninitialized for repo %s" repo_url
+  | Some repo_state -> repo_state.config <- Some config
+
+let set_repo_pipeline_status (state : State_t.state) repo_url ~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: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
+  match Hashtbl.find state repo_url with
+  | None -> state_error "state uninitialized for repo %s" repo_url
+  | Some repo_state ->
+    repo_state.pipeline_statuses <- Map.update repo_state.pipeline_statuses pipeline ~f:set_branch_status
+
+(** `is_pipeline_allowed s r p` returns `true` if
+    `status_rules` doesn't define a whitelist of allowed
+    pipelines in the config of repo `r`, or if the list
+    contains pipeline `p`; returns `false` otherwise. *)
+let is_pipeline_allowed (state : State_t.state) repo_url ~pipeline =
+  match (find_repo_exn state repo_url).config with
   | None -> false
   | Some config ->
   match config.status_rules.allowed_pipelines with