handle pr notifications on the same thread

lib/action.ml

@@ -5,8 +5,10 @@ open Common
 open Github_j
 
 exception Action_error of string
+exception Success_handler_error of string
 
 let action_error msg = raise (Action_error msg)
+let handler_error msg = raise (Success_handler_error msg)
 let log = Log.from "action"
 
 module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
@@ -41,12 +43,8 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     (* Updates mapping every 24 hours *)
     refresh_username_to_slack_id_tbl_background_lwt ~ctx
 
-  let match_github_login_to_slack_id cfg_opt login =
-    let login =
-      match cfg_opt with
-      | None -> login
-      | Some cfg -> List.assoc_opt login cfg.user_mappings |> Option.default login
-    in
+  let match_github_login_to_slack_id cfg login =
+    let login = List.assoc_opt login cfg.user_mappings |> Option.default login in
     login |> canonicalize_email_username |> Stringtbl.find_opt username_to_slack_id_tbl
 
   let partition_push (cfg : Config_t.config) n =
@@ -81,10 +79,24 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     labels |> List.concat_map (Rule.Label.match_rules ~rules) |> List.sort_uniq String.compare |> fun channel_names ->
     if channel_names = [] then Stdlib.Option.to_list default else channel_names
 
-  let partition_pr cfg (n : pr_notification) =
+  let partition_pr cfg (ctx : Context.t) (n : pr_notification) =
     match n.action with
-    | (Opened | Closed | Reopened | Labeled | Ready_for_review) when not n.pull_request.draft ->
+    | (Opened | Closed | Reopened | Ready_for_review) when not n.pull_request.draft ->
       partition_label cfg n.pull_request.labels
+    | Labeled when not n.pull_request.draft ->
+      (* labels get notified by gh in addition the pr notification itself, which means that when we open a pr
+          we have one `Open` notification and as many `Labeled` notifications as the pr has labels.
+          we want to avoid having many notifications for a single `Opened` event. *)
+      (match State.has_pr_thread ctx.state ~repo_url:n.repository.url ~pr_url:n.pull_request.html_url with
+      | false ->
+        (* we dont have a thread for the pr yet, these are the labels notifications before the PR *)
+        []
+      | true ->
+        (* if we already have a thread on a certain channel, we already have received an open PR notification.
+           If we have a new label that triggers a notification on a new channel, we'll notify the channel.
+           If the label triggers a notification on a channel with an existing thread, the notification will go
+           in the thread *)
+        partition_label cfg n.pull_request.labels)
     | _ -> []
 
   let partition_issue cfg (n : issue_notification) =
@@ -105,16 +117,17 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
   let partition_pr_review cfg (n : pr_review_notification) =
     let { review; action; _ } = n in
     match action, review.state, review.body with
-    | Submitted, "commented", (Some "" | None) -> []
-    (* the case (action = Submitted, review.state = "commented", review.body = "") happens when
-       a reviewer starts a review by commenting on particular sections of the code, which triggars a pull_request_review_comment event simultaneouly,
-       and then submits the review without submitting any general feedback or explicit approval/changes.
+    | Submitted, "commented", (Some "" | None) ->
+      (* the case (action = Submitted, review.state = "commented", review.body = "") happens when
+           a reviewer starts a review by commenting on particular sections of the code, which triggars a pull_request_review_comment event simultaneouly,
+           and then submits the review without submitting any general feedback or explicit approval/changes.
 
-       the case (action = Submitted, review.state = "commented", review.body = null) happens when
-       a reviewer adds a single comment on a particular section of the code, which triggars a pull_request_review_comment event simultaneouly.
+           the case (action = Submitted, review.state = "commented", review.body = null) happens when
+           a reviewer adds a single comment on a particular section of the code, which triggars a pull_request_review_comment event simultaneouly.
 
-       in both cases, since pull_request_review_comment is already handled by another type of event, information in the pull_request_review payload
-       does not provide any insightful information and will thus be ignored. *)
+         in both cases, since pull_request_review_comment is already handled by another type of event, information in the pull_request_review payload
+         does not provide any insightful information and will thus be ignored. *)
+      []
     | Submitted, _, _ -> partition_label cfg n.pull_request.labels
     | _ -> []
 
