Introduce support for multiple GitLab instances.

Distinguish the bot's name on GitHub and on each GitLab instance. Introduce ppx_expect test for new function. Co-authored-by: Erik Martin-Dorel <[email protected]>
coq · May 22, 2023 · 7ae27aa · 7ae27aa
1 parent 8101013
commit 7ae27aa
Show file tree

Hide file tree

Showing 26 changed files with 494 additions and 266 deletions.
diff --git a/README.md b/README.md
@@ -253,14 +253,21 @@ Once you finish the installation, follow these steps:
   By default, **@coqbot** considers that both GitHub and GitLab repositories
   share the same URL except for the "lab" replacing the "hub" part. If
   that is not the case, assuming you created a GitLab repository whose
-  URL is <https://gitlab.com/owner/repo/>, add a file `coqbot.toml` at
+  URL is <https://mygitlab.example.com/owner/repo/>, add a file `coqbot.toml` at
   the root of your GitHub repository and in its default branch (most often
   named `master`), containing:
   ```
   [mapping]
   gitlab = "owner/repo"
+  gitlab_domain = "mygitlab.example.com"
   ```
-  If you use other instance of **@coqbot**, this repository-specific
+  If omitted, the `gitlab_domain` value defaults to `"gitlab.com"`.
+  Note that the value of `gitlab_domain` must be a supported GitLab
+  instance, i.e., it needs to be defined in the bot's own configuration
+  file (check [coqbot-config.toml](coqbot-config.toml) for the coqbot
+  instance configuration).
+
+  If you use another instance of **@coqbot**, this repository-specific
   configuration file becomes `BOT_NAME.toml` where `BOT_NAME` is the name
   of the bot.
 
@@ -345,11 +352,14 @@ to [Heroku](https://www.heroku.com/). Simply follow the official
 The bot will need to read a few environment variables so make sure
 these are configured in your Heroku app:
 
-- `GITLAB_ACCESS_TOKEN`
-- `GITHUB_ACCESS_TOKEN`
-- `GITHUB_WEBHOOK_SECRET`
+- `GITHUB_ACCESS_TOKEN` (can also be defined in the configuration file as `github.api_token`)
+- `GITLAB_ACCESS_TOKEN` (can also be defined for each GitLab instance through the configuration file as `api_token` or through an environment variable whose name is defined in the configuration file as `api_token_env_var`)
+- `GITHUB_WEBHOOK_SECRET` (can also be defined in the configuration file as `github.webhook_secret`)
+- `GITLAB_WEBHOOK_SECRET` (can also be defined in the configuration file as `gitlab.webhook_secret`, will default to `GITHUB_WEBHOOK_SECRET` if not defined)
+- `DAILY_SCHEDULE_SECRET` (can also be defined in the configuration file as `github.daily_schedule_secret`, will default to `GITHUB_WEBHOOK_SECRET` if not defined)
+- `GITHUB_APP_ID` (can also be defined in the configuration file as `github.app_id`)
 - `GITHUB_PRIVATE_KEY` (a private key of your GitHub app)
-- `GITHUB_APP_ID` (your GitHub App ID)
+- `PORT` (can also be defined in the configuration file as `server.port`)
 
 Then, you must configure the bot with a configuration file. Here is an example
 to adapt to your needs [`example-config.toml`](example-config.toml)).

diff --git a/bot-components/Bot_info.ml b/bot-components/Bot_info.ml
@@ -1,8 +1,10 @@
+open Base
+
 type t =
