Parse GitHub assignees (and show them in project/person summaries)

Closes #51

lib/domain.ml

@@ -97,6 +97,26 @@ let combine_allocations a1 a2 =
 let get_first_day a1 = DateMap.min_binding a1 |> fst
 let get_last_day a1 = DateMap.max_binding a1 |> fst
 
+(** --- Entities ----------------------------- *)
+
+type person =
+  { email : string (** Email is the primary key for persons *)
+  ; full_name : string
+  ; github_handle : string option
+  ; slack_handle : string option
+  }
+
+type placeholder = { name : string }
+
+type entity =
+  | Person of person
+  | Placeholder of placeholder
+
+let get_entity_name = function
+  | Person p -> p.full_name
+  | Placeholder p -> Printf.sprintf "Placeholder: %s" p.name
+;;
+
 (** --- Project metadata --------------------- *)
 
 type project_plan =
@@ -169,28 +189,9 @@ type project =
   ; state : State.t
   ; programme : string option
   ; plan : project_plan option
+  ; assignees : person list
   }
 
-(** --- Entities ----------------------------- *)
-
-type person =
-  { email : string (** Email is the primary key for persons *)
-  ; full_name : string
-  ; github_handle : string option
-  ; slack_handle : string option
-  }
-
-type placeholder = { name : string }
-
-type entity =
-  | Person of person
-  | Placeholder of placeholder
-
-let get_entity_name = function
-  | Person p -> p.full_name
-  | Placeholder p -> Printf.sprintf "Placeholder: %s" p.name
-;;
-
 (** --- Emoji reactions ---------------------- *)
 
 type emoji =

lib/domain.mli

@@ -111,6 +111,25 @@ val get_last_day : 'a DateMap.t -> CalendarLib.Date.t
 
 (** {1 Entities relevant to scheduling and planning} *)
 
+(** A person *)
+type person =
+  { email : string (** Email is the primary key for persons *)
+  ; full_name : string
+  ; github_handle : string option
+  ; slack_handle : string option
+  }
+
+(** A placeholder on Forecast. *)
+type placeholder = { name : string }
+
+(** An entity is a person or a placeholder. *)
+type entity =
+  | Person of person
+  | Placeholder of placeholder
+
+(** Get the name of an entity. *)
+val get_entity_name : entity -> string
+
 (** A [plan] gives the constraints on the possible allocations to a project. *)
 type project_plan =
   { budget : FTE.t
@@ -154,30 +173,12 @@ type project =
   ; state : State.t
   ; programme : string option
   ; plan : project_plan option
+  ; assignees : person list
   }
 
 (** Convert the column name in GitHub to a variant type. May raise UnknownColumn *)
 val state_of_column : string -> State.t
 
-(** A person *)
-type person =
-  { email : string (** Email is the primary key for persons *)
-  ; full_name : string
-  ; github_handle : string option
-  ; slack_handle : string option
-  }
-
-(** A placeholder on Forecast. *)
-type placeholder = { name : string }
-
-(** An entity is a person or a placeholder. *)
-type entity =
-  | Person of person
-  | Placeholder of placeholder
-
-(** Get the name of an entity. *)
-val get_entity_name : entity -> string
-
 (** The types of emoji reactions we care about. *)
 type emoji =
   | Laugh

lib/github.ml

@@ -88,6 +88,15 @@ type person = GithubRaw.person =
   }
 [@@deriving show, ord]
 
+type issue =
+  { number : int (** The issue number from GitHub *)
+  ; name : string
+  ; state : Domain.State.t
+  ; programme : string option
+  ; plan : Domain.project_plan option
+  ; assignees : string list
+  }
+
 (* We recognise only floats, strings, and lists of strings as valid types in the metadata.
    We parse the YAML into this variant type first, and then pick the correct types for
    each field later. *)
@@ -325,7 +334,7 @@ let find_programme (issue : Raw.issue) =
   List.find_map parse_label issue.labels
 ;;
 
-let make_issue (col_name : string) (issue : Raw.issue) =
+let make_issue (col_name : string) (issue : Raw.issue) : issue =
   let plan =
     match parse_metadata issue with
     | None -> None
@@ -340,6 +349,7 @@ let make_issue (col_name : string) (issue : Raw.issue) =
   ; state = state_of_column col_name
   ; programme = find_programme issue
   ; plan
+  ; assignees = issue.assignees
   }
 ;;
 

lib/github.mli

@@ -50,13 +50,23 @@ type github_event =
 
 (* We reexport the Raw.person type so that no other module ever has a need to import
    anything from GithubRaw. *)
-
 type person = GithubRaw.person =
   { login : string
   ; name : string option
   ; email : string option
   }
 