@@ -238,27 +251,37 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
   let generate_notifications (ctx : Context.t) (req : Github.t) =
     let repo = Github.repo_of_notification req in
     let cfg = Context.find_repo_config_exn ctx repo.url in
-    let slack_match_func = match_github_login_to_slack_id (Some cfg) in
+    let slack_match_func = match_github_login_to_slack_id cfg in
+    let get_thread_permalink = Slack_api.get_thread_permalink in
     match ignore_notifications_from_user cfg req with
     | true -> Lwt.return []
     | false ->
     match req with
     | Github.Push n ->
       partition_push cfg n |> List.map (fun (channel, n) -> generate_push_notification n channel) |> Lwt.return
     | Pull_request n ->
-      partition_pr cfg n |> List.map (generate_pull_request_notification ~slack_match_func n) |> Lwt.return
+      let%lwt notifications =
+        partition_pr cfg ctx n
+        |> Lwt_list.map_p (generate_pull_request_notification ~ctx ~slack_match_func ~get_thread_permalink n)
+      in
+      Lwt.return @@ List.flatten notifications
     | PR_review n ->
-      partition_pr_review cfg n |> List.map (generate_pr_review_notification ~slack_match_func n) |> Lwt.return
-    | PR_review_comment _n ->
-      (* we want to silence review comments and keep only the "main" review message
-         TODO: make this configurable? *)
-      Lwt.return []
-      (* partition_pr_review_comment cfg n
-         |> List.map (generate_pr_review_comment_notification ~slack_match_func n)
-         |> Lwt.return *)
+      let%lwt notifications =
+        partition_pr_review cfg n
+        |> Lwt_list.map_p (generate_pr_review_notification ~ctx ~slack_match_func ~get_thread_permalink n)
+      in
+      Lwt.return @@ List.flatten notifications
+    | PR_review_comment n ->
+      partition_pr_review_comment cfg n
+      |> List.map (generate_pr_review_comment_notification ~ctx ~slack_match_func n)
+      |> Lwt.return
     | Issue n -> partition_issue cfg n |> List.map (generate_issue_notification ~slack_match_func n) |> Lwt.return
     | Issue_comment n ->
-      partition_issue_comment cfg n |> List.map (generate_issue_comment_notification ~slack_match_func n) |> Lwt.return
+      let%lwt notifications =
+        partition_issue_comment cfg n
+        |> Lwt_list.map_p (generate_issue_comment_notification ~ctx ~slack_match_func ~get_thread_permalink n)
+      in
+      Lwt.return @@ List.flatten notifications
     | Commit_comment n ->
       let%lwt channels, api_commit = partition_commit_comment ctx n in
       let notifs = List.map (generate_commit_comment_notification ~slack_match_func api_commit n) channels in
@@ -269,9 +292,17 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
       Lwt.return notifs
 
   let send_notifications (ctx : Context.t) notifications =
-    let notify (msg : Slack_t.post_message_req) =
+    let notify (msg, handler) =
       match%lwt Slack_api.send_notification ~ctx ~msg with
-      | Ok () -> Lwt.return_unit
+      | Ok (Some res) ->
+        (match handler with
+        | None -> Lwt.return_unit
+        | Some handler ->
+        try
+          handler res;
+          Lwt.return_unit
+        with exn -> handler_error (Printexc.to_string exn))
+      | Ok None -> Lwt.return_unit
       | Error e -> action_error e
     in
     Lwt_list.iter_s notify notifications
@@ -360,6 +391,9 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     | Action_error msg ->
       log#error "action error %s" msg;
       Lwt.return_unit
