extract minimal interface for communicating w/ slack and GH

define local + remote implementations of each
more concise decode_string_pad implementation

Author: yasunariw

lib/api.ml

@@ -0,0 +1,13 @@
+open Base
+open Github_t
+open Slack_t
+
+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
+end
+
+module type Slack = sig
+  val send_notification : chan:string -> msg:webhook_notification -> url:string -> (unit, string) Result.t Lwt.t
+end

lib/api_local.ml

@@ -0,0 +1,62 @@
+open Base
+open Common
+open Devkit
+
+let cwd = Caml.Sys.getcwd ()
+
+let cache_dir = Caml.Filename.concat cwd "github-api-cache"
+
+module Github : Api.Github = struct
+  let log = Log.from "github"
+
+  let get_config ~(ctx : Context.t) ~repo:_ =
+    let url = Caml.Filename.concat cwd ctx.data.cfg_filename in
+    match%lwt get_local_file url with
+    | Error e ->
+      log#error "error while getting local file %s: %s" url e;
+      Lwt.return @@ fmt_error "failed to get config from file %s" url
+    | Ok res -> Lwt.return @@ Ok (Config_j.config_of_string res)
+
+  let get_api_commit ~ctx:_ ~repo:_ ~sha =
+    let url = Caml.Filename.concat cache_dir sha in
+    match%lwt get_local_file url with
+    | Error e ->
+      log#error "error while getting local file %s: %s" url e;
+      Lwt.return @@ fmt_error "failed to get api commit from file %s" url
+    | Ok res -> Lwt.return @@ Ok (Github_j.api_commit_of_string res)
+end
+
+module Slack : Api.Slack = struct
+  let send_notification ~chan ~msg ~url:_ =
+    let json =
+      msg |> Slack_j.string_of_webhook_notification |> Yojson.Basic.from_string |> Yojson.Basic.pretty_to_string
+    in
+    Stdio.printf "will notify #%s\n" chan;
+    Stdio.printf "%s\n" json;
+    Lwt.return @@ Ok ()
+end
+
+module Slack_simple : Api.Slack = struct
+  let log = Log.from "slack"
+
+  let send_notification ~chan ~msg ~url:_ =
+    log#info "will notify %s%s" chan
+      ( match msg.Slack_t.text with
+      | None -> ""
+      | Some s -> Printf.sprintf " with %S" s
+      );
+    Lwt.return @@ Ok ()
+end
+
+module Slack_json : Api.Slack = struct
+  let log = Log.from "slack"
+
+  let send_notification ~chan ~msg ~url:_ =
+    let json = Slack_j.string_of_webhook_notification msg in
+    log#info "will notify %s" chan;
+    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 ()
+end

lib/api_remote.ml

