diff --git a/lib/domain.ml b/lib/domain.ml index 5206226..cbd3fe1 100644 --- a/lib/domain.ml +++ b/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 = diff --git a/lib/domain.mli b/lib/domain.mli index 765770a..4034742 100644 --- a/lib/domain.mli +++ b/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 diff --git a/lib/github.ml b/lib/github.ml index 7905fa8..3894be9 100644 --- a/lib/github.ml +++ b/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 } ;; diff --git a/lib/github.mli b/lib/github.mli index 03dfc11..f971cb8 100644 --- a/lib/github.mli +++ b/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}. *) diff --git a/lib/githubRaw.ml b/lib/githubRaw.ml index e5c5b60..3ca5272 100644 --- a/lib/githubRaw.ml +++ b/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" diff --git a/lib/githubRaw.mli b/lib/githubRaw.mli index d5b2de1..925bbc7 100644 --- a/lib/githubRaw.mli +++ b/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 diff --git a/lib/person.ml b/lib/person.ml index 53a88db..69e5422 100644 --- a/lib/person.ml +++ b/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; diff --git a/lib/project.ml b/lib/project.ml index 1dd29b7..2550576 100644 --- a/lib/project.ml +++ b/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 *) diff --git a/lib/schedule.ml b/lib/schedule.ml index 3da67e6..769aea4 100644 --- a/lib/schedule.ml +++ b/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;