Merge pull request #127 from sewenthy/119-unfurling-commit-range-links

Add support for compare link unfurling

Author: Khady

lib/action.ml

@@ -320,25 +320,29 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
         Lwt.return_none
     in
     let process link =
+      let with_gh_result_populate_slack (type a) ~(api_result : (a, string) Result.t)
+        ~(populate : repository -> a -> Slack_t.message_attachment) ~repo
+        =
+        match api_result with
+        | Error _ -> Lwt.return_none
+        | Ok item -> Lwt.return_some @@ (link, populate repo item)
+      in
       match Github.gh_link_of_string link with
       | 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)
-        )
+        let%lwt result = Github_api.get_pull_request ~ctx ~repo ~number in
+        with_gh_result_populate_slack ~api_result:result ~populate:Slack_message.populate_pull_request ~repo
       | 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)
-        )
+        let%lwt result = Github_api.get_issue ~ctx ~repo ~number in
+        with_gh_result_populate_slack ~api_result:result ~populate:Slack_message.populate_issue ~repo
       | Commit (repo, sha) ->
-        ( match%lwt Github_api.get_api_commit ~ctx ~repo ~sha with
-        | Error _ -> Lwt.return_none
-        | Ok commit -> Lwt.return_some @@ (link, Slack_message.populate_commit repo commit)
-        )
+        let%lwt result = Github_api.get_api_commit ~ctx ~repo ~sha in
+        with_gh_result_populate_slack ~api_result:result ~populate:Slack_message.populate_commit ~repo
+      | Compare (repo, basehead) ->
+        let%lwt result = Github_api.get_compare ~ctx ~repo ~basehead in
+        with_gh_result_populate_slack ~api_result:result ~populate:Slack_message.populate_compare ~repo
     in
     let%lwt bot_user_id =
       match State.get_bot_user_id ctx.state with

lib/api.ml

@@ -7,6 +7,7 @@ module type Github = sig
   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
+  val get_compare : ctx:Context.t -> repo:repository -> basehead:Github.basehead -> (compare, string) Result.t Lwt.t
 
   val request_reviewers
     :  ctx:Context.t ->

lib/api_local.ml

@@ -1,34 +1,63 @@
 open Base
 open Common
 open Devkit
+open Printf
 
 let cwd = Caml.Sys.getcwd ()
 let cache_dir = Caml.Filename.concat cwd "github-api-cache"
 
+(** return the file with a function f applied unless the file is empty;
+ empty file:this is needed to simulate 404 returns from github *)
+let with_cache_file url f =
+  match get_local_file url with
+  | Error e ->
+    let err_msg = sprintf "error while getting local file: %s\ncached for url: %s" e url in
+    Stdio.print_endline err_msg;
+    Lwt.return_error err_msg
+  | Ok "" -> Lwt.return_error "empty file"
+  | Ok file -> Lwt.return_ok (f file)
+
+let clean_forward_slashes = String.substr_replace_all ~pattern:"/" ~with_:"_"
+
+(** get a member of the repo cached API call providing
+the member kind (pull, issue, commit, compare, etc),
+_ref (pr number, issue number, commit sha, compare basehead, etc),
+and its Github_j.<kind>_of_string function.
+NB: please save the cache file in the same format *)
+let get_repo_member_cache ~(repo : Github_t.repository) ~kind ~ref_ ~of_string =
+  let file = clean_forward_slashes (sprintf "%s_%s_%s" repo.full_name kind ref_) in
+  let url = Caml.Filename.concat cache_dir file in
+  with_cache_file url of_string
+
 module Github : Api.Github = struct
   let get_config ~(ctx : Context.t) ~repo:_ =
     let url = Caml.Filename.concat cwd ctx.config_filename in
