Subscribe to pull request card editions.

bot-components/GitHub_queries.mli

@@ -135,4 +135,7 @@ val get_project_field_values :
   -> project:int
   -> field:string
   -> options:string array
-  -> (GitHub_ID.t * (GitHub_ID.t * (string * string) list) option, string) result Lwt.t
+  -> ( GitHub_ID.t * (GitHub_ID.t * (string * string) list) option
+     , string )
+     result
+     Lwt.t

bot-components/GitHub_subscriptions.ml

@@ -49,25 +49,6 @@ let pull_request_info_of_json json =
       (match pr_json |> member "merged_at" with `Null -> false | _ -> true)
   ; last_commit_message= None }
 
-let project_card_of_json json =
-  let card_json = json |> member "project_card" in
-  let column_id = card_json |> member "column_id" |> to_int in
-  let regexp =
-    "https://api.github.com/repos/\\([^/]*\\)/\\([^/]*\\)/issues/\\([0-9]*\\)"
-  in
-  match card_json |> member "content_url" with
-  | `Null ->
-      Ok {issue= None; column_id}
-  | `String content_url when string_match ~regexp content_url ->
-      let owner = Str.matched_group 1 content_url in
-      let repo = Str.matched_group 2 content_url in
-      let number = Str.matched_group 3 content_url |> Int.of_string in
-      Ok {issue= Some {owner; repo; number}; column_id}
-  | `String _ ->
-      Error "Could not parse content_url field."
-  | _ ->
-      Error "content_url field has unexpected type."
-
 let comment_info_of_json ?(review_comment = false) json =
   let comment_json =
     if review_comment then json |> member "review" else json |> member "comment"
@@ -153,7 +134,7 @@ let push_event_info_of_json json =
 type msg =
   | IssueOpened of issue_info
   | IssueClosed of issue_info
-  | RemovedFromProject of project_card_issue
+  | PullRequestCardEdited of pull_request_card_info
   | PullRequestUpdated of pull_request_action * issue_info pull_request_info
   | BranchCreated of remote_ref_info
   | TagCreated of remote_ref_info
@@ -184,9 +165,27 @@ let github_action ~event ~action json =
       Ok (IssueOpened (issue_info_of_json json))
   | "issues", "closed" ->
       Ok (IssueClosed (issue_info_of_json json))
-  | "project_card", "deleted" ->
-      json |> project_card_of_json
-      |> Result.map ~f:(fun card -> RemovedFromProject card)
+  | "projects_v2_item", "edited"
+    when String.equal "PullRequest"
+           ( json |> member "projects_v2_item" |> member "content_type"
+           |> to_string )
+         && String.equal "single_select"
+              ( json |> member "changes" |> member "field_value"
+              |> member "field_type" |> to_string ) ->
+      let card_json = json |> member "projects_v2_item" in
+      let changes_json = json |> member "changes" |> member "field_value" in
+      Ok
+        (PullRequestCardEdited
+           { pr_id= card_json |> member "content_node_id" |> GitHub_ID.of_json
+           ; card_id= card_json |> member "node_id" |> GitHub_ID.of_json
+           ; project_id=
+               card_json |> member "project_node_id" |> GitHub_ID.of_json
+           ; project_number= changes_json |> member "project_number" |> to_int
+           ; field= changes_json |> member "field_name" |> to_string
+           ; old_value=
+               changes_json |> member "from" |> member "name" |> to_string
+           ; new_value=
+               changes_json |> member "to" |> member "name" |> to_string } )
   | "issue_comment", "created" ->
       Ok (CommentCreated (comment_info_of_json json))
   | "pull_request_review", "submitted" ->
@@ -204,7 +203,7 @@ let github_event ~event json =
   match event with
   | "pull_request"
   | "issues"
-  | "project_card"
+  | "projects_v2_item"
   | "issue_comment"
   | "pull_request_review"
   | "check_run"

bot-components/GitHub_subscriptions.mli

@@ -3,7 +3,7 @@ open GitHub_types
 type msg =
   | IssueOpened of issue_info
   | IssueClosed of issue_info
-  | RemovedFromProject of project_card_issue
+  | PullRequestCardEdited of pull_request_card_info
   | PullRequestUpdated of pull_request_action * issue_info pull_request_info
   | BranchCreated of remote_ref_info
   | TagCreated of remote_ref_info

bot-components/GitHub_types.mli

@@ -9,8 +9,14 @@ type merge_method = MERGE | REBASE | SQUASH
 
 type backport_info = {backport_to: string; rejected_milestone: string}
 
-type project_card =
-  {id: GitHub_ID.t; column: project_column option; columns: project_column list}
+type pull_request_card_info =
+  { pr_id: GitHub_ID.t
+  ; card_id: GitHub_ID.t
+  ; project_id: GitHub_ID.t
+  ; project_number: int
+  ; field: string
+  ; old_value: string
+  ; new_value: string }
 
 type mv_card_to_column_input = {card_id: GitHub_ID.t; column_id: GitHub_ID.t}
 

src/bot.ml

@@ -287,24 +287,32 @@ let callback _conn req body =
               (f "Issue %s/%s#%d was closed: checking its milestone."
                  issue.owner issue.repo issue.number )
             ()
+      | Ok
+          ( _
+          , PullRequestCardEdited {project_number; field; old_value; new_value}
+          )
+        when Int.equal project_number 11
+             && String.equal old_value "Request inclusion"
+             && String.equal new_value "Rejected"
+             && String.is_suffix ~suffix:" status" field ->
+          let backport_to = String.drop_suffix field 7 in
           (*
-      | Ok (_, RemovedFromProject ({issue= Some issue; column_id} as card)) ->
           (fun () ->
             action_as_github_app ~bot_info ~key ~app_id ~owner:issue.owner
               ~repo:issue.repo
               (project_action ~issue ~column_id) )
           |> Lwt.async ;
+          *)
           Server.respond_string ~status:`OK
             ~body:
               (f
-                 "Issue or PR %s/%s#%d was removed from project column %d: \
-                  checking if this was a backporting column."
-                 issue.owner issue.repo issue.number card.column_id )
+                 "PR proposed for backporting was rejected from inclusion in \
+                  %s. Updating the milestone."
+                 backport_to )
             ()
-      | Ok (_, RemovedFromProject _) ->
+      | Ok (_, PullRequestCardEdited _) ->
           Server.respond_string ~status:`OK
-            ~body:"Note card removed from project: nothing to do." ()
-            *)
+            ~body:"Unsupported pull request card edition." ()
       | Ok (_, IssueOpened ({body= Some body} as issue_info)) -> (
           let body =
             body |> trim_comments |> strip_quoted_bot_name ~github_bot_name