rename/move helper functions out of github.ml, action.ml, and request_handler.ml

all rule checking logic moved to rule.ml
decode_string_pad moved to common.ml
mock.ml contents moved to common.ml
process_github_notification moved to request_handler.ml

Author: yasunariw

lib/action.ml

@@ -16,3 +16,14 @@ module Tristate : Atdgen_runtime.Json_adapter.S = struct
     | `String "false" -> `Bool false
     | x -> x
 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)

lib/common.ml

@@ -4,20 +4,20 @@ type label_rule <ocaml from="Rule"> = abstract
 
 (* This type of rule is used for CI build notifications. *)
 type status_rules = {
-  ?allowed_pipelines: string list option; (* keep only status events with a title matching this list *)
+  ?allowed_pipelines : string list option; (* keep only status events with a title matching this list *)
   rules: status_state;
 }
 
 (* This type of rule is used for CI build notifications. *)
 type prefix_rules = {
-  ?default_channel: string nullable; (* if none of the rules is matching *)
+  ?default_channel : string nullable; (* if none of the rules is matching *)
   rules: prefix_rule list;
 }
 
 (* This type of rule is used for events that must be routed based on the
   files they are related to. *)
 type label_rules = {
-  ?default_channel: string nullable; (* if none of the rules is matching *)
+  ?default_channel : string nullable; (* if none of the rules is matching *)
   rules: label_rule list;
 }
 
@@ -41,6 +41,6 @@ type webhook = {
    shouldn't be checked into version control.  *)
 type secrets = {
   slack_hooks : webhook list;
-  ?gh_token: string option; (* must not be specified for public repositories *)
-  ?gh_webhook_secret: string option; (* if not specified - signatures will not be checked *)
+  ?gh_token : string option; (* must not be specified for public repositories *)
+  ?gh_webhook_secret : string option; (* if not specified - signatures will not be checked *)
 }

lib/config.atd

@@ -3,6 +3,10 @@ open Devkit
 open Printf
 open Github_j
 
+exception Remote_config_error of string
+
+let remote_config_error fmt = ksprintf (fun s -> raise (Remote_config_error s)) fmt
+
 let log = Log.from "github"
 
 type t =
@@ -14,14 +18,9 @@ type t =
   | Issue_comment of issue_comment_notification
   | Commit_comment of commit_comment_notification
   | Status of status_notification
+  (* all other events *)
   | Event of string
 
-(* all other events *)
-
-exception Remote_config_error of string
-
-let remote_config_error fmt = ksprintf (fun s -> raise (Remote_config_error s)) fmt
-
 let to_repo = function
   | Push n -> Some n.repository
   | Pull_request n -> Some n.repository
@@ -33,6 +32,16 @@ let to_repo = function
   | Status n -> Some n.repository
   | Event _ -> None
 
+let commits_branch_of_ref ref =
+  match String.split ~on:'/' ref with
+  | "refs" :: "heads" :: l -> String.concat ~sep:"/" l
+  | _ -> ref
+
+let event_of_filename filename =
+  match String.split_on_chars filename ~on:[ '.' ] with
+  | [ kind; _name; ext ] when String.equal ext "json" -> Some kind
+  | _ -> None
+
 let api_url_of_repo (repo : repository) =
   Option.map ~f:(fun host ->
     match host with
@@ -74,23 +83,12 @@ let get_remote_config_json_url filename ?token req =
     end
 
 let config_of_content_api_response response =
-  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)
-  in
   try%lwt
     match response.encoding with
     | "base64" ->
       Lwt.return
       @@ Config_j.config_of_string
-      @@ decode_string_pad
+      @@ Common.decode_string_pad
       @@ String.concat
       @@ String.split_lines
       @@ response.content
@@ -99,11 +97,23 @@ let config_of_content_api_response response =
   | Base64.Invalid_char -> remote_config_error "unable to decode configuration file from base64"
   | Yojson.Json_error msg -> remote_config_error "unable to parse configuration file as valid JSON (%s)" msg
 
-let load_config_json url =
-  let headers = [ "Accept: application/vnd.github.v3+json" ] in
-  match%lwt Web.http_request_lwt ~headers `GET url with
-  | `Error e -> remote_config_error "error while querying github api %s: %s" url e
-  | `Ok s -> config_of_content_api_response @@ Github_j.content_api_response_of_string s
+let is_main_merge_message ~msg:message ~branch (cfg : Config.t) =
+  match cfg.main_branch_name with
+  | Some main_branch when String.equal branch main_branch ->
+    (*
+      handle "Merge <main branch> into <feature branch>" commits when they are merged into main branch
+      we should have already seen these commits on the feature branch but for some reason they are distinct:true
+    *)
+    let prefix = sprintf "Merge branch '%s' into " main_branch in
+    let prefix2 = sprintf "Merge remote-tracking branch 'origin/%s' into " main_branch in
+    let title = Common.first_line message in
+    String.is_prefix title ~prefix || String.is_prefix title ~prefix:prefix2
+  | Some main_branch ->
+    let expect = sprintf "Merge branch '%s' into %s" main_branch branch in
+    let expect2 = sprintf "Merge remote-tracking branch 'origin/%s' into %s" main_branch branch in
+    let title = Common.first_line message in
+    String.equal title expect || String.equal title expect2
+  | _ -> false
 
 let is_valid_signature ~secret headers_sig body =
   let request_hash =
@@ -113,33 +123,11 @@ let is_valid_signature ~secret headers_sig body =
   let (`Hex request_hash) = Hex.of_string request_hash in
   String.equal headers_sig (sprintf "sha1=%s" request_hash)
 