-    match get_local_file url with
-    | Error e -> Lwt.return @@ fmt_error "error while getting local file: %s\nfailed to get config %s" e url
-    | Ok file -> Lwt.return @@ Ok (Config_j.config_of_string file)
-
-  let get_api_commit ~ctx:_ ~repo:_ ~sha =
-    let url = Caml.Filename.concat cache_dir sha in
-    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"
+    with_cache_file url Config_j.config_of_string
+
+  let get_api_commit ~ctx:_ ~repo ~sha =
+    get_repo_member_cache ~repo ~kind:"commit" ~ref_:sha ~of_string:Github_j.api_commit_of_string
+
+  let get_pull_request ~ctx:_ ~(repo : Github_t.repository) ~number =
+    get_repo_member_cache ~repo ~kind:"pull" ~ref_:(Int.to_string number) ~of_string:Github_j.pull_request_of_string
+
+  let get_issue ~ctx:_ ~(repo : Github_t.repository) ~number =
+    get_repo_member_cache ~repo ~kind:"issue" ~ref_:(Int.to_string number) ~of_string:Github_j.issue_of_string
+
+  let get_compare ~ctx:_ ~(repo : Github_t.repository) ~basehead:(base, merge) =
+    get_repo_member_cache ~repo ~kind:"compare" ~ref_:(sprintf "%s...%s" base merge)
+      ~of_string:Github_j.compare_of_string
+
   let request_reviewers ~ctx:_ ~repo:_ ~number:_ ~reviewers:_ = Lwt.return @@ Error "undefined for local setup"
 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 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
 
+(** Module for mocking test requests to slack--will output on Stdio *)
 module Slack : Api.Slack = struct
   include Slack_base
 
@@ -37,8 +66,20 @@ module Slack : Api.Slack = struct
     Stdio.printf "will notify #%s\n" msg.channel;
     Stdio.printf "%s\n" json;
     Lwt.return @@ Ok ()
+
+  let send_chat_unfurl ~ctx:_ ~channel ~ts ~unfurls () =
+    let req = Slack_j.{ channel; ts; unfurls } in
+    let data = req |> Slack_j.string_of_chat_unfurl_req |> Yojson.Basic.from_string |> Yojson.Basic.pretty_to_string in
+    Stdio.printf "will unfurl in #%s\n" channel;
+    Stdio.printf "%s\n" data;
+    Lwt.return @@ Ok ()
+
+  let send_auth_test ~ctx:_ () =
+    Lwt.return
+    @@ Ok ({ url = ""; team = ""; user = ""; team_id = ""; user_id = "test_slack_user" } : Slack_t.auth_test_res)
 end
 
+(** Simple messages (only the actual text messages that users see) output to log for checking payload commands *)
 module Slack_simple : Api.Slack = struct
   include Slack_base
 
@@ -48,11 +89,22 @@ module Slack_simple : Api.Slack = struct
     log#info "will notify %s%s" msg.channel
       ( match msg.Slack_t.text with
       | None -> ""
-      | Some s -> Printf.sprintf " with %S" s
+      | Some s -> sprintf " with %S" s
       );
     Lwt.return @@ Ok ()
+
+  let send_chat_unfurl ~ctx:_ ~channel ~ts:_ ~(unfurls : Slack_t.message_attachment Common.StringMap.t) () =
+    Stdio.printf "will unfurl in #%s\n" channel;
+    let unfurl_text = List.map (StringMap.to_list unfurls) ~f:(fun (_, unfurl) -> unfurl.text) in
+    Stdio.printf "%s\n" (String.concat ~sep:"\n" (List.filter_opt unfurl_text));
+    Lwt.return @@ Ok ()
+
+  let send_auth_test ~ctx:_ () =
+    Lwt.return
+    @@ Ok ({ url = ""; team = ""; user = ""; team_id = ""; user_id = "test_slack_user" } : Slack_t.auth_test_res)
 end
 
+(** Messages payload in json output to log for checking payload commands *)
 module Slack_json : Api.Slack = struct
   include Slack_base
 
