parse incoming unfurl links and try to construct supported GH types

Again, currently supports commit links but can be extended later on.

We shouldn't unfurl if three or more links are present, or if the
link type isn't supported for none of the urls.

Author: yasunariw

lib/action.ml

@@ -232,4 +232,42 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
     | Context.Context_error msg ->
       log#error "%s" msg;
       Lwt.return_unit
+
+  let process_link_shared_event (ctx : Context.t) (event : Slack_t.link_shared_event) =
+    let process link =
+      match Github.gh_link_of_string link with
+      | None -> Lwt.return_none
+      | Some gh_link ->
+      match gh_link with
+      | 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)
+        )
+    in
+    if List.length event.links > 2 then Lwt.return "ignored: more than two links present"
+    else begin
+      let links = List.map event.links ~f:(fun l -> l.url) in
+      let%lwt unfurls = List.map links ~f:process |> Lwt.all |> Lwt.map List.filter_opt |> Lwt.map StringMap.of_list in
+      if Map.is_empty unfurls then Lwt.return "ignored: no links to unfurl"
+      else begin
+        let req : Slack_j.chat_unfurl_req = { channel = event.channel; ts = event.message_ts; unfurls } in
+        match%lwt Slack_api.send_chat_unfurl ~ctx req with
+        | Ok () -> Lwt.return "ok"
+        | Error e ->
+          log#error "%s" e;
+          Lwt.return "ignored: failed to unfurl links"
+      end
+    end
+
+  let process_slack_event (ctx : Context.t) headers body =
+    let secrets = Context.get_secrets_exn ctx in
+    match Slack_j.event_notification_of_string body with
+    | Url_verification payload -> Lwt.return payload.challenge
+    | Event_callback notification ->
+    match Slack.validate_signature ?signing_key:secrets.slack_signing_secret ~headers body with
+    | Error e -> action_error e
+    | Ok () ->
+    match notification.event with
+    | Link_shared event -> process_link_shared_event ctx event
 end

lib/github.ml

@@ -86,3 +86,50 @@ let parse_exn ~secret headers body =
   | "commit_comment" -> Commit_comment (commit_comment_notification_of_string 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
+
+(** `gh_link_of_string s` parses a URL string `s` to try to match a supported
+    GitHub link type, generating repository endpoints if necessary *)
+let gh_link_of_string url_str =
+  let url = Uri.of_string url_str in
+  let path = Uri.path url in
+  let gh_com_html_base owner name = sprintf "https://github.com/%s/%s" owner name in
+  let gh_com_api_base owner name = sprintf "https://api.github.com/repos/%s/%s" owner name in
+  let custom_html_base ?(scheme = "https") base owner name = sprintf "%s://%s/%s/%s" scheme base owner name in
+  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
+  match Uri.host url with
+  | None -> None
+  | Some host ->
+  match Re.Str.string_match re path 0 with
+  | false -> None
+  | true ->
+    let base = host ^ Re.Str.matched_group 1 path in
+    let owner = Re.Str.matched_group 2 path in
+    let name = Re.Str.matched_group 3 path in
+    let link_type = Re.Str.matched_group 4 path in
+    let item = Re.Str.matched_group 5 path 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 repo =
+      {
+        name;
+        full_name = sprintf "%s/%s" owner name;
+        url = html_base;
+        commits_url = sprintf "%s/commits{/sha}" api_base;
+        contents_url = sprintf "%s/contents/{+path}" api_base;
+      }
+    in
+    begin
+      try
+        match link_type with
+        | "commit" -> Some (Commit (repo, item))
+        | _ -> None
+      with _ -> None
+    end