Merge branch 'yasu/filter-out-bot-msg'

* yasu/filter-out-bot-msg:
  log#warn and include contextual info
  slack: don't unfurl own msg links
  slack: add auth.test endpoint with atd adapter

Author: yasunariw

lib/action.ml

@@ -238,6 +238,23 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
       Lwt.return_unit
 
   let process_link_shared_event (ctx : Context.t) (event : Slack_t.link_shared_event) =
+    let fetch_bot_user_id () =
+      match%lwt Slack_api.send_auth_test ~ctx () with
+      | Ok { user_id; _ } ->
+        ctx.state.bot_user_id <- Some user_id;
+        let%lwt () =
+          Option.value_map ctx.state_filepath ~default:Lwt.return_unit ~f:(fun path ->
+            match%lwt State.save ctx.state path with
+            | Ok () -> Lwt.return_unit
+            | Error msg ->
+              log#warn "failed to save state file %s : %s" path msg;
+              Lwt.return_unit)
+        in
+        Lwt.return_some user_id
+      | Error msg ->
+        log#warn "failed to query slack auth.test : %s" msg;
+        Lwt.return_none
+    in
     let process link =
       match Github.gh_link_of_string link with
       | None -> Lwt.return_none
@@ -259,7 +276,14 @@ module Action (Github_api : Api.Github) (Slack_api : Api.Slack) = struct
         | Ok commit -> Lwt.return_some @@ (link, Slack_message.populate_commit repo commit)
         )
     in
+    let%lwt bot_user_id =
+      match ctx.state.bot_user_id with
+      | Some id -> Lwt.return_some id
+      | None -> fetch_bot_user_id ()
+    in
     if List.length event.links > 2 then Lwt.return "ignored: more than two links present"
+    else if Option.value_map bot_user_id ~default:false ~f:(String.equal event.user) then
+      Lwt.return "ignored: is bot user"
     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

lib/api.ml

@@ -16,4 +16,6 @@ module type Slack = sig
   val send_notification : ctx:Context.t -> msg:post_message_req -> (unit, string) Result.t Lwt.t
 
   val send_chat_unfurl : ctx:Context.t -> chat_unfurl_req -> (unit, string) Result.t Lwt.t
+
+  val send_auth_test : ctx:Context.t -> unit -> auth_test_res slack_response Lwt.t
 end

lib/api_local.ml

@@ -28,6 +28,8 @@ module Slack_base : Api.Slack = struct
   let send_notification ~ctx:_ ~msg:_ = Lwt.return @@ Error "undefined for local setup"
 
   let send_chat_unfurl ~ctx:_ _ = Lwt.return @@ Error "undefined for local setup"
+
+  let send_auth_test ~ctx:_ () = Lwt.return @@ Error "undefined for local setup"
 end
 
 module Slack : Api.Slack = struct

lib/api_remote.ml

@@ -67,6 +67,11 @@ end
 module Slack : Api.Slack = struct
   let log = Log.from "slack"
 
+  let slack_http_request ?headers ?body meth url read =
+    match%lwt http_request ?headers ?body meth url with
+    | Error e -> Lwt.return @@ Error (sprintf "error while querying %s: %s" url e)
+    | Ok s -> Lwt.return @@ Slack_j.slack_response_of_string read s
+
   let bearer_token_header access_token = sprintf "Authorization: Bearer %s" (Uri.pct_encode access_token)
 
   (** `send_notification ctx msg` notifies `msg.channel` with the payload `msg`;
@@ -123,4 +128,17 @@ module Slack : Api.Slack = struct
         )
       | Error e -> Lwt.return @@ fmt_error "error while querying %s: %s\nfailed to unfurl Slack links" url e
       )
+
+  let send_auth_test ~(ctx : Context.t) () =
+    log#info "retrieving bot information";
+    let secrets = Context.get_secrets_exn ctx in
+    match secrets.slack_access_token with
+    | None -> Lwt.return @@ Error "failed to retrieve Slack access token"
+    | Some access_token ->
+      let url = "https://slack.com/api/auth.test" in
+      let headers = [ bearer_token_header access_token ] in
+      ( match%lwt slack_http_request ~headers `GET url Slack_j.read_auth_test_res with
+      | Ok res -> Lwt.return @@ Ok res
+      | Error e -> Lwt.return @@ Error (sprintf "%s\nfailed to retrieve Slack auth info" e)
+      )
 end

lib/atd_adapters.ml

@@ -46,3 +46,28 @@ module Branch_filters_adapter = List_or_default_field.Make (struct
 
   let default_value = `List []
 end)
+
+module Slack_response_adapter : Atdgen_runtime.Json_adapter.S = struct
+  let normalize (x : Yojson.Safe.t) =
+    match x with
+    | `Assoc fields ->
+      begin
+        match List.assoc "ok" fields with
+        | `Bool true -> `List [ `String "Ok"; x ]
+        | `Bool false ->
+          begin
+            match List.assoc "error" fields with
+            | `String msg -> `List [ `String "Error"; `String msg ]
+            | _ -> x
+          end
+        | _ | (exception Not_found) -> x
+      end
+    | _ -> x
+
+  let restore (x : Yojson.Safe.t) =
+    let mk_fields ok fields = ("ok", `Bool ok) :: List.filter (fun (k, _) -> k <> "ok") fields in
+    match x with
+    | `List [ `String "Ok"; `Assoc fields ] -> `Assoc (mk_fields true fields)
+    | `List [ `String "Error"; `String msg ] -> `Assoc (mk_fields false [ "error", `String msg ])
+    | _ -> x
+end

lib/slack.atd

@@ -118,3 +118,19 @@ type chat_unfurl_res = {
   ok: bool;
   ?error: string option;
 }
+
+type auth_test_res = {
+  url: string;
+  team: string;
+  user: string;
+  team_id: string;
+  user_id: string;
+}
+
+type ('ok, 'err) http_response <ocaml predef module="Base.Result" t="t"> = [
+  | Ok of 'ok
+  | Error of 'err
+] <ocaml repr="classic">
+
+type 'ok slack_response = ('ok, string) http_response
+  <json adapter.ocaml="Atd_adapters.Slack_response_adapter">

lib/state.atd

@@ -11,5 +11,6 @@ type pipeline_statuses = branch_statuses map_as_object
 
 (* The serializable runtime state of the bot *)
 type state = {
-  pipeline_statuses <ocaml mutable>: pipeline_statuses
+  pipeline_statuses <ocaml mutable>: pipeline_statuses;
+  ?bot_user_id <ocaml mutable>: string nullable;
 }

lib/state.ml

@@ -2,7 +2,7 @@ open Base
 open Common
 open Devkit
 
-let empty : State_t.state = { pipeline_statuses = StringMap.empty }
+let empty : State_t.state = { pipeline_statuses = StringMap.empty; bot_user_id = None }
 
 let refresh_pipeline_status (state : State_t.state) ~pipeline ~(branches : Github_t.branch list) ~status =
   let update_pipeline_status branch_statuses =