@@ -66,4 +118,16 @@ module Slack_json : Api.Slack = struct
     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) () =
+    log#info "will notify %s" channel;
+    let json = List.map (StringMap.to_list unfurls) ~f:(fun (_, unfurl) -> Slack_j.string_of_unfurl unfurl) in
+    let url = Uri.of_string "https://slack.com/api/chat.unfurl" in
+    log#info "%s" (Uri.to_string url);
+    log#info "%s" (String.concat ~sep:";\n" json);
+    Lwt.return @@ Ok ()
+
+  let send_auth_test ~ctx:_ () =
+    Lwt.return
+    @@ Ok ({ url = ""; team = ""; user = ""; team_id = ""; user_id = "test_slack_user" } : Slack_t.auth_test_res)
 end

lib/api_remote.ml

@@ -16,6 +16,9 @@ module Github : Api.Github = struct
   let issues_url ~(repo : Github_t.repository) ~number =
     String.substr_replace_first ~pattern:"{/number}" ~with_:(sprintf "/%d" number) repo.issues_url
 
+  let compare_url ~(repo : Github_t.repository) ~basehead:(base, merge) =
+    String.substr_replace_first ~pattern:"{/basehead}" ~with_:(sprintf "/%s...%s" base merge) repo.compare_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)
@@ -71,6 +74,12 @@ module Github : Api.Github = struct
     let%lwt res = issues_url ~repo ~number |> get_resource ~secrets:(Context.get_secrets_exn ctx) ~repo_url:repo.url in
     Lwt.return @@ Result.map res ~f:Github_j.issue_of_string
 
+  let get_compare ~(ctx : Context.t) ~(repo : Github_t.repository) ~basehead =
+    let%lwt res =
+      compare_url ~repo ~basehead |> get_resource ~secrets:(Context.get_secrets_exn ctx) ~repo_url:repo.url
+    in
+    Lwt.return @@ Result.map res ~f:Github_j.compare_of_string
+
   let request_reviewers ~(ctx : Context.t) ~(repo : Github_t.repository) ~number ~reviewers =
     let body = Github_j.string_of_request_reviewers_req reviewers in
     let%lwt res =

lib/github.atd

@@ -27,6 +27,16 @@ type commit = {
   modified: string list;
 }
 