+(* Intermediate type for a project. We cannot parse assignee usernames until we
+   have gotten to Schedule, because to do so requires data from Forecast.. *)
+type issue =
+  { number : int (** The issue number from GitHub *)
+  ; name : string
+  ; state : Domain.State.t
+  ; programme : string option
+  ; plan : Domain.project_plan option
+  ; assignees : string list
+  }
+
 (** A type for Github users. *)
 val show_person : person -> string
 
@@ -66,7 +76,7 @@ val compare_person : person -> person -> int
 
 (** Given a project board name, return a list of projects, one for each issue on the
     board. *)
-val get_project_issues : unit -> Domain.project list
+val get_project_issues : unit -> issue list
 
 (** This is re-exported from [GithubRaw] for convenience. See
     {!GithubRaw.get_all_users_async}. *)

lib/githubRaw.ml

@@ -143,8 +143,8 @@ type issue =
   ; title : string
   ; body : string
   ; state : issue_state
-  ; assignees : person list
   ; labels : string list
+  ; assignees : string list
   }
 
 let get_issue_async id =
@@ -167,14 +167,12 @@ let get_issue_async id =
     |> to_list
     |> List.map (fun a -> a |> member "login" |> to_string)
   in
-  let* assignee_opts = assignee_usernames |> List.map find_person_by_login |> Lwt.all in
-  let assignees = assignee_opts |> List.filter_map Fun.id in
   Lwt.return
     { number = id
     ; title = issue_json |> member "title" |> to_string
     ; body = issue_json |> member "body" |> to_string
     ; state = issue_json |> member "state" |> to_string |> state_of_string
-    ; assignees
+    ; assignees = assignee_usernames
     ; labels =
         issue_json
         |> member "labels"

lib/githubRaw.mli

@@ -83,8 +83,8 @@ type issue =
   ; title : string
   ; body : string
   ; state : issue_state
-  ; assignees : person list
   ; labels : string list
+  ; assignees : string list
   }
 
 (** A GitHub issue, but with reactions. We have a separate type for this because

lib/person.ml

@@ -50,6 +50,15 @@ let print_info ~(use_color : bool) (psn : person) =
   prout ~use_color [ ANSI.Bold ] (make_box s)
 ;;
 
+let print_github_assignments ~(use_color : bool) (prjs : project list) =
+  print_heading ~use_color "GitHub issue assignments";
+  match prjs with
+  | [] -> print_endline "None found."
+  | _ ->
+    let print_prj prj = Printf.printf "#%-4d %s\n" prj.number prj.name in
+    List.iter print_prj prjs
+;;
+
 let print_assignments ~(use_color : bool) (asns : assignment list) =
   let make_name asn = Printf.sprintf "#%-4d %s" asn.project.number asn.project.name in
   print_heading ~use_color "Recent Forecast assignments";
@@ -152,9 +161,17 @@ let print
             >= CL.Date.add (CL.Date.today ()) (CL.Date.Period.month (-2)))
     |> List.sort Assignment.compare_by_date
   in
+  let this_github_prjs =
+    prjs
+    |> IntMap.filter (fun _ v -> List.mem psn v.assignees)
+    |> IntMap.bindings
+    |> List.map snd
+  in
   print_info ~use_color psn;
   print_endline "";
   print_endline "";
+  print_github_assignments ~use_color this_github_prjs;
+  print_endline "";
   print_assignments ~use_color this_asns;
   print_endline "";
   print_capacity ~use_color this_asns;

lib/project.ml

@@ -28,30 +28,33 @@ let print_metadata ~(use_color : bool) (prj : project) =
   (match prj.programme with
    | None -> prout ~use_color [ ANSI.red ] "Programme           : Not found\n"
    | Some s -> printf "Programme           : %s\n" s);