+    | Success_handler_error msg ->
+      log#error "success handler error %s" msg;
+      Lwt.return_unit
     | Context.Context_error msg ->
       log#error "context error %s" msg;
       Lwt.return_unit

lib/api.ml

@@ -22,7 +22,7 @@ module type Slack = sig
     lookup_user_res slack_response Lwt.t
 
   val list_users : ?cursor:string -> ?limit:int -> ctx:Context.t -> unit -> list_users_res slack_response Lwt.t
-  val send_notification : ctx:Context.t -> msg:post_message_req -> unit slack_response Lwt.t
+  val send_notification : ctx:Context.t -> msg:post_message_req -> post_message_res option slack_response Lwt.t
 
   val send_chat_unfurl :
     ctx:Context.t ->
@@ -33,4 +33,6 @@ module type Slack = sig
     unit slack_response Lwt.t
 
   val send_auth_test : ctx:Context.t -> unit -> auth_test_res slack_response Lwt.t
+
+  val get_thread_permalink : ctx:Context.t -> State_t.slack_thread -> string option Lwt.t
 end

lib/api_local.ml

@@ -56,6 +56,7 @@ module Slack_base : Api.Slack = struct
   let send_notification ~ctx:_ ~msg:_ = Lwt.return @@ Error "undefined for local setup"
   let send_chat_unfurl ~ctx:_ ~channel:_ ~ts:_ ~unfurls:_ () = Lwt.return @@ Error "undefined for local setup"
   let send_auth_test ~ctx:_ () = Lwt.return @@ Error "undefined for local setup"
+  let get_thread_permalink ~ctx:_ (_thread : State_t.slack_thread) = Lwt.return_none
 end
 
 (** Module for mocking test requests to slack--will output on Stdio *)
@@ -76,7 +77,7 @@ module Slack : Api.Slack = struct
     let json = msg |> Slack_j.string_of_post_message_req |> Yojson.Basic.from_string |> Yojson.Basic.pretty_to_string in
     Printf.printf "will notify #%s\n" msg.channel;
     Printf.printf "%s\n" json;
-    Lwt.return @@ Ok ()
+    Lwt.return @@ Ok None
 
   let send_chat_unfurl ~ctx:_ ~channel ~ts ~unfurls () =
     let req = Slack_j.{ channel; ts; unfurls } in
@@ -88,6 +89,12 @@ module Slack : Api.Slack = struct
   let send_auth_test ~ctx:_ () =
     Lwt.return
     @@ Ok ({ url = ""; team = ""; user = ""; team_id = ""; user_id = "test_slack_user" } : Slack_t.auth_test_res)
+
+  let get_thread_permalink ~ctx:_ (thread : State_t.slack_thread) =
+    Lwt.return_some
+    @@ Printf.sprintf "https://monorobot.slack.com/archives/%s/p%s?thread_ts=%s&cid=%s" thread.cid
+         (Stre.replace_all ~str:thread.ts ~sub:"." ~by:"")
+         thread.ts thread.cid
 end
 
 (** Simple messages (only the actual text messages that users see) output to log for checking payload commands *)
@@ -101,7 +108,7 @@ module Slack_simple : Api.Slack = struct
       (match msg.Slack_t.text with
       | None -> ""
       | Some s -> sprintf " with %S" s);
-    Lwt.return @@ Ok ()
+    Lwt.return @@ Ok None
 
   let send_chat_unfurl ~ctx:_ ~channel ~ts:_ ~(unfurls : Slack_t.message_attachment Common.StringMap.t) () =
     Printf.printf "will unfurl in #%s\n" channel;
@@ -114,6 +121,8 @@ module Slack_simple : Api.Slack = struct
   let send_auth_test ~ctx:_ () =
     Lwt.return
     @@ Ok ({ url = ""; team = ""; user = ""; team_id = ""; user_id = "test_slack_user" } : Slack_t.auth_test_res)
