Support updating corresponding comment message in Slack

lib/action.ml

@@ -58,12 +58,12 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
 
   let partition_pr_review_comment cfg (n : pr_review_comment_notification) =
     match n.action with
-    | Created -> partition_label cfg n.pull_request.labels
+    | Created | Edited -> partition_label cfg n.pull_request.labels
     | _ -> []
 
   let partition_issue_comment cfg (n : issue_comment_notification) =
     match n.action with
-    | Created -> partition_label cfg n.issue.labels
+    | Created | Edited -> partition_label cfg n.issue.labels
     | _ -> []
 
   let partition_pr_review cfg (n : pr_review_notification) =
@@ -79,7 +79,7 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
 
        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
+    | (Submitted | Edited), _, _ -> partition_label cfg n.pull_request.labels
     | _ -> []
 
   let partition_commit (cfg : Config_t.config) files =
@@ -174,6 +174,46 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     | Some sender_login -> List.exists cfg.ignored_users ~f:(String.equal sender_login)
     | None -> false
 
+  let generate_stateful_notification (ctx : Context.t) content req channel =
+    match req with
+    | Github.PR_review_comment n ->
+      ( match n.action with
+      | Github_t.Created -> Some (generate_new_message content channel)
+      | Edited ->
+        ( match State.get_comment_msg ctx.state n.repository.url ~issue_num:n.pull_request.number n.comment.id with
+        | None ->
+          log#warn "could not find comment %d in %s for PR #%n" n.comment.id n.repository.url n.pull_request.number;
+          None
+        | Some ts -> Some (generate_update_message content ~ts channel)
+        )
+      | _ -> None
+      )
+    | Issue_comment n ->
+      ( match n.action with
+      | Github_t.Created -> Some (generate_new_message content channel)
+      | Edited ->
+        ( match State.get_comment_msg ctx.state n.repository.url ~issue_num:n.issue.number n.comment.id with
+        | None ->
+          log#warn "could not find comment %d in %s for issue #%n" n.comment.id n.repository.url n.issue.number;
+          None
+        | Some ts -> Some (generate_update_message content ~ts channel)
+        )
+      | _ -> None
+      )
+    | PR_review n ->
+      ( match n.action with
+      | Github_t.Submitted -> Some (generate_new_message content channel)
+      | Edited ->
+        ( match State.get_review_msg ctx.state n.repository.url ~issue_num:n.pull_request.number n.review.id with
+        | None ->
+          log#warn "could not find review %d in %s for PR #%n" n.review.id n.repository.url n.pull_request.number;
+          None
+        | Some ts -> Some (generate_update_message content ~ts channel)
+        )
+      | _ -> None
+      )
+    | _ -> Some (generate_new_message content channel)
+
   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
@@ -182,30 +222,84 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     | false ->
     match req with
     | Github.Push n ->
-      partition_push cfg n |> List.map ~f:(fun (channel, n) -> generate_push_notification n channel) |> Lwt.return
-    | Pull_request n -> partition_pr cfg n |> List.map ~f:(generate_pull_request_notification n) |> Lwt.return
-    | PR_review n -> partition_pr_review cfg n |> List.map ~f:(generate_pr_review_notification n) |> Lwt.return
+      partition_push cfg n
+      |> List.map ~f:(fun (channel, n) ->
+           generate_stateful_notification ctx (generate_push_notification_content n) req channel
+         )
+      |> Lwt.return
+    | Pull_request n ->
+      partition_pr cfg n
+      |> List.map ~f:(fun channel ->
+           generate_stateful_notification ctx (generate_pull_request_notification_content n) req channel
+         )
+      |> Lwt.return
+    | PR_review n ->
+      partition_pr_review cfg n
+      |> List.map ~f:(fun channel ->
+           generate_stateful_notification ctx (generate_pr_review_notification_content n) req channel
+         )
+      |> Lwt.return
     | PR_review_comment n ->
-      partition_pr_review_comment cfg n |> List.map ~f:(generate_pr_review_comment_notification n) |> Lwt.return
-    | Issue n -> partition_issue cfg n |> List.map ~f:(generate_issue_notification n) |> Lwt.return
+      partition_pr_review_comment cfg n
+      |> List.map ~f:(fun channel ->
+           generate_stateful_notification ctx (generate_pr_review_comment_notification_content n) req channel
+         )
+      |> Lwt.return
+    | Issue n ->
+      partition_issue cfg n
+      |> List.map ~f:(fun channel ->
+           generate_stateful_notification ctx (generate_issue_notification_content n) req channel
+         )
+      |> Lwt.return
     | Issue_comment n ->