-  match prj.plan with
-  | None -> print_endline "Remaining metadata could not be parsed from GitHub."
-  | Some plan ->
-    let earliest_start_date_string =
-      match plan.earliest_start_date with
-      | None -> "None"
-      | Some d -> CalendarLib.Printer.Date.to_string d
-    in
-    let latest_end_date_string =
-      match plan.latest_end_date with
-      | None -> "None"
-      | Some d -> CalendarLib.Printer.Date.to_string d
-    in
-    (match plan.finance_codes with
-     | [] -> prout ~use_color [ ANSI.red ] "Finance codes       : Not found\n"
-     | xs -> printf "Finance codes       : %s\n" (String.concat ", " xs));
-    printf "Earliest start date : %s\n" earliest_start_date_string;
-    printf
-      "Latest start date   : %s\n"
-      (CalendarLib.Printer.Date.to_string plan.latest_start_date);
-    printf "Latest end date     : %s\n" latest_end_date_string;
-    printf "Minimum FTE         : %.0f%%\n" plan.min_fte_percent;
-    printf "Nominal FTE         : %.0f%%\n" plan.nominal_fte_percent;
-    printf "Maximum FTE         : %.0f%%\n" plan.max_fte_percent
+  (match prj.plan with
+   | None -> print_endline "Remaining metadata could not be parsed from GitHub."
+   | Some plan ->
+     let earliest_start_date_string =
+       match plan.earliest_start_date with
+       | None -> "None"
+       | Some d -> CalendarLib.Printer.Date.to_string d
+     in
+     let latest_end_date_string =
+       match plan.latest_end_date with
+       | None -> "None"
+       | Some d -> CalendarLib.Printer.Date.to_string d
+     in
+     (match plan.finance_codes with
+      | [] -> prout ~use_color [ ANSI.red ] "Finance codes       : Not found\n"
+      | xs -> printf "Finance codes       : %s\n" (String.concat ", " xs));
+     printf "Earliest start date : %s\n" earliest_start_date_string;
+     printf
+       "Latest start date   : %s\n"
+       (CalendarLib.Printer.Date.to_string plan.latest_start_date);
+     printf "Latest end date     : %s\n" latest_end_date_string;
+     printf "Minimum FTE         : %.0f%%\n" plan.min_fte_percent;
+     printf "Nominal FTE         : %.0f%%\n" plan.nominal_fte_percent;
+     printf "Maximum FTE         : %.0f%%\n" plan.max_fte_percent);
+  printf
+    "GitHub assignees    : %s\n"
+    (List.map (fun p -> p.full_name) prj.assignees |> String.concat ", ")
 ;;
 
 (** [asns] must be subsetted to only those belonging to this project *)

lib/schedule.ml

@@ -317,15 +317,36 @@ type project_pair = Pair of (Forecast.project option * project option)
  *)
 let merge_projects
   (fc_projects : Forecast.project IntMap.t)
-  (gh_issues : project IntMap.t)
+  (gh_issues : Github.issue IntMap.t)
+  (people : person list)
   =
+  (* First, add in the assignees from Forecast *)
+  let map_assignees (gh_p : Github.issue) : project =
+    let new_assignees =
+      List.filter_map
+        (fun a -> List.find_opt (fun p -> p.github_handle = Some a) people)
+        gh_p.assignees
+    in
+    { number = gh_p.number
+    ; name = gh_p.name
+    ; state = gh_p.state
+    ; programme = gh_p.programme
+    ; plan = gh_p.plan
+    ; assignees = new_assignees
+    }
+  in
+  let gh_projects = IntMap.map map_assignees gh_issues in
+
+  (* Pair the Forecast and GitHub projects *)
   let pair_projects _ fc_opt gh_opt =
     match fc_opt, gh_opt with
     | None, None -> None
     | x, y -> Some (Pair (x, y))
   in
-  let combined_map = IntMap.merge pair_projects fc_projects gh_issues in
-  let check_projects _ (pair : project_pair) =
+  let combined_map = IntMap.merge pair_projects fc_projects gh_projects in
+
+  (* Check the pairs for any inconsistencies and log events as necessary *)
+  let check_projects _ (pair : project_pair) : unit =
     (* Check that they both exist *)
     match pair with
     | Pair (None, None) -> ()
@@ -347,7 +368,9 @@ let merge_projects
       if not finance_codes_match then log_event (FinanceCodeNotMatchingError gh_p)
   in
   IntMap.iter check_projects combined_map;
-  gh_issues
+
+  (* Return only the GitHub issues *)
+  gh_projects
 ;;
 
 (* ---------------------------------------------------------------------- *)
@@ -389,6 +412,7 @@ let upconvert (prj : Forecast.project) : project =
   ; state = Other
   ; programme = Some prj.programme
   ; plan = None
+  ; assignees = []
   }
 ;;
 
@@ -524,11 +548,14 @@ let get_the_schedule ~start_date ~end_date =
   let fc_people = fc_people' |> Forecast.StringMap.bindings |> List.map snd in
   let gh_issues = Github.get_project_issues () in
   let gh_issues_map =
-    gh_issues |> List.map (fun i -> i.number, i) |> List.to_seq |> IntMap.of_seq
+    gh_issues
+    |> List.map (fun (i : Github.issue) -> i.number, i)
+    |> List.to_seq
+    |> IntMap.of_seq
   in
   let gh_people = Github.get_all_users_async |> Lwt_main.run in
   let people = merge_people fc_people gh_people fc_assignments in
-  let projects = merge_projects fc_projects gh_issues_map in
+  let projects = merge_projects fc_projects gh_issues_map people in
   let assignments = List.filter_map (merge_assignment people projects) fc_assignments in
   check_projects projects assignments;