+type file = {
+  sha: commit_hash;
+  filename: string;
+  status: string;
+  additions: int;
+  deletions: int;
+  changes: int;
+  blob_url <ocaml name="url"> : string;
+}
+
 type github_user = {
   login: string;
   id: int;
@@ -52,6 +62,7 @@ type repository = {
   contents_url: string;
   pulls_url: string;
   issues_url: string;
+  compare_url: string;
 }
 
 type commit_pushed_notification = {
@@ -106,6 +117,22 @@ type issue = {
   ~comments <ocaml default="0">: int;
 }
 
+type compare = {
+  url: string;
+  html_url: string;
+  permalink_url: string;
+  diff_url: string;
+  patch_url: string;
+  base_commit: api_commit;
+  merge_base_commit: api_commit;
+  status: string;
+  ahead_by: int;
+  behind_by: int;
+  total_commits: int;
+  commits: api_commit list;
+  ~files <ocaml default="[]">: file list;
+}
+
 type pr_action = [
   Assigned <json name="assigned">
   | Unassigned <json name="unassigned">
@@ -244,16 +271,6 @@ type status_notification = {
   updated_at: string;
 }
 
-type file = {
-  sha: commit_hash;
-  filename: string;
-  status: string;
-  additions: int;
-  deletions: int;
-  changes: int;
-  blob_url <ocaml name="url"> : string;
-}
-
 type api_commit_stats = {
   total: int;
   additions: int;
@@ -264,9 +281,9 @@ type api_commit = {
   sha: commit_hash;
   commit: inner_commit;
   html_url <ocaml name="url"> : string;
-  author: github_user;
-  files: file list;
-  stats: api_commit_stats;
+  ?author: github_user option; (* will be none if author's email is not associated with any github account *)
+  ~files <ocaml default="[]">: file list;
+  ~stats <ocaml default="{total=0; additions=0; deletions=0;}">: api_commit_stats;
 }
 
 type commit_comment_notification = {

lib/github.ml

@@ -87,12 +87,18 @@ let parse_exn headers body =
   | "member" | "create" | "delete" | "release" -> Event (event_notification_of_string body)
   | event -> failwith @@ sprintf "unsupported event : %s" event
 
+type basehead = string * string
+
 type gh_link =
   | Pull_request of repository * int
   | Issue of repository * int
   | Commit of repository * commit_hash
+  | Compare of repository * basehead
 
-let gh_link_re = Re2.create_exn {|^(.*)/(.+)/(.+)/(commit|pull|issues)/([a-z0-9]+)/?$|}
+let gh_link_re = Re2.create_exn {|^(.*)/(.+)/(.+)/(commit|pull|issues|compare)/([a-zA-Z0-9/:\-_.~\^%]+)$|}
+let commit_sha_re = Re2.create_exn {|[a-f0-9]{4,40}|}
+let comparer_re = {|([a-zA-Z0-9/:\-_.~\^]+)|}
+let compare_basehead_re = Re2.create_exn (sprintf {|%s([.]{3})%s|} comparer_re comparer_re)
 let gh_org_team_re = Re2.create_exn {|[a-zA-Z0-9\-]+/([a-zA-Z0-9\-]+)|}
 
 (** [gh_link_of_string s] parses a URL string [s] to try to match a supported
@@ -111,13 +117,14 @@ let gh_link_of_string url_str =
   | Some host ->
   match Re2.find_submatches_exn gh_link_re path with
   | [| _; prefix; Some owner; Some name; Some link_type; Some item |] ->
-    let base = Option.value_map prefix ~default:host ~f:(fun p -> String.concat [ host; p ]) in
-    let scheme = Uri.scheme url in
-    let html_base, api_base =
-      if String.is_suffix base ~suffix:"github.com" then gh_com_html_base owner name, gh_com_api_base owner name
-      else custom_html_base ?scheme base owner name, custom_api_base ?scheme base owner name
-    in
+    let item = Base.String.chop_suffix_if_exists item ~suffix:"/" in
     let repo =
+      let base = Option.value_map prefix ~default:host ~f:(fun p -> String.concat [ host; p ]) in
+      let scheme = Uri.scheme url in
+      let html_base, api_base =
+        if String.is_suffix base ~suffix:"github.com" then gh_com_html_base owner name, gh_com_api_base owner name
+        else custom_html_base ?scheme base owner name, custom_api_base ?scheme base owner name
+      in
       {
         name;
         full_name = sprintf "%s/%s" owner name;
@@ -126,14 +133,30 @@ let gh_link_of_string url_str =
         contents_url = sprintf "%s/contents/{+path}" api_base;
         pulls_url = sprintf "%s/pulls{/number}" api_base;
         issues_url = sprintf "%s/issues{/number}" api_base;
+        compare_url = sprintf "%s/compare{/basehead}" api_base;
       }
     in
+    let verify_commit_sha repo item =
+      try
+        match Re2.find_submatches_exn commit_sha_re item with
+        | [| Some sha |] -> Some (Commit (repo, sha))
+        | _ -> None
+      with _ -> None
+    in
+    let verify_compare_basehead repo basehead =
+      match Re2.find_submatches_exn compare_basehead_re basehead with
+      | [| _; Some base; _; Some merge |] -> Some (Compare (repo, (base, merge)))
+      | _ | (exception Re2.Exceptions.Regex_match_failed _) -> None
+    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))
+        | "commit" -> verify_commit_sha repo item
+        | "compare" ->
+          let item = Uri.pct_decode item in
+          verify_compare_basehead repo item
         | _ -> None
       with _ -> None
     end