-      partition_issue_comment cfg n |> List.map ~f:(generate_issue_comment_notification n) |> Lwt.return
+      partition_issue_comment cfg n
+      |> List.map ~f:(fun channel ->
+           (* not sure why but when I remove "fun channel" it evaluates the [generate_issue_comment_notification_content n] before the partition so I got errors but when I add this, it's completely fine, probably some compiler optimization? *)
+           generate_stateful_notification ctx (generate_issue_comment_notification_content n) req channel
+         )
+      |> Lwt.return
     | Commit_comment n ->
       let%lwt channels, api_commit = partition_commit_comment ctx n in
-      let notifs = List.map ~f:(generate_commit_comment_notification api_commit n) channels in
+      let notifs =
+        List.map
+          ~f:(generate_stateful_notification ctx (generate_commit_comment_notification_content api_commit n) req)
+          channels
+      in
       Lwt.return notifs
     | Status n ->
       let%lwt channels = partition_status ctx n in
-      let notifs = List.map ~f:(generate_status_notification cfg n) channels in
+      let notifs =
+        List.map
+          ~f:(fun channel -> generate_stateful_notification ctx (generate_status_notification_content cfg n) req channel)
+          channels
+      in
       Lwt.return notifs
     | _ -> Lwt.return []
 
-  let send_notifications (ctx : Context.t) notifications =
-    let notify (msg : Slack_t.post_message_req) =
-      match%lwt Slack_api.send_notification ~ctx ~msg with
-      | Ok () -> Lwt.return_unit
-      | Error e -> action_error e
+  let send_notifications (ctx : Context.t) (req : Github.t) notifications =
+    let update_comment_mapping message =
+      match req with
+      | Github.PR_review_comment n ->
+        State.add_comment_msg ctx.state n.repository.url ~issue_num:n.pull_request.number n.comment.id message
+      | Issue_comment n ->
+        State.add_comment_msg ctx.state n.repository.url ~issue_num:n.issue.number n.comment.id message
+      | PR_review n ->
+        State.add_review_msg ctx.state n.repository.url ~issue_num:n.pull_request.number n.review.id message
+      | _ -> Lwt.return_unit
+    in
+    let notify = function
+      | New_message (msg : Slack_t.post_message_req) ->
+        ( match%lwt Slack_api.send_notification ~ctx ~msg with
+        | Ok res -> update_comment_mapping res.ts
+        | Error e -> action_error e
+        )
+      | Update_message msg ->
+        ( match%lwt Slack_api.update_notification ~ctx ~msg with
+        | Ok () -> Lwt.return_unit
+        | Error e -> action_error e
+        )
     in
+
     Lwt_list.iter_s notify notifications
 
   (** [refresh_repo_config ctx n] fetches the latest repo config if it's
@@ -253,6 +347,13 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
       end
     | _ -> Lwt.return_unit
 
+  let cleanup_state (ctx : Context.t) (payload : Github.t) =
+    match payload with
+    | Github.Pull_request { action = Closed; pull_request = { number; _ }; repository = { url; _ }; _ }
+    | Issue { action = Closed; issue = { number; _ }; repository = { url; _ }; _ } ->
+      State.close_issue ctx.state url number
+    | _ -> Lwt.return_unit
+
   let process_github_notification (ctx : Context.t) headers body =
     let validate_signature secrets payload =
       let repo = Github.repo_of_notification payload in
@@ -278,10 +379,14 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
           | Error e -> action_error e
           | Ok () ->
             let%lwt notifications = generate_notifications ctx payload in
-            let%lwt () = Lwt.join [ send_notifications ctx notifications; do_github_tasks ctx repo payload ] in
+            let%lwt () =
+              Lwt.join
+                [ send_notifications ctx payload (List.filter_opt notifications); do_github_tasks ctx repo payload ]
+            in
             ( match ctx.state_filepath with
             | None -> Lwt.return_unit
             | Some path ->
+              let%lwt () = cleanup_state ctx payload in
               ( match%lwt State.save ctx.state path with
               | Ok () -> Lwt.return_unit
               | Error e -> action_error e

lib/api.ml

@@ -18,7 +18,8 @@ module type Github = sig
 end
 
 module type Slack = sig
-  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 slack_response Lwt.t
+  val update_notification : ctx:Context.t -> msg:update_message_req -> unit slack_response Lwt.t
 
   val send_chat_unfurl
     :  ctx:Context.t ->

lib/api_local.ml

@@ -53,6 +53,7 @@ end
 (** The base implementation for local check payload debugging and mocking tests *)
 module Slack_base : Api.Slack = struct
   let send_notification ~ctx:_ ~msg:_ = Lwt.return @@ Error "undefined for local setup"
+  let update_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"
 end
@@ -65,6 +66,14 @@ 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
     Stdio.printf "will notify #%s\n" msg.channel;
     Stdio.printf "%s\n" json;
+    Lwt.return @@ Ok ({ channel = msg.channel; ts = "SOMETS" } : Slack_t.post_message_res)
+
+  let update_notification ~ctx:_ ~msg =
+    let json =
+      msg |> Slack_j.string_of_update_message_req |> Yojson.Basic.from_string |> Yojson.Basic.pretty_to_string
+    in
+    Stdio.printf "will update msg in #%s\n" msg.channel;
+    Stdio.printf "%s\n" json;
     Lwt.return @@ Ok ()
 
   let send_chat_unfurl ~ctx:_ ~channel ~ts ~unfurls () =
@@ -91,6 +100,14 @@ module Slack_simple : Api.Slack = struct
       | None -> ""
       | Some s -> sprintf " with %S" s
       );
+    Lwt.return @@ Ok ({ channel = msg.channel; ts = "SOMETS" } : Slack_t.post_message_res)
+
+  let update_notification ~ctx:_ ~(msg : Slack_t.update_message_req) =
+    log#info "will update msg in #%s: %s\n" msg.channel
+      ( match msg.Slack_t.text with
+      | None -> ""
+      | Some s -> sprintf " with %S" s
+      );
     Lwt.return @@ Ok ()
 
   let send_chat_unfurl ~ctx:_ ~channel ~ts:_ ~(unfurls : Slack_t.message_attachment Common.StringMap.t) () =
@@ -117,6 +134,15 @@ 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 ({ channel = msg.channel; ts = "SOMETS" } : Slack_t.post_message_res)
+
+  let update_notification ~ctx:_ ~(msg : Slack_t.update_message_req) =
+    log#info "will notify %s" msg.channel;
+    let json = Slack_j.string_of_update_message_req msg in
+    let url = Uri.of_string "https://api.slack.com/docs/messages/builder" in
+    let url = Uri.add_query_param url ("msg", [ json ]) in
+    log#info "%s" (Uri.to_string url);
+    log#info "%s" json;
     Lwt.return @@ Ok ()
 
   let send_chat_unfurl ~ctx:_ ~channel ~ts:_ ~(unfurls : Slack_t.message_attachment Common.StringMap.t) () =

lib/api_remote.ml

@@ -139,12 +139,44 @@ 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 -> Lwt.return_ok @@ Slack_j.post_message_res_of_string res
         | 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 res
+        | Error e -> Lwt.return @@ build_error e
+      end
+
+  (** [update_notification ctx msg] update a message at [msg.ts] in [msg.channel]
+      with the payload [msg]; uses web API with access token if available, or with
+      webhook otherwise *)
+  let update_notification ~(ctx : Context.t) ~(msg : Slack_t.update_message_req) =
+    log#info "sending to %s" msg.channel;
+    let build_error e = fmt_error "%s\nfailed to send Slack notification" e in
+    let secrets = Context.get_secrets_exn ctx in
+    let headers, url, webhook_mode =
+      match Context.hook_of_channel ctx msg.channel with
+      | Some url -> [], Some url, true
+      | None ->
+      match secrets.slack_access_token with
+      | Some access_token -> [ bearer_token_header access_token ], Some "https://slack.com/api/chat.update", false
+      | None -> [], None, false
+    in
+    match url with
+    | None -> Lwt.return @@ build_error @@ sprintf "no token or webhook configured to notify channel %s" msg.channel
+    | Some url ->
+      let data = Slack_j.string_of_update_message_req msg in
+      let body = `Raw ("application/json", data) in
+      log#info "data: %s" data;
+      if webhook_mode then begin
+        match%lwt http_request ~body ~headers `POST url with
+        | Ok (_res : string) -> Lwt.return_ok ()
+        | 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_update_message_res with
+        | Ok (_res : Slack_t.update_message_res) -> Lwt.return_ok ()
         | Error e -> Lwt.return @@ build_error e
       end
 

lib/github.atd

@@ -185,6 +185,7 @@ type pr_notification = {
 
 type review = {
   ?body: string nullable;
+  id: int;
   html_url: string;
   state: string;
 }
@@ -287,7 +288,7 @@ type api_commit = {
 }
 
 type commit_comment_notification = {
-  action: string;
+  action: comment_action;
   repository: repository;
   comment: comment;
   sender: github_user;

lib/slack.atd

@@ -65,6 +65,17 @@ type post_message_req = {
 
 type post_message_res = {
   channel: string;
+  ts: string;
+}
+
+type update_message_req = {
+  inherit post_message_req;
+  ts: string;
+}
+
+type update_message_res = {
+  channel: string;
+  ts: string;
 }
 
 type link_shared_link = {