+
+  let get_thread_permalink ~ctx:_ (_thread : State_t.slack_thread) = Lwt.return_none
 end
 
 (** Messages payload in json output to log for checking payload commands *)
@@ -129,7 +138,7 @@ module Slack_json : Api.Slack = struct
     let url = Uri.add_query_param url ("msg", [ json ]) in
     log#info "%s" (Uri.to_string url);
     log#info "%s" json;
-    Lwt.return @@ Ok ()
+    Lwt.return @@ Ok None
 
   let send_chat_unfurl ~ctx:_ ~channel ~ts:_ ~(unfurls : Slack_t.message_attachment Common.StringMap.t) () =
     log#info "will notify %s" channel;
@@ -142,4 +151,6 @@ module Slack_json : Api.Slack = struct
   let send_auth_test ~ctx:_ () =
     Lwt.return
     @@ Ok ({ url = ""; team = ""; user = ""; team_id = ""; user_id = "test_slack_user" } : Slack_t.auth_test_res)
+
+  let get_thread_permalink ~ctx:_ (_thread : State_t.slack_thread) = Lwt.return_none
 end

lib/api_remote.ml

@@ -185,12 +185,14 @@ module Slack : Api.Slack = struct
       log#info "data: %s" data;
       if webhook_mode then begin
         match%lwt http_request ~body ~headers `POST url with
-        | Ok _res -> Lwt.return @@ Ok ()
+        | Ok _res ->
+          (* Webhooks reply only 200 `ok`. We can't generate anything useful for notification success handlers *)
+          Lwt.return @@ Ok None
         | Error e -> Lwt.return @@ build_error (query_error_msg url e)
       end
       else begin
         match%lwt slack_api_request ~body ~headers `POST url Slack_j.read_post_message_res with
-        | Ok _res -> Lwt.return @@ Ok ()
+        | Ok res -> Lwt.return @@ Ok (Some res)
         | Error e -> Lwt.return @@ build_error e
       end
 
@@ -203,4 +205,19 @@ module Slack : Api.Slack = struct
 
   let send_auth_test ~(ctx : Context.t) () =
     request_token_auth ~name:"retrieve bot information" ~ctx `POST "auth.test" Slack_j.read_auth_test_res
+
+  let get_thread_permalink ~(ctx : Context.t) (thread : State_t.slack_thread) =
+    let url_args = Web.make_url_args [ "channel", thread.cid; "message_ts", thread.ts ] in
+    match%lwt
+      request_token_auth ~name:"retrieve message permalink" ~ctx `GET
+        (sprintf "chat.getPermalink?%s" url_args)
+        Slack_j.read_permalink_res
+    with
+    | Error (s : string) ->
+      log#warn "couldn't fetch permalink for slack thread %s: %s" thread.ts s;
+      Lwt.return_none
+    | Ok (res : Slack_t.permalink_res) when res.ok = false ->
+      log#warn "bad request fetching permalink for slack thread %s: %s" thread.ts (Option.default "" res.error);
+      Lwt.return_none
+    | Ok ({ permalink; _ } : Slack_t.permalink_res) -> Lwt.return_some permalink
 end

lib/slack.atd

@@ -58,6 +58,7 @@ type message_block = [
 
 type post_message_req = {
   channel: string;
+  ?thread_ts: string nullable;
   ?username : string nullable;
   ?text: string nullable;
   ?attachments: message_attachment list nullable;
@@ -68,6 +69,7 @@ type post_message_req = {
 
 type post_message_res = {
   channel: string;
+  ts: string;
 }
 
 type lookup_user_res = {
@@ -144,6 +146,13 @@ type auth_test_res = {
   user_id: string;
 }
 
+type permalink_res = {
+  ok: bool;
+  permalink: string;
+  channel: string;
+  ?error: string nullable;
+}
+
 type ('ok, 'err) http_response <ocaml predef module="Result" t="t"> = [
   | Ok of 'ok
   | Error of 'err