-(* Parse a payload. The type of the payload is detected from the headers. *)
-let parse_exn ~secret headers body =
-  begin
-    match secret with
-    | None -> ()
-    | Some secret ->
-    match List.Assoc.find headers "x-hub-signature" ~equal:String.equal with
-    | None -> Exn.fail "unable to find header x-hub-signature"
-    | Some req_sig -> if not @@ is_valid_signature ~secret req_sig body then failwith "request signature invalid"
-  end;
-  match List.Assoc.find_exn headers "x-github-event" ~equal:String.equal with
-  | exception exn -> Exn.fail ~exn "unable to read x-github-event"
-  | "push" -> Push (commit_pushed_notification_of_string body)
-  | "pull_request" -> Pull_request (pr_notification_of_string body)
-  | "pull_request_review" -> PR_review (pr_review_notification_of_string body)
-  | "pull_request_review_comment" -> PR_review_comment (pr_review_comment_notification_of_string body)
-  | "issues" -> Issue (issue_notification_of_string body)
-  | "issue_comment" -> Issue_comment (issue_comment_notification_of_string body)
-  | "status" -> Status (status_notification_of_string body)
-  | "commit_comment" -> Commit_comment (commit_comment_notification_of_string body)
-  | ("member" | "create" | "delete" | "release") as event -> Event event
-  | event -> failwith @@ sprintf "unsupported event : %s" event
-
-let get_commits_branch ref =
-  match String.split ~on:'/' ref with
-  | "refs" :: "heads" :: l -> String.concat ~sep:"/" l
-  | _ -> ref
+let load_config_json url =
+  let headers = [ "Accept: application/vnd.github.v3+json" ] in
+  match%lwt Web.http_request_lwt ~headers `GET url with
+  | `Error e -> remote_config_error "error while querying github api %s: %s" url e
+  | `Ok s -> config_of_content_api_response @@ Github_j.content_api_response_of_string s
 
 let query_api ?token ~url parse =
   let headers = Option.map token ~f:(fun t -> [ sprintf "Authorization: token %s" t ]) in
@@ -187,3 +175,26 @@ let generate_commit_from_commit_comment cfg n =
   let commit_url = String.sub ~pos:0 ~len:url_length url ^ "/" ^ sha in
   (* add sha hash to get the full api link *)
   generate_query_commit cfg ~url:commit_url ~sha
+
+(* Parse a payload. The type of the payload is detected from the headers. *)
+let parse_exn ~secret headers body =
+  begin
+    match secret with
+    | None -> ()
+    | Some secret ->
+    match List.Assoc.find headers "x-hub-signature" ~equal:String.equal with
+    | None -> Exn.fail "unable to find header x-hub-signature"
+    | Some req_sig -> if not @@ is_valid_signature ~secret req_sig body then failwith "request signature invalid"
+  end;
+  match List.Assoc.find_exn headers "x-github-event" ~equal:String.equal with
+  | exception exn -> Exn.fail ~exn "unable to read x-github-event"
+  | "push" -> Push (commit_pushed_notification_of_string body)
+  | "pull_request" -> Pull_request (pr_notification_of_string body)
+  | "pull_request_review" -> PR_review (pr_review_notification_of_string body)
+  | "pull_request_review_comment" -> PR_review_comment (pr_review_comment_notification_of_string body)
+  | "issues" -> Issue (issue_notification_of_string body)
+  | "issue_comment" -> Issue_comment (issue_comment_notification_of_string body)
+  | "status" -> Status (status_notification_of_string body)
+  | "commit_comment" -> Commit_comment (commit_comment_notification_of_string body)
+  | ("member" | "create" | "delete" | "release") as event -> Event event
+  | event -> failwith @@ sprintf "unsupported event : %s" event

lib/github.ml

@@ -0,0 +1,132 @@
+open Base
+open Rule_t
+open Github_t
+
+module Status = struct
+  let hide_cancelled (notification : status_notification) (cfg : Config.t) =
+    let find_cancelled status_state =
+      match status_state with
+      | Config.Cancelled r -> Some r
+      | _ -> None
+    in
+    let regexp_opt = List.find_map cfg.status_rules.status ~f:find_cancelled in
+    match regexp_opt with
+    | None -> false
+    | Some regexp ->
+      let { state; description; _ } = notification in
+      let r = Re.Str.regexp_case_fold regexp in
+      ( match description, state with
+      | Some s, Failure when Re.Str.string_match r s 0 -> true
+      | _ -> false
+      )
+
+  let hide_success (n : status_notification) (ctx : Context.t) =
+    match List.exists ctx.cfg.status_rules.status ~f:(Poly.equal Config.HideConsecutiveSuccess) with
+    | false -> false
+    | true ->
+    match n.state with
+    | Success ->
+      List.exists
+        ~f:(fun b ->
+          match State.get_branch_state b.name ctx.state with
+          | None | Some { last_build_state = Failure; _ } -> false
+          | Some { last_build_state = Success; _ } -> true)
+        n.branches
+    | _ -> false
+end
+
+module Prefix = struct
+  type prefix_match =
+    | Match of int
+    | NoMatch
+
+  let chan_of_prefix_rule (r : prefix_rule) = r.channel_name
+
+  let touching_prefix (rule : prefix_rule) name =
+    let match_lengths filename prefixes =
+      List.filter_map
+        ~f:(fun prefix -> if String.is_prefix filename ~prefix then Some (String.length prefix) else None)
+        prefixes
+    in
+    match match_lengths name rule.ignore with
+    | _ :: _ -> NoMatch
+    | [] ->
+    match rule.allow with
+    | [] -> Match 0
+    | _ ->
+    match List.max_elt (match_lengths name rule.allow) ~compare:Int.compare with
+    | Some x -> Match x
+    | None -> NoMatch
+
+  let longest_touching_prefix_rule rules name =
+    let get_m rule = touching_prefix rule name in
+    let reduce_to_longest_match longest_rule_match_pair current_rule =
+      let _, longest_match = longest_rule_match_pair in
+      let current_match = get_m current_rule in
+      let current_rule_match_pair = current_rule, current_match in
+      match longest_match with
+      | NoMatch -> current_rule_match_pair
+      | Match x ->
+      match current_match with
+      | NoMatch -> longest_rule_match_pair
+      | Match y -> if y > x then current_rule_match_pair else longest_rule_match_pair
+    in
+    match rules with
+    | [] -> None
+    | (x : prefix_rule) :: xs ->
+    match List.fold_left xs ~init:(x, get_m x) ~f:reduce_to_longest_match with
+    | _, NoMatch -> None
+    | r, Match _ -> Some r
+
+  let chan_of_file rules file = Option.map ~f:chan_of_prefix_rule @@ longest_touching_prefix_rule rules file
+
+  let unique_chans_of_files rules files =
+    List.dedup_and_sort ~compare:String.compare @@ List.filter_map files ~f:(chan_of_file rules)
+
+  let filter_push rules (commit : Github_t.commit) =
+    let files = List.concat [ commit.added; commit.removed; commit.modified ] in
+    List.map ~f:(fun chan -> chan, commit) @@ unique_chans_of_files rules files
+
+  let print_prefix_routing rules =
+    let show_match l = String.concat ~sep:" or " @@ List.map ~f:(fun s -> s ^ "*") l in
+    rules
+    |> List.iter ~f:(fun (rule : prefix_rule) ->
+         begin
+           match rule.allow, rule.ignore with
+           | [], [] -> Stdio.printf "  any"
+           | l, [] -> Stdio.printf "  %s" (show_match l)
+           | [], l -> Stdio.printf "  not %s" (show_match l)
+           | l, i -> Stdio.printf "  %s and not %s" (show_match l) (show_match i)
+         end;
+         Stdio.printf " -> #%s\n%!" rule.channel_name)
+end
+
+module Label = struct
+  let touching_label rule name =
+    let name_lc = String.lowercase name in
+    let label_lc = List.map rule.allow ~f:(fun l -> String.lowercase l) in
+    let ignore_lc = List.map rule.ignore ~f:(fun l -> String.lowercase l) in
+    (* convert both labels and config into lowe-case to make label matching case-insensitive *)
+    (List.is_empty label_lc || List.mem ~equal:String.equal label_lc name_lc)
+    && not (List.mem ~equal:String.equal ignore_lc name_lc)
+
+  let filter_label rules (label : Github_j.label) =
+    rules
+    |> List.filter_map ~f:(fun rule ->
+         match touching_label rule label.name with
+         | false -> None
+         | true -> Some rule.channel_name)
+
+  let print_label_routing rules =
+    let show_match l = String.concat ~sep:" or " l in
+    rules
+    |> List.iter ~f:(fun (rule : label_rule) ->
+         begin
+           match rule.allow, rule.ignore with
+           | [], [] -> Stdio.printf "  any"
+           | l, [] -> Stdio.printf "  %s" (show_match l)
+           | [], l -> Stdio.printf "  not %s" (show_match l)
+           | l, i -> Stdio.printf "  %s and not %s" (show_match l) (show_match i)
+         end;
+         Stdio.printf " -> #%s\n%!" rule.channel_name)
+end

lib/mock.ml

@@ -223,7 +223,7 @@ let git_short_sha_hash hash = String.sub ~pos:0 ~len:8 hash
 
 let generate_push_notification notification =
   let { sender; created; deleted; forced; compare; commits; repository; _ } = notification in
-  let commits_branch = Github.get_commits_branch notification.ref in
+  let commits_branch = Github.commits_branch_of_ref notification.ref in
   let tree_url = String.concat ~sep:"/" [ repository.url; "tree"; Uri.pct_encode commits_branch ] in
   let title =
     if deleted then

lib/rule.ml

@@ -1,6 +1,7 @@
 open Devkit
 open Base
 open Lib
+open Action
 module Arg = Caml.Arg
 open Cmdliner
 
@@ -10,9 +11,9 @@ let log = Log.from "monorobot"
 
 let cfg_action_after_refresh (cfg : Config.t) =
   log#info "using prefix routing:";
-  Action.print_prefix_routing cfg.prefix_rules.rules;
+  Rule.Prefix.print_prefix_routing cfg.prefix_rules.rules;
   log#info "using label routing:";
-  Action.print_label_routing cfg.label_rules.rules;
+  Rule.Label.print_label_routing cfg.label_rules.rules;
   log#info "signature checking %s" (if Option.is_some cfg.gh_webhook_secret then "enabled" else "disabled")
 
 let update_state_at_path state_path state event = State.save state_path @@ State.update_state state event
@@ -36,7 +37,8 @@ let check_common file print config secrets state_path =
     Context.make_thunk ~state_path ~cfg_path_or_remote_filename:config ~secrets_path:secrets ~cfg_action_after_refresh
       ()
   in
-  match Mock.kind file with
+  let filename = Caml.Filename.basename file in
+  match Github.event_of_filename filename with
   | None ->
     log#error "aborting because payload %s is not named properly, named should be KIND.NAME_OF_PAYLOAD.json" file;
     Lwt.return_unit