@@ -0,0 +1,64 @@
+open Base
+open Printf
+open Devkit
+open Common
+
+module Github : Api.Github = struct
+  let log = Log.from "github"
+
+  let commits_url ~(repo : Github_t.repository) ~sha =
+    String.substr_replace_first ~pattern:"{/sha}" ~with_:sha repo.commits_url
+
+  let contents_url ~(repo : Github_t.repository) ~path =
+    String.substr_replace_first ~pattern:"{+path}" ~with_:path repo.contents_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)
+
+  let get_config ~(ctx : Context.t) ~repo =
+    let url = contents_url ~repo ~path:ctx.data.cfg_filename in
+    let headers = build_headers ?token:ctx.secrets.gh_token () in
+    match%lwt http_get ~headers url with
+    | Error e ->
+      log#error "error while querying %s: %s" url e;
+      Lwt.return @@ fmt_error "failed to get config from file %s" url
+    | Ok res ->
+      let response = Github_j.content_api_response_of_string res in
+      ( match response.encoding with
+      | "base64" ->
+        begin
+          try
+            response.content |> String.split_lines |> String.concat |> decode_string_pad |> Config_j.config_of_string
+            |> fun res -> Lwt.return @@ Ok res
+          with Base64.Invalid_char as exn ->
+            log#error ~exn "failed to decode base64 in Github response";
+            Lwt.return @@ fmt_error "failed to get config from file %s" url
+        end
+      | encoding ->
+        log#error "unexpected encoding '%s' in Github response" encoding;
+        Lwt.return @@ fmt_error "failed to get config from file %s" url
+      )
+
+  let get_api_commit ~(ctx : Context.t) ~repo ~sha =
+    let url = commits_url ~repo ~sha in
+    let headers = build_headers ?token:ctx.secrets.gh_token () in
+    match%lwt http_get ~headers url with
+    | Ok res -> Lwt.return @@ Ok (Github_j.api_commit_of_string res)
+    | Error e ->
+      log#error "error while querying %s: %s" url e;
+      Lwt.return @@ fmt_error "failed to get api commit %s" sha
+end
+
+module Slack : Api.Slack = struct
+  let log = Log.from "slack"
+
+  let send_notification ~chan ~msg ~url =
+    let data = Slack_j.string_of_webhook_notification msg in
+    log#info "sending to %s : %s" chan data;
+    match%lwt http_post ~path:url ~data with
+    | Ok _ -> Lwt.return @@ Ok ()
+    | Error e ->
+      log#error "error while querying %s: %s" url e;
+      Lwt.return @@ fmt_error "failed to send Slack notification"
+end

lib/common.ml

@@ -1,4 +1,7 @@
 open Base
+open Devkit
+
+let fmt_error fmt = Printf.ksprintf (fun s -> Error s) fmt
 
 let first_line s =
   match String.split ~on:'\n' s with
@@ -18,12 +21,29 @@ module Tristate : Atdgen_runtime.Json_adapter.S = struct
 end
 
 let decode_string_pad s =
-  let rec strip_padding i =
-    if i < 0 then ""
-    else (
-      match s.[i] with
-      | '=' | '\n' | '\r' | '\t' | ' ' -> strip_padding (i - 1)
-      | _ -> String.sub s ~pos:0 ~len:(i + 1)
-    )
-  in
-  Base64.decode_string @@ strip_padding (String.length s - 1)
+  String.rstrip ~drop:(List.mem [ '='; ' '; '\n'; '\r'; '\t' ] ~equal:Char.equal) s |> Base64.decode_string
+
+let http_get ?headers path =
+  match%lwt Web.http_request_lwt ~ua:"monorobot" ~verbose:true ?headers `GET path with
+  | `Ok s -> Lwt.return @@ Ok s
+  | `Error e -> Lwt.return @@ Error e
+
+let http_post ~path ~data =
+  let body = `Raw ("application/json", data) in
+  match%lwt Web.http_request_lwt ~verbose:true ~body `POST path with
+  | `Ok res -> Lwt.return @@ Ok res
+  | `Error e -> Lwt.return @@ Error e
+
+let get_local_file path =
+  try%lwt
+    let%lwt data = Lwt_io.with_file ~mode:Lwt_io.input path (fun ic -> Lwt_io.read ic) in
+    Lwt.return @@ Ok data
+  with exn -> Lwt.return @@ Error (Exn.str exn)
+
+let write_to_local_file ~path ~data =
+  try%lwt
+    let%lwt () =
+      Lwt_io.with_file ~flags:[ O_CREAT; O_WRONLY; O_TRUNC ] ~mode:Lwt_io.output path (fun oc -> Lwt_io.write oc data)
+    in
+    Lwt.return @@ Ok ()
+  with exn -> Lwt.return @@ Error (Exn.str exn)

lib/github.atd

@@ -31,6 +31,7 @@ type repository = {
   full_name: string;
   html_url <ocaml name="url"> : string;
   commits_url: string;
+  contents_url: string;
 }
 
 type commit_pushed_notification = {