-  { gitlab_token: string
+  { gitlab_instances: (string, string * string) Hashtbl.t
   ; github_pat: string
   ; github_install_token: string option
-  ; name: string
+  ; github_name: string
   ; email: string
   ; domain: string
   ; app_id: int }
@@ -13,3 +15,15 @@ let github_token bot_info =
       t
   | None ->
       bot_info.github_pat
+
+let gitlab_name_and_token bot_info gitlab_domain =
+  match Hashtbl.find bot_info.gitlab_instances gitlab_domain with
+  | Some t ->
+      Ok t
+  | None ->
+      Error
+        ( "I don't know about GitLab domain " ^ gitlab_domain
+        ^ " (not in my configuration file)" )
+
+let gitlab_token bot_info gitlab_domain =
+  gitlab_name_and_token bot_info gitlab_domain |> Result.map ~f:snd
diff --git a/bot-components/Bot_info.mli b/bot-components/Bot_info.mli
@@ -1,10 +1,14 @@
 type t =
-  { gitlab_token: string
+  { gitlab_instances: (string, string * string) Base.Hashtbl.t
   ; github_pat: string
   ; github_install_token: string option
-  ; name: string
+  ; github_name: string
   ; email: string
   ; domain: string
   ; app_id: int }
 
 val github_token : t -> string
+
+val gitlab_token : t -> string -> (string, string) Result.t
+
+val gitlab_name_and_token : t -> string -> (string * string, string) Result.t
diff --git a/bot-components/GitHub_app.ml b/bot-components/GitHub_app.ml
@@ -39,13 +39,13 @@ let make_jwt ~key ~app_id =
 
 let get ~bot_info ~token ~url =
   Stdio.print_endline ("Making get request to " ^ url) ;
-  let headers = headers ~bot_info (github_headers token) in
+  let headers = headers (github_headers token) bot_info.Bot_info.github_name in
   Client.get ~headers (Uri.of_string url)
   >>= fun (_response, body) -> Cohttp_lwt.Body.to_string body
 
 let post ~bot_info ~body ~token ~url =
   Stdio.print_endline ("Making post request to " ^ url) ;
-  let headers = headers ~bot_info (github_headers token) in
+  let headers = headers (github_headers token) bot_info.Bot_info.github_name in
   let body =
     (match body with None -> "{}" | Some json -> Yojson.to_string json)
     |> Cohttp_lwt.Body.of_string

diff --git a/bot-components/GitHub_mutations.ml b/bot-components/GitHub_mutations.ml
@@ -4,7 +4,7 @@ open Cohttp_lwt_unix
 open Lwt
 open Utils
 
-let send_graphql_query = GraphQL_query.send_graphql_query ~api:`GitHub
+let send_graphql_query = GraphQL_query.send_graphql_query ~api:GitHub
 
 let mv_card_to_column ~bot_info ({card_id; column_id} : mv_card_to_column_input)
     =
@@ -213,7 +213,7 @@ let remove_labels ~bot_info ~labels ~issue =
 (* TODO: use GraphQL API *)
 
 let update_milestone ~bot_info new_milestone (issue : issue) =
-  let headers = headers (github_header bot_info) ~bot_info in
+  let headers = headers (github_header bot_info) bot_info.github_name in
   let uri =
     f "https://api.github.com/repos/%s/%s/issues/%d" issue.owner issue.repo
       issue.number
@@ -245,7 +245,7 @@ let send_status_check ~bot_info ~repo_full_name ~commit ~state ~url ~context
     "https://api.github.com/repos/" ^ repo_full_name ^ "/statuses/" ^ commit
     |> Uri.of_string
   in
-  send_request ~body ~uri (github_header bot_info) ~bot_info
+  send_request ~body ~uri (github_header bot_info) bot_info.github_name
 
 let add_pr_to_column ~bot_info ~pr_id ~column_id =
   let body =
@@ -265,4 +265,4 @@ let add_pr_to_column ~bot_info ~pr_id ~column_id =
   in
   send_request ~body ~uri
     (project_api_preview_header @ github_header bot_info)
-    ~bot_info
+    bot_info.github_name
diff --git a/bot-components/GitHub_queries.ml b/bot-components/GitHub_queries.ml
@@ -4,15 +4,16 @@ open GitHub_types
 open Lwt
 open Utils
 
-let send_graphql_query = GraphQL_query.send_graphql_query ~api:`GitHub
+let send_graphql_query = GraphQL_query.send_graphql_query ~api:GitHub
 
 let extract_backport_info ~(bot_info : Bot_info.t) description :
     full_backport_info option =
   let project_column_regexp =
     "https://github.com/[^/]*/[^/]*/projects/[0-9]+#column-\\([0-9]+\\)"
   in
   let regexp =
-    bot_info.name ^ ": backport to \\([^ ]*\\) (request inclusion column: "
+    bot_info.github_name
+    ^ ": backport to \\([^ ]*\\) (request inclusion column: "
     ^ project_column_regexp ^ "; backported column: " ^ project_column_regexp
     ^ "; move rejected PRs to: "
     ^ "https://github.com/[^/]*/[^/]*/milestone/\\([0-9]+\\)" ^ ")"
@@ -29,7 +30,7 @@ let extract_backport_info ~(bot_info : Bot_info.t) description :
           [{backport_to; request_inclusion_column; backported_column}]
       ; rejected_milestone }
   else
-    let begin_regexp = bot_info.name ^ ": \\(.*\\)$" in
+    let begin_regexp = bot_info.github_name ^ ": \\(.*\\)$" in
     let backport_info_unit =
       "backport to \\([^ ]*\\) (request inclusion column: "
       ^ project_column_regexp ^ "; backported column: " ^ project_column_regexp

diff --git a/bot-components/GitLab_mutations.ml b/bot-components/GitLab_mutations.ml
@@ -2,38 +2,48 @@ open Base
 open Bot_info
 open Utils
 
-let generic_retry ~bot_info ~url_part =
+let generic_retry ~bot_info ~gitlab_domain ~url_part =
   let uri =
-    "https://gitlab.com/api/v4/" ^ url_part ^ "/retry" |> Uri.of_string
+    f "https://%s/api/v4/%s/retry" gitlab_domain url_part |> Uri.of_string
   in
-  let gitlab_header = [("Private-Token", bot_info.gitlab_token)] in
-  Utils.send_request ~body:Cohttp_lwt.Body.empty ~uri gitlab_header ~bot_info
+  match gitlab_name_and_token bot_info gitlab_domain with
+  | Error err ->
+      Lwt_io.printlf "Error when retrying job %s: %s." url_part err
+  | Ok (name, token) ->
+      let gitlab_header = [("Private-Token", token)] in
+      Utils.send_request ~body:Cohttp_lwt.Body.empty ~uri gitlab_header name
 
-let retry_job ~bot_info ~project_id ~build_id =
-  generic_retry ~bot_info
+let retry_job ~bot_info ~gitlab_domain ~project_id ~build_id =
+  generic_retry ~bot_info ~gitlab_domain
     ~url_part:
       ( "projects/" ^ Int.to_string project_id ^ "/jobs/"
       ^ Int.to_string build_id )
 
-let play_job ~bot_info ~project_id ~build_id ?(key_value_pairs = []) () =
+let play_job ~bot_info ~gitlab_domain ~project_id ~build_id
+    ?(key_value_pairs = []) () =
   let uri =
     Uri.of_string
-    @@ Printf.sprintf "https://gitlab.com/api/v4/projects/%d/jobs/%d/play"
+    @@ Printf.sprintf "https://%s/api/v4/projects/%d/jobs/%d/play" gitlab_domain
          project_id build_id
   in
-  let gitlab_header =
-    [ ("Private-Token", bot_info.gitlab_token)
-    ; ("Content-Type", "application/json") ]
-  in
-  let body =
-    match key_value_pairs with
-    | [] ->
-        Cohttp_lwt.Body.empty
-    | _ ->
-        key_value_pairs
-        |> List.map ~f:(fun (k, v) -> f {|{ "key": "%s", "value": "%s" }|} k v)
-        |> String.concat ~sep:","
-        |> f {|{ "job_variables_attributes": [%s] }|}
-        |> Cohttp_lwt.Body.of_string
-  in
-  Utils.send_request ~body ~uri gitlab_header ~bot_info
+  match gitlab_name_and_token bot_info gitlab_domain with
+  | Error err ->
+      Lwt_io.printlf "Error when playing job %d of project %d: %s." build_id
+        project_id err
+  | Ok (name, token) ->
+      let gitlab_header =
+        [("Private-Token", token); ("Content-Type", "application/json")]
+      in
+      let body =
+        match key_value_pairs with
+        | [] ->
+            Cohttp_lwt.Body.empty
+        | _ ->
+            key_value_pairs
+            |> List.map ~f:(fun (k, v) ->
+                   f {|{ "key": "%s", "value": "%s" }|} k v )
+            |> String.concat ~sep:","
+            |> f {|{ "job_variables_attributes": [%s] }|}
+            |> Cohttp_lwt.Body.of_string
+      in
+      Utils.send_request ~body ~uri gitlab_header name
diff --git a/bot-components/GitLab_mutations.mli b/bot-components/GitLab_mutations.mli
@@ -1,10 +1,16 @@
 val retry_job :
-  bot_info:Bot_info.t -> project_id:int -> build_id:int -> unit Lwt.t
+     bot_info:Bot_info.t
+  -> gitlab_domain:string
+  -> project_id:int
+  -> build_id:int
+  -> unit Lwt.t
 
-val generic_retry : bot_info:Bot_info.t -> url_part:string -> unit Lwt.t
+val generic_retry :
+  bot_info:Bot_info.t -> gitlab_domain:string -> url_part:string -> unit Lwt.t
 
 val play_job :
      bot_info:Bot_info.t
+  -> gitlab_domain:string
   -> project_id:int
   -> build_id:int
   -> ?key_value_pairs:(string * string) list

diff --git a/bot-components/GitLab_queries.ml b/bot-components/GitLab_queries.ml
@@ -1,30 +1,37 @@
 open Base
 open Cohttp_lwt_unix
-open Lwt
 open Bot_info
 open Utils
 
-let send_graphql_query = GraphQL_query.send_graphql_query ~api:`GitLab
+let send_graphql_query ~gitlab_domain =
+  GraphQL_query.send_graphql_query ~api:(GitLab gitlab_domain)
 
-let get_build_trace ~bot_info ~project_id ~build_id =
+let get_build_trace ~bot_info ~gitlab_domain ~project_id ~build_id =
   let uri =
-    "https://gitlab.com/api/v4/projects/" ^ Int.to_string project_id ^ "/jobs/"
-    ^ Int.to_string build_id ^ "/trace"
+    f "https://%s/api/v4/projects/%d/jobs/%d/trace" gitlab_domain project_id
+      build_id
     |> Uri.of_string
   in
-  let gitlab_header = [("Private-Token", bot_info.gitlab_token)] in
-  let headers = Utils.headers gitlab_header ~bot_info in
+  let open Lwt_result.Infix in
+  gitlab_name_and_token bot_info gitlab_domain
+  |> Lwt.return
+  >>= fun (name, token) ->
+  let gitlab_header = [("Private-Token", token)] in
+  let headers = Utils.headers gitlab_header name in
+  let open Lwt.Infix in
   Client.get ~headers uri
-  >>= fun (_response, body) -> Cohttp_lwt.Body.to_string body
+  >>= fun (_response, body) ->
+  Cohttp_lwt.Body.to_string body |> Lwt.map Result.return
 
-let get_retry_nb ~bot_info ~full_name ~build_id ~build_name =
+let get_retry_nb ~bot_info ~gitlab_domain ~full_name ~build_id ~build_name =
   let open GitLab_GraphQL.GetRetriedJobs in
+  let open Lwt.Infix in
   makeVariables ~fullPath:full_name
     ~jobId:
       (build_id |> f {|"gid://gitlab/Ci::Build/%d"|} |> Yojson.Basic.from_string)
     ()
   |> serializeVariables |> variablesToJson
-  |> send_graphql_query ~bot_info ~query
+  |> send_graphql_query ~bot_info ~gitlab_domain ~query
        ~parse:(Fn.compose parse unsafe_fromJson)
   >|= function
   | Ok {project= Some {job= Some {pipeline= Some {jobs= Some {count= 0}}}}} ->

diff --git a/bot-components/GitLab_queries.mli b/bot-components/GitLab_queries.mli
@@ -1,8 +1,13 @@
 val get_build_trace :
-  bot_info:Bot_info.t -> project_id:int -> build_id:int -> string Lwt.t
+     bot_info:Bot_info.t
+  -> gitlab_domain:string
+  -> project_id:int
+  -> build_id:int
+  -> (string, string) Lwt_result.t
 
 val get_retry_nb :
      bot_info:Bot_info.t
+  -> gitlab_domain:string
   -> full_name:string
   -> build_id:int
   -> build_name:string

diff --git a/bot-components/GitLab_subscriptions.ml b/bot-components/GitLab_subscriptions.ml
@@ -32,7 +32,9 @@ let job_info_of_json json =
   let project_id = json |> member "project_id" |> to_int in
   let base_commit, head_commit = json |> extract_commit in
   let branch = json |> member "ref" |> to_string in
-  let repo_url = json |> member "repository" |> member "url" |> to_string in
+  let http_repo_url =
+    json |> member "repository" |> member "homepage" |> to_string
+  in
   let stage = json |> member "build_stage" |> to_string in
   let failure_reason =
     json |> member "build_failure_reason" |> to_string |> Option.some
@@ -44,7 +46,8 @@ let job_info_of_json json =
   ; stage
   ; failure_reason
   ; allow_fail
-  ; common_info= {base_commit; head_commit; branch; repo_url; project_id} }
+  ; common_info= {base_commit; head_commit; branch; http_repo_url; project_id}
+  }
 
 (* For use to decode builds inside a pipeline webhook *)
 let build_info_of_json json =
@@ -70,8 +73,7 @@ let pipeline_info_of_json json =
   let base_commit, head_commit = json |> extract_commit in
   let branch = pipeline_json |> member "ref" |> to_string in
   let project = json |> member "project" in
-  let repo_url = project |> member "web_url" |> to_string in
-  let project_path = project |> member "path_with_namespace" |> to_string in
+  let http_repo_url = project |> member "web_url" |> to_string in
   let project_id = project |> member "id" |> to_int in
   let variables =
     pipeline_json |> member "variables" |> to_list
@@ -88,8 +90,7 @@ let pipeline_info_of_json json =
   in
   { state
   ; pipeline_id
-  ; project_path
-  ; common_info= {head_commit; base_commit; branch; repo_url; project_id}
+  ; common_info= {head_commit; base_commit; branch; http_repo_url; project_id}
   ; variables
   ; stages
   ; builds }

diff --git a/bot-components/GitLab_types.mli b/bot-components/GitLab_types.mli
@@ -2,7 +2,7 @@ type ci_common_info =
   { head_commit: string
   ; base_commit: string option
   ; branch: string
-  ; repo_url: string
+  ; http_repo_url: string
   ; project_id: int }
 
 type 'a job_info =
@@ -17,7 +17,6 @@ type 'a job_info =
 type pipeline_info =
   { state: string
   ; pipeline_id: int
-  ; project_path: string
   ; common_info: ci_common_info
   ; variables: (string * string) list
   ; stages: string list