Add link unfurl for PRs and issues

README.md

@@ -42,7 +42,7 @@ Run the `_build/default/src/monorobot.exe` binary. The following commands are su
 
 ### Link Unfurling
 
-You can configure Monorobot to [unfurl GitHub links](https://api.slack.com/reference/messaging/link-unfurling) in Slack messages. Currently, commit links are supported.
+You can configure Monorobot to [unfurl GitHub links](https://api.slack.com/reference/messaging/link-unfurling) in Slack messages. Currently, commit, pull request, and issue links are supported.
 
 1. Give your app `links:read` and `links:write` [permissions](https://api.slack.com/apps).
 1. Configure your app to [support the Events API](https://api.slack.com/events-api#prepare). During the [url verification handshake](https://api.slack.com/events-api#the-events-api__subscribing-to-event-types__events-api-request-urls__request-url-configuration--verification__url-verification-handshake), you should tell Slack to direct event notifications to `<server_domain>/slack/events`. Ensure the server is running before triggering the handshake.

lib/action.ml

@@ -239,6 +239,16 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
       | None -> Lwt.return_none
       | Some gh_link ->
       match gh_link with
+      | Pull_request (repo, number) ->
+        ( match%lwt Github_api.get_pull_request ~ctx ~repo ~number with
+        | Error _ -> Lwt.return_none
+        | Ok pr -> Lwt.return_some @@ (link, Slack_message.populate_pull_request repo pr)
+        )
+      | Issue (repo, number) ->
+        ( match%lwt Github_api.get_issue ~ctx ~repo ~number with
+        | Error _ -> Lwt.return_none
+        | Ok issue -> Lwt.return_some @@ (link, Slack_message.populate_issue repo issue)
+        )
       | Commit (repo, sha) ->
         ( match%lwt Github_api.get_api_commit ~ctx ~repo ~sha with
         | Error _ -> Lwt.return_none

lib/api.ml

@@ -6,6 +6,10 @@ module type Github = sig
   val get_config : ctx:Context.t -> repo:repository -> (Config_t.config, string) Result.t Lwt.t
 
   val get_api_commit : ctx:Context.t -> repo:repository -> sha:string -> (api_commit, string) Result.t Lwt.t
+
+  val get_pull_request : ctx:Context.t -> repo:repository -> number:int -> (pull_request, string) Result.t Lwt.t
+
+  val get_issue : ctx:Context.t -> repo:repository -> number:int -> (issue, string) Result.t Lwt.t
 end
 
 module type Slack = sig

lib/api_local.ml

@@ -18,6 +18,10 @@ module Github : Api.Github = struct
     match get_local_file url with
     | Error e -> Lwt.return @@ fmt_error "error while getting local file: %s\nfailed to get api commit %s" e url
     | Ok file -> Lwt.return @@ Ok (Github_j.api_commit_of_string file)
+
+  let get_pull_request ~ctx:_ ~repo:_ ~number:_ = Lwt.return @@ Error "undefined for local setup"
+
+  let get_issue ~ctx:_ ~repo:_ ~number:_ = Lwt.return @@ Error "undefined for local setup"
 end
 
 module Slack_base : Api.Slack = struct

lib/api_remote.ml

@@ -10,6 +10,12 @@ module Github : Api.Github = struct
   let contents_url ~(repo : Github_t.repository) ~path =
     String.substr_replace_first ~pattern:"{+path}" ~with_:path repo.contents_url
 
+  let pulls_url ~(repo : Github_t.repository) ~number =
+    String.substr_replace_first ~pattern:"{/number}" ~with_:(sprintf "/%d" number) repo.pulls_url
+
+  let issues_url ~(repo : Github_t.repository) ~number =
+    String.substr_replace_first ~pattern:"{/number}" ~with_:(sprintf "/%d" number) repo.issues_url
+
   let build_headers ?token () =
     let headers = [ "Accept: application/vnd.github.v3+json" ] in
     Option.value_map token ~default:headers ~f:(fun v -> sprintf "Authorization: token %s" v :: headers)
@@ -38,13 +44,24 @@ module Github : Api.Github = struct
         @@ fmt_error "unexpected encoding '%s' in Github response\nfailed to get config from file %s" encoding url
       )
 
-  let get_api_commit ~(ctx : Context.t) ~repo ~sha =
+  let get_resource (ctx : Context.t) url =
     let secrets = Context.get_secrets_exn ctx in
-    let url = commits_url ~repo ~sha in
     let headers = build_headers ?token:secrets.gh_token () in
     match%lwt http_request ~headers `GET url with
-    | Ok res -> Lwt.return @@ Ok (Github_j.api_commit_of_string res)
-    | Error e -> Lwt.return @@ fmt_error "error while querying remote: %s\nfailed to get api commit from file %s" e url
+    | Ok res -> Lwt.return @@ Ok res
+    | Error e -> Lwt.return @@ fmt_error "error while querying remote: %s\nfailed to get resource from %s" e url
+
+  let get_api_commit ~(ctx : Context.t) ~repo ~sha =
+    let%lwt res = commits_url ~repo ~sha |> get_resource ctx in
+    Lwt.return @@ Result.map res ~f:Github_j.api_commit_of_string
+
+  let get_pull_request ~(ctx : Context.t) ~repo ~number =
+    let%lwt res = pulls_url ~repo ~number |> get_resource ctx in
+    Lwt.return @@ Result.map res ~f:Github_j.pull_request_of_string
+
+  let get_issue ~(ctx : Context.t) ~repo ~number =
+    let%lwt res = issues_url ~repo ~number |> get_resource ctx in
+    Lwt.return @@ Result.map res ~f:Github_j.issue_of_string
 end
 
 module Slack : Api.Slack = struct

lib/github.atd

@@ -29,12 +29,23 @@ type github_user = {
   avatar_url: string;
 }
 
+type github_team = {
+  id: int;
+  name: string;
+  slug: string;
+  url: string;
+  html_url: string;
+  ~description <ocaml default="\"\"">: string;
+}
+
 type repository = {
   name: string;
   full_name: string;
   html_url <ocaml name="url"> : string;
   commits_url: string;
   contents_url: string;
+  pulls_url: string;
+  issues_url: string;
 }
 
 type commit_pushed_notification = {
@@ -55,13 +66,25 @@ type label = {
   name: string;
 }
 
+type abstract_issue_state = [
+| Open <json name="open">
+| Closed <json name="closed">
+] <ocaml repr="classic">
+
 type pull_request = {
   user: github_user;
   number: int;
   body: string;
   title: string;
   html_url: string;
   labels: label list;
+  state: abstract_issue_state;
+  ~requested_reviewers <ocaml default="[]">: github_user list;
+  ~requested_teams <ocaml default="[]">: github_team list;
+  ~assignees <ocaml default="[]">: github_user list;
+  ~merged <ocaml default="false">: bool;
+  ~draft <ocaml default="false">: bool;
+  ~comments <ocaml default="0">: int;
 }
 
 type issue = {
@@ -72,6 +95,9 @@ type issue = {
   html_url: string;
   labels: label list;
   ?pull_request: basic_json nullable;
+  state: abstract_issue_state;
+  ~assignees <ocaml default="[]">: github_user list;
+  ~comments <ocaml default="0">: int;
 }
 
 type pr_action = [

lib/github.ml

@@ -87,7 +87,10 @@ let parse_exn ~secret headers body =
   | "member" | "create" | "delete" | "release" -> Event (event_notification_of_string body)
   | event -> failwith @@ sprintf "unsupported event : %s" event
 
-type gh_link = Commit of repository * commit_hash
+type gh_link =
+  | Pull_request of repository * int
+  | Issue of repository * int
+  | Commit of repository * commit_hash
 
 (** `gh_link_of_string s` parses a URL string `s` to try to match a supported
     GitHub link type, generating repository endpoints if necessary *)
@@ -100,7 +103,7 @@ let gh_link_of_string url_str =
   let custom_api_base ?(scheme = "https") base owner name =
     sprintf "%s://%s/api/v3/repos/%s/%s" scheme base owner name
   in
-  let re = Re.Str.regexp {|^\(.*\)/\(.+\)/\(.+\)/\(commit\)/\([a-z0-9]+\)/?$|} in
+  let re = Re.Str.regexp {|^\(.*\)/\(.+\)/\(.+\)/\(commit\|pull\|issues\)/\([a-z0-9]+\)/?$|} in
   match Uri.host url with
   | None -> None
   | Some host ->
@@ -124,11 +127,15 @@ let gh_link_of_string url_str =
         url = html_base;
         commits_url = sprintf "%s/commits{/sha}" api_base;
         contents_url = sprintf "%s/contents/{+path}" api_base;
+        pulls_url = sprintf "%s/pulls{/number}" api_base;
+        issues_url = sprintf "%s/issues{/number}" api_base;
       }
     in
     begin
       try
         match link_type with
+        | "pull" -> Some (Pull_request (repo, Int.of_string item))
+        | "issues" -> Some (Issue (repo, Int.of_string item))
         | "commit" -> Some (Commit (repo, item))
         | _ -> None
       with _ -> None

lib/slack.atd

@@ -3,6 +3,7 @@ type 'v map_as_object <ocaml from="State"> = abstract
 type message_field = {
   ?title: string nullable;
   value: string;
+  ~short <ocaml default="false">: bool;
 }
 
 type message_attachment = {

lib/slack.ml

@@ -259,7 +259,7 @@ let generate_push_notification notification channel =
             mrkdwn_in = Some [ "fields" ];
             fallback = Some "Commit pushed notification";
             color = Some "#ccc";
-            fields = Some [ { value = String.concat ~sep:"\n" commits; title = None } ];
+            fields = Some [ { value = String.concat ~sep:"\n" commits; title = None; short = false } ];
           };
         ];
     blocks = None;
@@ -315,6 +315,7 @@ let generate_status_notification (cfg : Config_t.config) (notification : status_
         (sprintf "<%s|[%s]> CI Build Status notification for <%s|%s>: %s" repository.url repository.full_name t context
            state_info)
   in
+  let msg = String.concat ~sep:"\n" @@ List.concat [ commit_info; branches_info ] in
   let attachment =
     {
       empty_attachments with
@@ -323,7 +324,7 @@ let generate_status_notification (cfg : Config_t.config) (notification : status_
       pretext = summary;
       color = Some color_info;
       text = description_info;
-      fields = Some [ { title = None; value = String.concat ~sep:"\n" @@ List.concat [ commit_info; branches_info ] } ];
+      fields = Some [ { title = None; value = msg; short = false } ];
     }
   in
   { channel; text = None; attachments = Some [ attachment ]; blocks = None }

lib/slack_message.ml

@@ -5,6 +5,19 @@ open Slack_t
 open Common
 open Mrkdwn
 
+let color_of_state ?(draft = false) ?(merged = false) state =
+  match draft with
+  | true -> Colors.gray
+  | false ->
+  match merged with
+  | true -> Colors.purple
+  | false ->
+  match state with
+  | Open -> Colors.green
+  | Closed -> Colors.red
+
+let gh_name_of_string = sprintf "@%s"
+
 let empty_attachment =
   {
     mrkdwn_in = None;
@@ -27,6 +40,84 @@ let empty_attachment =
 let base_attachment (repository : repository) =
   { empty_attachment with footer = Some (sprintf "<%s|%s>" repository.url (escape_mrkdwn repository.full_name)) }
 
+let pp_label (label : label) = label.name
+
+let pp_github_user (user : github_user) = gh_name_of_string user.login
+
+let pp_github_team (team : github_team) = gh_name_of_string team.slug
+
+let populate_pull_request repository (pull_request : pull_request) =
+  let ({
+         title;
+         number;
+         html_url;
+         user;
+         assignees;
+         comments;
+         labels;
+         requested_reviewers;
+         requested_teams;
+         state;
+         draft;
+         merged;
+         _;
+       }
+        : pull_request)
+    =
+    pull_request
+  in
+  let get_reviewers () =
+    List.concat [ List.map requested_reviewers ~f:pp_github_user; List.map requested_teams ~f:pp_github_team ]
+  in
+  let fields =
+    [
+      "Assignees", List.map assignees ~f:pp_github_user;
+      "Labels", List.map labels ~f:pp_label;
+      ("Comments", if comments > 0 then [ Int.to_string comments ] else []);
+      "Reviewers", get_reviewers ();
+    ]
+    |> List.filter_map ~f:(fun (t, v) -> if List.is_empty v then None else Some (t, String.concat v ~sep:", "))
+    |> List.map ~f:(fun (t, v) -> { title = Some t; value = v; short = true })
+  in
+  let get_title () = sprintf "#%d %s" number (Mrkdwn.escape_mrkdwn title) in
+  {
+    (base_attachment repository) with
+    author_name = Some user.login;
+    author_link = Some user.html_url;
+    author_icon = Some user.avatar_url;
+    color = Some (color_of_state ~draft ~merged state);
+    fields = Some fields;
+    mrkdwn_in = Some [ "text" ];
+    title = Some (get_title ());
+    title_link = Some html_url;
+    fallback = Some (sprintf "[%s] %s" repository.full_name title);
+  }
+
+let populate_issue repository (issue : issue) =
+  let ({ title; number; html_url; user; assignees; comments; labels; state; _ } : issue) = issue in
+  let fields =
+    [
+      "Assignees", List.map assignees ~f:pp_github_user;
+      "Labels", List.map labels ~f:pp_label;
+      ("Comments", if comments > 0 then [ Int.to_string comments ] else []);
+    ]
+    |> List.filter_map ~f:(fun (t, v) -> if List.is_empty v then None else Some (t, String.concat v ~sep:", "))
+    |> List.map ~f:(fun (t, v) -> { title = Some t; value = v; short = true })
+  in
+  let get_title () = sprintf "#%d %s" number (Mrkdwn.escape_mrkdwn title) in
+  {
+    (base_attachment repository) with
+    author_name = Some user.login;
+    author_link = Some user.html_url;
+    author_icon = Some user.avatar_url;
+    color = Some (color_of_state state);
+    fields = Some fields;
+    mrkdwn_in = Some [ "text" ];
+    title = Some (get_title ());
+    title_link = Some html_url;
+    fallback = Some (sprintf "[%s] %s" repository.full_name title);
+  }
+
 let populate_commit repository (commit : api_commit) =
   let ({ sha; commit; url; author; files; _ } : api_commit) = commit in
   let title =

test/github_link_test.ml

@@ -11,6 +11,8 @@ let mk_repo ?(scheme = "https") prefix prefix_api : repository =
     url = sprintf "%s://%s/acme/test_repo" scheme prefix;
     commits_url = sprintf "%s://%s/repos/acme/test_repo/commits{/sha}" scheme prefix_api;
     contents_url = sprintf "%s://%s/repos/acme/test_repo/contents/{+path}" scheme prefix_api;
+    pulls_url = sprintf "%s://%s/repos/acme/test_repo/pulls{/number}" scheme prefix_api;
+    issues_url = sprintf "%s://%s/repos/acme/test_repo/issues{/number}" scheme prefix_api;
   }
 
 let enterprise_repo1 = mk_repo "git.acme.org" "git.acme.org/api/v3"
@@ -21,6 +23,28 @@ let enterprise_repo_insecure = mk_repo ~scheme:"http" "git.acme.org" "git.acme.o
 
 let github_repo = mk_repo "github.com" "api.github.com"
 
+let pr_cases prefix repo =
+  [
+    sprintf "https://%s/acme/test_repo/pull/100" prefix, Some (Pull_request (repo, 100));
+    sprintf "https://%s/acme/test_repo/pull/2" prefix, Some (Pull_request (repo, 2));
+    sprintf "https://%s/acme/test_repo/pull/100/" prefix, Some (Pull_request (repo, 100));
+    sprintf "https://%s/acme/test_repo/pull/100?arg1=123" prefix, Some (Pull_request (repo, 100));
+    sprintf "https://%s/acme/test_repo/pull/abc" prefix, None;
+    sprintf "https://%s/acme/test_repo/pull/" prefix, None;
+    sprintf "https://%s/acme/test_repo/pull" prefix, None;
+  ]
+
+let issue_cases prefix repo =
+  [
+    sprintf "https://%s/acme/test_repo/issues/100" prefix, Some (Issue (repo, 100));
+    sprintf "https://%s/acme/test_repo/issues/2" prefix, Some (Issue (repo, 2));
+    sprintf "https://%s/acme/test_repo/issues/100/" prefix, Some (Issue (repo, 100));
+    sprintf "https://%s/acme/test_repo/issues/100?arg1=123" prefix, Some (Issue (repo, 100));
+    sprintf "https://%s/acme/test_repo/issues/abc" prefix, None;
+    sprintf "https://%s/acme/test_repo/issues/" prefix, None;
+    sprintf "https://%s/acme/test_repo/issues" prefix, None;
+  ]
+
 let commit_cases prefix repo =
   [
     sprintf "https://%s/acme/test_repo/commit/69c42640" prefix, Some (Commit (repo, "69c42640"));
@@ -40,9 +64,17 @@ let other_cases =
 let cases =
   List.concat
     [
+      pr_cases "github.com" github_repo;
+      issue_cases "github.com" github_repo;
       commit_cases "github.com" github_repo;
+      pr_cases "www.github.com" github_repo;
+      issue_cases "www.github.com" github_repo;
       commit_cases "www.github.com" github_repo;
+      pr_cases "git.acme.org" enterprise_repo1;
+      issue_cases "git.acme.org" enterprise_repo1;
       commit_cases "git.acme.org" enterprise_repo1;
+      pr_cases "acme.org/path/to/git" enterprise_repo2;
+      issue_cases "acme.org/path/to/git" enterprise_repo2;
       commit_cases "acme.org/path/to/git" enterprise_repo2;
       other_cases;
     ]

test/test.ml

@@ -42,7 +42,9 @@ let process ~(ctx : Context.t) (kind, path, state_path) =
 
 let () =
   let payloads = get_mock_payloads () in
-  let repo : Github_t.repository = { name = ""; full_name = ""; url = ""; commits_url = ""; contents_url = "" } in
+  let repo : Github_t.repository =
+    { name = ""; full_name = ""; url = ""; commits_url = ""; contents_url = ""; pulls_url = ""; issues_url = "" }
+  in
   let ctx = Context.make ~state_filepath:"state.json" () in
   Lwt_main.run
     ( match%lwt Api_local.Github.get_config ~ctx ~repo with