From da7f656d87dc21f50ca73c86a478dac5db1b9a36 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Fri, 4 Oct 2019 16:49:15 +0200 Subject: [PATCH 01/12] updating dependencies --- camelus.opam | 4 ---- 1 file changed, 4 deletions(-) diff --git a/camelus.opam b/camelus.opam index 752298f..a861d31 100644 --- a/camelus.opam +++ b/camelus.opam @@ -23,7 +23,3 @@ depends: [ "fpath" ] build: ["dune" "build" "-p" name] -pin-depends: [ - ["github.3.1.0" "git+https://github.com/AltGr/ocaml-github#21efde3"] - ["github-unix.3.1.0" "git+https://github.com/AltGr/ocaml-github#21efde3"] -] From 6f0a7756f808e3b6cb1e55c46d62e25ef54d6af3 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Fri, 4 Oct 2019 17:09:05 +0200 Subject: [PATCH 02/12] adding header, updating replay auto to check header for modifications --- camelus_lib.ml | 197 ++++++++++++++++++++++++++-------------------- camelus_main.ml | 2 +- camelus_replay.ml | 13 ++- 3 files changed, 122 insertions(+), 90 deletions(-) diff --git a/camelus_lib.ml b/camelus_lib.ml index 691ff9d..cdd7d87 100644 --- a/camelus_lib.ml +++ b/camelus_lib.ml @@ -50,6 +50,89 @@ type push_event = { push_ancestor: string; } +module Conf = struct + module C = struct + let internal = ".opam-ci" + + type t = { + port: int; + name: string; + token: Github.Token.t; + secret: Cstruct.t; + repo: repo; + roles: [ `Pr_checker | `Push_upgrader ] list; + base_branch: string; + dest_branch: string; + } + + let empty = { + port = 8122; + name = "opam-ci"; + token = Github.Token.of_string ""; + secret = Cstruct.of_string ""; + repo = { user="ocaml"; name="opam-repository"; auth=None }; + roles = [ `Pr_checker ]; + base_branch = "master"; + dest_branch = "2.0.0"; + } + + open OpamPp.Op + + let role_of_string = function + | "pr_checker" -> `Pr_checker + | "push_upgrader" -> `Push_upgrader + | _ -> failwith "Invalid role (accepted are pr_checker, push_upgrader)" + + let role_to_string = function + | `Pr_checker -> "pr_checker" + | `Push_upgrader -> "push_upgrader" + + let fields = [ + "port", OpamPp.ppacc (fun port t -> {t with port}) (fun t -> t.port) + OpamFormat.V.pos_int; + "name", OpamPp.ppacc (fun name t -> {t with name}) (fun t -> t.name) + OpamFormat.V.string; + "token", OpamPp.ppacc (fun token t -> {t with token}) (fun t -> t.token) + (OpamFormat.V.string -| + OpamPp.of_module "token" (module Github.Token)); + "secret", OpamPp.ppacc + (fun secret t -> {t with secret}) (fun t -> t.secret) + (OpamFormat.V.string -| + OpamPp.of_pair "secret" + Cstruct.((of_string ?allocator:None ?off:None ?len:None), to_string)); + "repo-user", OpamPp.ppacc + (fun user t -> {t with repo = {t.repo with user}}) + (fun t -> t.repo.user) + OpamFormat.V.string; + "repo-name", OpamPp.ppacc + (fun name t -> {t with repo = {t.repo with name}}) + (fun t -> t.repo.name) + OpamFormat.V.string; + "roles", OpamPp.ppacc + (fun roles t -> {t with roles }) + (fun t -> t.roles) + (OpamFormat.V.map_list ~depth:1 @@ + OpamFormat.V.ident -| + OpamPp.of_pair "role" (role_of_string, role_to_string)); + "base-branch", OpamPp.ppacc + (fun base_branch t -> {t with base_branch }) + (fun t -> t.base_branch) + OpamFormat.V.string; + "dest-branch", OpamPp.ppacc + (fun dest_branch t -> {t with dest_branch }) + (fun t -> t.dest_branch) + OpamFormat.V.string; + ] + + let pp = + OpamFormat.I.map_file @@ + OpamFormat.I.fields ~name:internal ~empty fields -| + OpamFormat.I.show_errors ~name:internal ~strict:true () + end + include C + include OpamFile.SyntaxFile(C) +end + module FdPool = struct let max_count = 50 @@ -1031,8 +1114,33 @@ module PrChecks = struct | l -> "\n\n---\n\n##### :sun_behind_small_cloud: " ^ (string_of_int @@ List.length l ) ^ " ignored non-opam files:\n\n" ^ OpamStd.Format.itemize ~bullet:"* " (fun s -> s) l - let run pr gitstore = + let msg_header ~conf pr = + let%lwt hello_msg = + begin match pr.pr_user with + | "AltGr" -> Lwt.return "As you wish, master!" + | "kit-ty-kate" -> Lwt.return "Good to see you Madam." + | "thomasblanc" -> Lwt.return "Tom, are you trying to break me again?" + | user -> + Lwt.catch + (fun () -> + Github.Monad.run (Github.Stream.to_list @@ Github.Search.issues ~qualifiers:[`Author user; `Repo (conf.Conf.repo.user ^"/"^conf.Conf.repo.name);] ~keywords:[] ()) >>= function + | [] -> raise Not_found + | { Github_t.repository_issue_search_total_count = l; _ }::_ -> + Lwt.return @@ + if l <= 1 + then "I believe this is your first contribution here. Please be nice, reviewers!" + else if l <= 50 + then Printf.sprintf "@%s has posted %d contributions." user l + else Printf.sprintf "A pull request by opam-seasoned @%s." user + ) + (fun _ -> Lwt.return @@ Printf.sprintf "Hey @thomasblanc there is a bug in your code see logs for %d" pr.number) + end in + Lwt.return @@ Printf.sprintf "Commit: %s\n\n%s\n\n" pr.head.sha hello_msg + + + let run ~conf pr gitstore = let%lwt () = RepoGit.fetch_pr pr gitstore in + let%lwt msghead = msg_header ~conf pr in let head = pr.head.sha in let%lwt ancestor = RepoGit.common_ancestor pr gitstore in let%lwt opam_files, other_files = changed_opam_files ancestor head gitstore in @@ -1050,11 +1158,11 @@ module PrChecks = struct installability_check ancestor head gitstore packages in Lwt.return (add_status stlint stinst, - msglint ^ "\n\n---\n" ^ msginst ^ misc_files_body) + msghead ^ msglint ^ "\n\n---\n" ^ msginst ^ misc_files_body) with e -> log "Installability check failed: %s%s" (Printexc.to_string e) (Printexc.get_backtrace ()); - Lwt.return (stlint, msglint ^ misc_files_body) + Lwt.return (stlint, msghead ^ msglint ^ misc_files_body) end @@ -1171,89 +1279,6 @@ module Github_comment = struct end -module Conf = struct - module C = struct - let internal = ".opam-ci" - - type t = { - port: int; - name: string; - token: Github.Token.t; - secret: Cstruct.t; - repo: repo; - roles: [ `Pr_checker | `Push_upgrader ] list; - base_branch: string; - dest_branch: string; - } - - let empty = { - port = 8122; - name = "opam-ci"; - token = Github.Token.of_string ""; - secret = Cstruct.of_string ""; - repo = { user="ocaml"; name="opam-repository"; auth=None }; - roles = [ `Pr_checker ]; - base_branch = "master"; - dest_branch = "2.0.0"; - } - - open OpamPp.Op - - let role_of_string = function - | "pr_checker" -> `Pr_checker - | "push_upgrader" -> `Push_upgrader - | _ -> failwith "Invalid role (accepted are pr_checker, push_upgrader)" - - let role_to_string = function - | `Pr_checker -> "pr_checker" - | `Push_upgrader -> "push_upgrader" - - let fields = [ - "port", OpamPp.ppacc (fun port t -> {t with port}) (fun t -> t.port) - OpamFormat.V.pos_int; - "name", OpamPp.ppacc (fun name t -> {t with name}) (fun t -> t.name) - OpamFormat.V.string; - "token", OpamPp.ppacc (fun token t -> {t with token}) (fun t -> t.token) - (OpamFormat.V.string -| - OpamPp.of_module "token" (module Github.Token)); - "secret", OpamPp.ppacc - (fun secret t -> {t with secret}) (fun t -> t.secret) - (OpamFormat.V.string -| - OpamPp.of_pair "secret" - Cstruct.((of_string ?allocator:None ?off:None ?len:None), to_string)); - "repo-user", OpamPp.ppacc - (fun user t -> {t with repo = {t.repo with user}}) - (fun t -> t.repo.user) - OpamFormat.V.string; - "repo-name", OpamPp.ppacc - (fun name t -> {t with repo = {t.repo with name}}) - (fun t -> t.repo.name) - OpamFormat.V.string; - "roles", OpamPp.ppacc - (fun roles t -> {t with roles }) - (fun t -> t.roles) - (OpamFormat.V.map_list ~depth:1 @@ - OpamFormat.V.ident -| - OpamPp.of_pair "role" (role_of_string, role_to_string)); - "base-branch", OpamPp.ppacc - (fun base_branch t -> {t with base_branch }) - (fun t -> t.base_branch) - OpamFormat.V.string; - "dest-branch", OpamPp.ppacc - (fun dest_branch t -> {t with dest_branch }) - (fun t -> t.dest_branch) - OpamFormat.V.string; - ] - - let pp = - OpamFormat.I.map_file @@ - OpamFormat.I.fields ~name:internal ~empty fields -| - OpamFormat.I.show_errors ~name:internal ~strict:true () - end - include C - include OpamFile.SyntaxFile(C) -end - module Webhook_handler = struct diff --git a/camelus_main.ml b/camelus_main.ml index 2391f13..7c81aa1 100644 --- a/camelus_main.ml +++ b/camelus_main.ml @@ -35,7 +35,7 @@ let handler conf gitstore = function pr.head.repo.user pr.head.repo.name pr.head.ref pr.head.sha pr.base.sha; try%lwt - let%lwt report = PrChecks.run pr gitstore in + let%lwt report = PrChecks.run ~conf pr gitstore in Github_comment.push_report ~name:conf.Conf.name ~token:conf.Conf.token diff --git a/camelus_replay.ml b/camelus_replay.ml index 5b7e718..e5455b1 100644 --- a/camelus_replay.ml +++ b/camelus_replay.ml @@ -62,8 +62,15 @@ let get_unchecked_pr () = Github.Stream.map (fun pr -> let stream = Github.Issue.comments ~token ~user:repo.user ~repo:repo.name ~num:pr.pull_number () in Github.Stream.find (fun { issue_comment_user = u; _ } -> u.user_login = conf.Conf.name) stream >>= - function | Some _ -> return [] - | None -> return [pr.pull_number] + function + | Some ({ issue_comment_body = b; _ },_) -> + begin try Scanf.sscanf b "Commit: %s\n" + (fun c -> + if String.equal c pr.pull_head.branch_sha + then return [] + else return [pr.pull_number]) + with _ -> return [pr.pull_number] end + | None -> return [pr.pull_number] ) open_prs in Github.Stream.to_list res_stream @@ -94,7 +101,7 @@ let replay_check nums = message = p.pull_title, p.pull_body; } in - let%lwt report = PrChecks.run pr gitstore in + let%lwt report = PrChecks.run ~conf pr gitstore in Github_comment.push_report ~name ~token ~report pr ) nums From e5847d6aa151f13cd8ef9be9636148bee86d7e76 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Tue, 8 Oct 2019 16:19:00 +0200 Subject: [PATCH 03/12] Adding log_tag to track pr number in logs --- camelus_lib.ml | 10 +++- camelus_main.ml | 43 ++++++++-------- camelus_replay.ml | 121 ++++++++++++++++++++++++---------------------- 3 files changed, 93 insertions(+), 81 deletions(-) diff --git a/camelus_lib.ml b/camelus_lib.ml index cdd7d87..df87c1d 100644 --- a/camelus_lib.ml +++ b/camelus_lib.ml @@ -18,7 +18,15 @@ open Lwt.Infix -let log fmt = OpamConsole.msg (fmt ^^ "\n%!") +let log_tag : string Lwt.key= Lwt.new_key () + +let log fmt = + let tag = + match Lwt.get log_tag with + | None -> "??" + | Some s -> s + in + OpamConsole.msg ("[%s] "^^ fmt ^^ "\n%!") tag let verbose = try Sys.getenv "CAMELUS_VERBOSE" <> "" diff --git a/camelus_main.ml b/camelus_main.ml index 7c81aa1..1da4cac 100644 --- a/camelus_main.ml +++ b/camelus_main.ml @@ -28,27 +28,28 @@ let () = Lwt.async_exception_hook := let handler conf gitstore = function | `Pr pr when List.mem `Pr_checker conf.Conf.roles -> - (log "=> PR #%d received \ - (onto %s/%s#%s from %s/%s#%s, commit %s over %s)" - pr.number - pr.base.repo.user pr.base.repo.name pr.base.ref - pr.head.repo.user pr.head.repo.name pr.head.ref - pr.head.sha pr.base.sha; - try%lwt - let%lwt report = PrChecks.run ~conf pr gitstore in - Github_comment.push_report - ~name:conf.Conf.name - ~token:conf.Conf.token - ~report - pr - with exn -> - log "Check failed: %s" (Printexc.to_string exn); - let%lwt _ = - Github_comment.push_status - ~name:conf.Conf.name ~token:conf.Conf.token pr - ~text:"Could not complete" `Failure - in - Lwt.return_unit) + Lwt.with_value log_tag (Some (string_of_int pr.number)) + (fun () -> log "=> PR #%d received \ + (onto %s/%s#%s from %s/%s#%s, commit %s over %s)" + pr.number + pr.base.repo.user pr.base.repo.name pr.base.ref + pr.head.repo.user pr.head.repo.name pr.head.ref + pr.head.sha pr.base.sha; + try%lwt + let%lwt report = PrChecks.run ~conf pr gitstore in + Github_comment.push_report + ~name:conf.Conf.name + ~token:conf.Conf.token + ~report + pr + with exn -> + log "Check failed: %s" (Printexc.to_string exn); + let%lwt _ = + Github_comment.push_status + ~name:conf.Conf.name ~token:conf.Conf.token pr + ~text:"Could not complete" `Failure + in + Lwt.return_unit) | `Push p when List.mem `Push_upgrader conf.Conf.roles -> (log "=> Push received (head %s onto %s)" p.push_head p.push_ancestor; diff --git a/camelus_replay.ml b/camelus_replay.ml index e5455b1..704d837 100644 --- a/camelus_replay.ml +++ b/camelus_replay.ml @@ -34,46 +34,47 @@ let replay_upgrade num = | _ -> failwith "No merge SHA found" in let merge_parent_sha = merge_sha^"^" in - log "Upgrading branch from %s to %s" - merge_parent_sha merge_sha; - let%lwt new_branch = - FormatUpgrade.run base_branch dest_branch - merge_parent_sha merge_sha gitstore - repo + log "Upgrading branch from %s to %s" + merge_parent_sha merge_sha; + let%lwt new_branch = + FormatUpgrade.run base_branch dest_branch + merge_parent_sha merge_sha gitstore + repo + in + match new_branch with + | None -> Lwt.return_unit + | Some (branch, msg) -> + let title, message = + match OpamStd.String.cut_at msg '\n' with + | Some (t, m) -> t, Some (String.trim m) + | None -> "Merge changes from 1.2 format repo", None in - match new_branch with - | None -> Lwt.return_unit - | Some (branch, msg) -> - let title, message = - match OpamStd.String.cut_at msg '\n' with - | Some (t, m) -> t, Some (String.trim m) - | None -> "Merge changes from 1.2 format repo", None - in - Github_comment.pull_request - ~name ~token repo - branch dest_branch - ?message title + Github_comment.pull_request + ~name ~token repo + branch dest_branch + ?message title let get_unchecked_pr () = let open Github.Monad in - run @@ - let open_prs = Github.Pull.for_repo ~token ~state:`Open ~user:repo.user ~repo:repo.name () in - let res_stream = - Github.Stream.map (fun pr -> - let stream = Github.Issue.comments ~token ~user:repo.user ~repo:repo.name ~num:pr.pull_number () in - Github.Stream.find (fun { issue_comment_user = u; _ } -> u.user_login = conf.Conf.name) stream >>= - function - | Some ({ issue_comment_body = b; _ },_) -> - begin try Scanf.sscanf b "Commit: %s\n" - (fun c -> - if String.equal c pr.pull_head.branch_sha - then return [] - else return [pr.pull_number]) - with _ -> return [pr.pull_number] end - | None -> return [pr.pull_number] - ) open_prs - in - Github.Stream.to_list res_stream + GH.run (fun () -> + let open_prs = Github.Pull.for_repo ~token ~state:`Open ~user:repo.user ~repo:repo.name () in + let res_stream = + Github.Stream.map (fun pr -> + let stream = Github.Issue.comments ~token ~user:repo.user ~repo:repo.name ~num:pr.pull_number () in + Github.Stream.find (fun { issue_comment_user = u; _ } -> u.user_login = conf.Conf.name) stream >>= + function + | Some ({ issue_comment_body = b; _ },_) -> + begin try Scanf.sscanf b "Commit: %s\n" + (fun c -> + if String.equal c pr.pull_head.branch_sha + then return [] + else return [pr.pull_number]) + with _ -> return [pr.pull_number] end + | None -> return [pr.pull_number] + ) open_prs + in + Github.Stream.to_list res_stream + ) let replay_check nums = let%lwt gitstore = match%lwt RepoGit.get repo with @@ -81,28 +82,30 @@ let replay_check nums = | Error e -> Lwt.fail (Failure "Repository loading failed") in Lwt_list.iter_p (fun num -> - let%lwt pr = get_pr num >|= fun p -> - let get_repo b = { - repo = - (match b.branch_repo with - | None -> repo - | Some gr -> { - user = gr.repository_owner.user_login; - name = gr.repository_name; - auth = None; - }); - ref = b.branch_ref; - sha = b.branch_sha; - } in { - number = num; - base = get_repo p.pull_base; - head = get_repo p.pull_head; - pr_user = p.pull_user.user_login; - message = p.pull_title, p.pull_body; - } - in - let%lwt report = PrChecks.run ~conf pr gitstore in - Github_comment.push_report ~name ~token ~report pr ) + Lwt.with_value log_tag (Some (string_of_int num)) (fun () -> + let%lwt pr = get_pr num >|= fun p -> + let get_repo b = { + repo = + (match b.branch_repo with + | None -> repo + | Some gr -> { + user = gr.repository_owner.user_login; + name = gr.repository_name; + auth = None; + }); + ref = b.branch_ref; + sha = b.branch_sha; + } in { + number = num; + base = get_repo p.pull_base; + head = get_repo p.pull_head; + pr_user = p.pull_user.user_login; + message = p.pull_title, p.pull_body; + } + in + let%lwt report = PrChecks.run ~conf pr gitstore in + Github_comment.push_report ~name ~token ~report pr ) + ) nums let () = @@ -112,7 +115,7 @@ let () = Lwt_main.run (replay_upgrade num) | "check" -> let num = int_of_string Sys.argv.(2) in - Lwt_main.run (replay_check [num]) + Lwt_main.run (Lwt.with_value log_tag (Some Sys.argv.(2)) (fun () ->replay_check [num])) | "check-bunch" -> begin match Array.to_list Sys.argv with From 473143fc2b8e36df7178af529ba4c4b2c498ae24 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Tue, 8 Oct 2019 16:19:33 +0200 Subject: [PATCH 04/12] Adding propper Github mutex --- camelus_lib.ml | 52 +++++++++++++++++++++++------------------------ camelus_replay.ml | 8 ++++---- 2 files changed, 30 insertions(+), 30 deletions(-) diff --git a/camelus_lib.ml b/camelus_lib.ml index df87c1d..b31b378 100644 --- a/camelus_lib.ml +++ b/camelus_lib.ml @@ -162,6 +162,14 @@ module FdPool = struct end +module GH = struct + + let mutex = Lwt_mutex.create () + + let run f = Lwt_mutex.with_lock mutex (fun () -> Github.Monad.run @@ f ()) + +end + module RepoGit = struct module M = OpamStd.String.Map @@ -845,7 +853,7 @@ module PrChecks = struct OpamStd.String.ends_with ~suffix:"/opam" s -> true | _ -> false) - files + files in List.map (function (s, Some c) -> (OpamFilename.of_string s, c) | (_,None) -> assert false) opamfiles, List.map fst others @@ -1131,15 +1139,15 @@ module PrChecks = struct | user -> Lwt.catch (fun () -> - Github.Monad.run (Github.Stream.to_list @@ Github.Search.issues ~qualifiers:[`Author user; `Repo (conf.Conf.repo.user ^"/"^conf.Conf.repo.name);] ~keywords:[] ()) >>= function + GH.run (fun () -> Github.Stream.to_list @@ Github.Search.issues ~qualifiers:[`Author user; `Repo (conf.Conf.repo.user ^"/"^conf.Conf.repo.name);] ~keywords:[] ()) >>= function | [] -> raise Not_found | { Github_t.repository_issue_search_total_count = l; _ }::_ -> - Lwt.return @@ - if l <= 1 - then "I believe this is your first contribution here. Please be nice, reviewers!" - else if l <= 50 - then Printf.sprintf "@%s has posted %d contributions." user l - else Printf.sprintf "A pull request by opam-seasoned @%s." user + Lwt.return @@ + if l <= 1 + then "I believe this is your first contribution here. Please be nice, reviewers!" + else if l <= 50 + then Printf.sprintf "@%s has posted %d contributions." user l + else Printf.sprintf "A pull request by opam-seasoned @%s." user ) (fun _ -> Lwt.return @@ Printf.sprintf "Hey @thomasblanc there is a bug in your code see logs for %d" pr.number) end in @@ -1181,14 +1189,6 @@ module Github_comment = struct let github_max_descr_length = 140 - let github_mutex = Lwt_mutex.create () - let run cmd = - Lwt.bind (Lwt_mutex.lock github_mutex) - (fun () -> - Lwt.finalize (fun () -> run cmd) - (fun () -> Lwt_mutex.unlock github_mutex; Lwt.return_unit) - ) - let make_status ~name ~token pr ?text status = let status = { new_status_state = status; @@ -1201,7 +1201,7 @@ module Github_comment = struct ~status ~sha:pr.head.sha () let push_status ~name ~token pr ?text status = - run (make_status ~name ~token pr ?text status) + GH.run (fun () -> make_status ~name ~token pr ?text status) let push_report ~name ~token ~report:(status,body) pr = let user = pr.base.repo.user in @@ -1241,11 +1241,11 @@ module Github_comment = struct in make_status ~name ~token pr ~text state in - run ( - comment () >>= fun _ -> - push_status () >>= fun _ -> - return (log "Comment posted back to PR #%d" pr.number); - ) + GH.run (fun () -> + comment () >>= fun _ -> + push_status () >>= fun _ -> + return (log "Comment posted back to PR #%d" pr.number); + ) let pull_request ~name ~token repo branch target_branch ?message title = log "Pull-requesting..."; @@ -1280,10 +1280,10 @@ module Github_comment = struct Github.Pull.update ~token ~user:repo.user ~repo:repo.name ~num:pr.pull_number ~update_pull () in - run ( - pr () >>= fun resp -> - return (log "Filed pull-request #%d" resp#value.pull_number) - ) + GH.run (fun () -> + pr () >>= fun resp -> + return (log "Filed pull-request #%d" resp#value.pull_number) + ) end diff --git a/camelus_replay.ml b/camelus_replay.ml index 704d837..d61584c 100644 --- a/camelus_replay.ml +++ b/camelus_replay.ml @@ -15,10 +15,10 @@ let base_branch = "master" let dest_branch = "2.0.0" let get_pr num = - Github.Monad.run @@ - let open Github.Monad in - Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= - Github.Response.value + GH.run (fun () -> + let open Github.Monad in + Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= + Github.Response.value) open Lwt.Infix open Github_t From b1960ee74813a75cc241e3d67b7ea52cef29b360 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Fri, 11 Oct 2019 17:10:57 +0200 Subject: [PATCH 05/12] Commenting outdated 1.2 upgrade code, implementing GH calls in a separate thread --- camelus_lib.ml | 205 +++++++++++++++++++++++++++++++--------------- camelus_main.ml | 62 +++++++------- camelus_replay.ml | 70 ++++++++-------- 3 files changed, 206 insertions(+), 131 deletions(-) diff --git a/camelus_lib.ml b/camelus_lib.ml index b31b378..38f6d61 100644 --- a/camelus_lib.ml +++ b/camelus_lib.ml @@ -168,6 +168,96 @@ module GH = struct let run f = Lwt_mutex.with_lock mutex (fun () -> Github.Monad.run @@ f ()) + type _ req = + | Count_previous_posts : pull_request -> int req + | Comment : pull_request * string -> unit req + | Status : (pull_request * Github_t.status_state * string option) -> unit req + | Pr : int -> Github_t.pull req + | Open_prs : Github_t.pull list req + + type breq = R : 'a req * 'a Lwt.u -> breq + + let eval : type a. Conf.t -> repo -> a req -> a Github.Monad.t = + fun conf repo req -> + let open Github.Monad in + let open Github_t in + let token = conf.Conf.token in + match req with + | Count_previous_posts { pr_user = user; number; _ } -> + let s = Github.Search.issues + ~qualifiers:[`Author user; `Repo (conf.Conf.repo.user ^"/"^conf.Conf.repo.name);] + ~keywords:[] () + in + bind (function + | None -> return 0 + | Some ({repository_issue_search_total_count = c}, _) -> return c + ) + (Github.Stream.next s) + | Comment (pr,body) -> + begin + let user = pr.base.repo.user in + let repo = pr.base.repo.name in + let num = pr.number in + let rec find_comment stream = + Github.Stream.next stream >>= function + | Some (c, s) -> + if c.issue_comment_user.user_login = conf.name then return (Some c) + else find_comment s + | None -> return None + in + find_comment (Github.Issue.comments ~token ~user ~repo ~num ()) + >>= function + | None -> + Github.Issue.create_comment ~token ~user ~repo ~num ~body () + | Some { issue_comment_id = id; _ } -> + Github.Issue.update_comment ~token ~user ~repo ~id ~body () + end >>= fun _ -> return () + | Status (pr,status,text) -> + let status = { + new_status_state = status; + new_status_target_url = None; + new_status_description = text; + new_status_context = Some conf.Conf.name; + } in + Github.Status.create + ~token ~user:pr.base.repo.user ~repo:pr.base.repo.name + ~status ~sha:pr.head.sha () + >>= fun _ -> return () + | Pr num -> + Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= + Github.Response.value + | Open_prs -> + Github.Pull.for_repo ~token ~state:`Open ~user:repo.user ~repo:repo.name () + |> Github.Stream.to_list + + let gh_stream, gh_push = Lwt_stream.create () + + let request : type a. a req -> a Lwt.t = fun req -> + let (promise, resolve) = Lwt.wait () in + gh_push ( Some ( R ( req, resolve ) ) ); + promise + + let loop ~conf () = + let step () = + match%lwt Lwt_stream.next gh_stream with + | exception exn -> + log "Event handler failed: %s" (Printexc.to_string exn); + Lwt.return (Github.Monad.return ()) + | R ( req, resolve ) -> + let repo = conf.Conf.repo in + Lwt.return @@ + ( let open Github.Monad in + catch + (fun () -> eval conf repo req >>= fun res -> + Lwt.wakeup_later resolve res; return () ) + (fun exn -> Lwt.wakeup_later_exn resolve exn; return () ) ) + in + let rec looper () = + let open Github.Monad in + step () |> embed |> bind (fun x -> x) >>= looper + in + run (fun () -> looper ()) + end module RepoGit = struct @@ -1139,17 +1229,15 @@ module PrChecks = struct | user -> Lwt.catch (fun () -> - GH.run (fun () -> Github.Stream.to_list @@ Github.Search.issues ~qualifiers:[`Author user; `Repo (conf.Conf.repo.user ^"/"^conf.Conf.repo.name);] ~keywords:[] ()) >>= function - | [] -> raise Not_found - | { Github_t.repository_issue_search_total_count = l; _ }::_ -> + GH.request (Count_previous_posts pr) >>= fun l -> Lwt.return @@ if l <= 1 - then "I believe this is your first contribution here. Please be nice, reviewers!" + then Printf.sprintf "Hello @%s! I believe this is your first contribution here. Please be nice, reviewers!" user else if l <= 50 then Printf.sprintf "@%s has posted %d contributions." user l else Printf.sprintf "A pull request by opam-seasoned @%s." user ) - (fun _ -> Lwt.return @@ Printf.sprintf "Hey @thomasblanc there is a bug in your code see logs for %d" pr.number) + (fun _ -> Lwt.return "I made an error retrieving the post by the user, sorry about that") end in Lwt.return @@ Printf.sprintf "Commit: %s\n\n%s\n\n" pr.head.sha hello_msg @@ -1184,7 +1272,6 @@ end module Github_comment = struct - open Github.Monad open Github_t let github_max_descr_length = 140 @@ -1201,27 +1288,12 @@ module Github_comment = struct ~status ~sha:pr.head.sha () let push_status ~name ~token pr ?text status = - GH.run (fun () -> make_status ~name ~token pr ?text status) + GH.request (Status ( pr, status, text)) let push_report ~name ~token ~report:(status,body) pr = - let user = pr.base.repo.user in - let repo = pr.base.repo.name in - let num = pr.number in let comment () = log "Commenting..."; - let rec find_comment stream = - Github.Stream.next stream >>= function - | Some (c, s) -> - if c.issue_comment_user.user_login = name then return (Some c) - else find_comment s - | None -> return None - in - find_comment (Github.Issue.comments ~token ~user ~repo ~num ()) - >>= function - | None -> - Github.Issue.create_comment ~token ~user ~repo ~num ~body () - | Some { issue_comment_id = id; _ } -> - Github.Issue.update_comment ~token ~user ~repo ~id ~body () + GH.request @@ Comment (pr,body) in let push_status () = log "Pushing status..."; @@ -1239,51 +1311,50 @@ module Github_comment = struct if String.length m <= github_max_descr_length then m else Printf.sprintf "Errors for %d packages" (List.length ps) in - make_status ~name ~token pr ~text state - in - GH.run (fun () -> - comment () >>= fun _ -> - push_status () >>= fun _ -> - return (log "Comment posted back to PR #%d" pr.number); - ) - - let pull_request ~name ~token repo branch target_branch ?message title = - log "Pull-requesting..."; - let pr () = - let rec find_pr stream = - Github.Stream.next stream >>= function - | Some (pr, s) -> - if pr.pull_head.branch_ref = branch && - pr.pull_base.branch_ref = target_branch - then return (Some pr) - else find_pr s - | None -> return None - in - find_pr (Github.Pull.for_repo - ~token ~state:`Open ~user:repo.user ~repo:repo.name ()) - >>= function - | None -> - let pull = { - new_pull_title = title; - new_pull_body = message; - new_pull_base = target_branch; - new_pull_head = branch; - } in - Github.Pull.create ~token ~user:repo.user ~repo:repo.name ~pull () - | Some pr -> - let update_pull = { - update_pull_title = Some title; - update_pull_body = message; - update_pull_state = None; - update_pull_base = None; - } in - Github.Pull.update ~token ~user:repo.user ~repo:repo.name - ~num:pr.pull_number ~update_pull () + push_status ~name ~token pr ~text state in - GH.run (fun () -> - pr () >>= fun resp -> - return (log "Filed pull-request #%d" resp#value.pull_number) - ) + comment () >>= fun () -> + push_status () >>= fun () -> + Lwt.return (log "Comment posted back to PR #%d" pr.number) + + (* let pull_request ~name ~token repo branch target_branch ?message title = + * let open Github.Monad in + * log "Pull-requesting..."; + * let pr () = + * let rec find_pr stream = + * Github.Stream.next stream >>= function + * | Some (pr, s) -> + * if pr.pull_head.branch_ref = branch && + * pr.pull_base.branch_ref = target_branch + * then return (Some pr) + * else find_pr s + * | None -> return None + * in + * find_pr (Github.Pull.for_repo + * ~token ~state:`Open ~user:repo.user ~repo:repo.name ()) + * >>= function + * | None -> + * let pull = { + * new_pull_title = title; + * new_pull_body = message; + * new_pull_base = target_branch; + * new_pull_head = branch; + * } in + * Github.Pull.create ~token ~user:repo.user ~repo:repo.name ~pull () + * | Some pr -> + * let update_pull = { + * update_pull_title = Some title; + * update_pull_body = message; + * update_pull_state = None; + * update_pull_base = None; + * } in + * Github.Pull.update ~token ~user:repo.user ~repo:repo.name + * ~num:pr.pull_number ~update_pull () + * in + * GH.run (fun () -> + * pr () >>= fun resp -> + * return (log "Filed pull-request #%d" resp#value.pull_number) + * ) *) end diff --git a/camelus_main.ml b/camelus_main.ml index 1da4cac..28b6deb 100644 --- a/camelus_main.ml +++ b/camelus_main.ml @@ -50,35 +50,35 @@ let handler conf gitstore = function ~text:"Could not complete" `Failure in Lwt.return_unit) - | `Push p when List.mem `Push_upgrader conf.Conf.roles -> - (log "=> Push received (head %s onto %s)" - p.push_head p.push_ancestor; - let auth = conf.Conf.name, Github.Token.to_string conf.Conf.token in - let%lwt pr_branch = - try%lwt - FormatUpgrade.run conf.Conf.base_branch conf.Conf.dest_branch - p.push_ancestor p.push_head gitstore - { p.push_repo with auth = Some auth } - with exn -> - log "Upgrade commit failed: %s" (Printexc.to_string exn); - Lwt.return None - in - match pr_branch with - | None -> Lwt.return_unit - | Some (branch, msg) -> - let title, message = - match OpamStd.String.cut_at msg '\n' with - | Some (t, m) -> t, Some (String.trim m) - | None -> "Merge changes from 1.2 format repo", None - in - try%lwt - Github_comment.pull_request - ~name:conf.Conf.name ~token:conf.Conf.token conf.Conf.repo - branch conf.Conf.dest_branch - ?message title - with exn -> - log "Pull request failed: %s" (Printexc.to_string exn); - Lwt.return_unit) + (* | `Push p when List.mem `Push_upgrader conf.Conf.roles -> + * (log "=> Push received (head %s onto %s)" + * p.push_head p.push_ancestor; + * let auth = conf.Conf.name, Github.Token.to_string conf.Conf.token in + * let%lwt pr_branch = + * try%lwt + * FormatUpgrade.run conf.Conf.base_branch conf.Conf.dest_branch + * p.push_ancestor p.push_head gitstore + * { p.push_repo with auth = Some auth } + * with exn -> + * log "Upgrade commit failed: %s" (Printexc.to_string exn); + * Lwt.return None + * in + * match pr_branch with + * | None -> Lwt.return_unit + * | Some (branch, msg) -> + * let title, message = + * match OpamStd.String.cut_at msg '\n' with + * | Some (t, m) -> t, Some (String.trim m) + * | None -> "Merge changes from 1.2 format repo", None + * in + * try%lwt + * Github_comment.pull_request + * ~name:conf.Conf.name ~token:conf.Conf.token conf.Conf.repo + * branch conf.Conf.dest_branch + * ?message title + * with exn -> + * log "Pull request failed: %s" (Printexc.to_string exn); + * Lwt.return_unit) *) | _ -> Lwt.return_unit let () = @@ -91,6 +91,7 @@ let () = (OpamFile.to_string f) (Printexc.to_string e); exit 3 in + let gh_loop = GH.loop ~conf () in let event_stream, event_push = Lwt_stream.create () in let rec check_loop gitstore = match%lwt Lwt_stream.next event_stream with @@ -118,11 +119,12 @@ let () = in Lwt.return (event_push (Some event)) in - Lwt_main.run (Lwt.join [ + Lwt_main.run (Lwt.choose [ (match%lwt RepoGit.get conf.Conf.repo with | Ok r -> check_loop r | Error e -> Lwt.fail (Failure "Repository loading failed")); Webhook_handler.server ~conf ~handler; + gh_loop; ]) diff --git a/camelus_replay.ml b/camelus_replay.ml index d61584c..1ce0677 100644 --- a/camelus_replay.ml +++ b/camelus_replay.ml @@ -2,6 +2,8 @@ open Camelus_lib let conf = Conf.read (OpamFile.make (OpamFilename.of_string "opam-ci.conf")) +let gh_loop = GH.loop ~conf () + let name = conf.Conf.name let token = conf.Conf.token @@ -23,36 +25,36 @@ let get_pr num = open Lwt.Infix open Github_t -let replay_upgrade num = - let%lwt gitstore = match%lwt RepoGit.get repo with - | Ok r -> Lwt.return r - | Error e -> Lwt.fail (Failure "Repository loading failed") - in - let%lwt p = get_pr num in - let merge_sha = match p.pull_merged_at, p.pull_merge_commit_sha with - | Some _, Some h -> h - | _ -> failwith "No merge SHA found" - in - let merge_parent_sha = merge_sha^"^" in - log "Upgrading branch from %s to %s" - merge_parent_sha merge_sha; - let%lwt new_branch = - FormatUpgrade.run base_branch dest_branch - merge_parent_sha merge_sha gitstore - repo - in - match new_branch with - | None -> Lwt.return_unit - | Some (branch, msg) -> - let title, message = - match OpamStd.String.cut_at msg '\n' with - | Some (t, m) -> t, Some (String.trim m) - | None -> "Merge changes from 1.2 format repo", None - in - Github_comment.pull_request - ~name ~token repo - branch dest_branch - ?message title +(* let replay_upgrade num = + * let%lwt gitstore = match%lwt RepoGit.get repo with + * | Ok r -> Lwt.return r + * | Error e -> Lwt.fail (Failure "Repository loading failed") + * in + * let%lwt p = get_pr num in + * let merge_sha = match p.pull_merged_at, p.pull_merge_commit_sha with + * | Some _, Some h -> h + * | _ -> failwith "No merge SHA found" + * in + * let merge_parent_sha = merge_sha^"^" in + * log "Upgrading branch from %s to %s" + * merge_parent_sha merge_sha; + * let%lwt new_branch = + * FormatUpgrade.run base_branch dest_branch + * merge_parent_sha merge_sha gitstore + * repo + * in + * match new_branch with + * | None -> Lwt.return_unit + * | Some (branch, msg) -> + * let title, message = + * match OpamStd.String.cut_at msg '\n' with + * | Some (t, m) -> t, Some (String.trim m) + * | None -> "Merge changes from 1.2 format repo", None + * in + * Github_comment.pull_request + * ~name ~token repo + * branch dest_branch + * ?message title *) let get_unchecked_pr () = let open Github.Monad in @@ -110,9 +112,9 @@ let replay_check nums = let () = match Sys.argv.(1) with - | "upgrade" -> - let num = int_of_string Sys.argv.(2) in - Lwt_main.run (replay_upgrade num) + (* | "upgrade" -> + * let num = int_of_string Sys.argv.(2) in + * Lwt_main.run (replay_upgrade num) *) | "check" -> let num = int_of_string Sys.argv.(2) in Lwt_main.run (Lwt.with_value log_tag (Some Sys.argv.(2)) (fun () ->replay_check [num])) @@ -126,5 +128,5 @@ let () = end | "auto" -> Lwt_main.run begin get_unchecked_pr () >>= replay_check end | _ -> - OpamConsole.msg "Usage: %s PR# or %s check-bunch PR#...\n" Sys.argv.(0) Sys.argv.(0); + OpamConsole.msg "Usage: %s auto or %s check PR# or %s check-bunch PR#...\n" Sys.argv.(0) Sys.argv.(0) Sys.argv.(0); exit 2 From d4c5caf03bc212e4e72d0e8f10a7e03bb9a40bd1 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Mon, 14 Oct 2019 17:41:52 +0200 Subject: [PATCH 06/12] Fixing camelus replay hanging --- camelus_lib.ml | 22 ++++++++++++++++++---- camelus_replay.ml | 29 ++--------------------------- 2 files changed, 20 insertions(+), 31 deletions(-) diff --git a/camelus_lib.ml b/camelus_lib.ml index 38f6d61..3e24673 100644 --- a/camelus_lib.ml +++ b/camelus_lib.ml @@ -173,7 +173,7 @@ module GH = struct | Comment : pull_request * string -> unit req | Status : (pull_request * Github_t.status_state * string option) -> unit req | Pr : int -> Github_t.pull req - | Open_prs : Github_t.pull list req + | Needing_check : int list req type breq = R : 'a req * 'a Lwt.u -> breq @@ -226,9 +226,23 @@ module GH = struct | Pr num -> Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= Github.Response.value - | Open_prs -> - Github.Pull.for_repo ~token ~state:`Open ~user:repo.user ~repo:repo.name () - |> Github.Stream.to_list + | Needing_check -> + Github.Pull.for_repo ~token ~state:`Open ~user:conf.repo.user ~repo:conf.repo.name () + |> Github.Stream.map (fun pr -> + let stream = Github.Issue.comments ~token ~user:repo.user ~repo:repo.name ~num:pr.pull_number () in + Github.Stream.find (fun { issue_comment_user = u; _ } -> u.user_login = conf.Conf.name) stream >>= + function + | Some ({ issue_comment_body = b; _ },_) -> + begin try Scanf.sscanf b "Commit: %s\n" + (fun c -> + if String.equal c pr.pull_head.branch_sha + then return [] + else return [pr.pull_number]) + with _ -> return [pr.pull_number] end + | None -> return [pr.pull_number] + ) + |> Github.Stream.to_list + let gh_stream, gh_push = Lwt_stream.create () diff --git a/camelus_replay.ml b/camelus_replay.ml index 1ce0677..ca3dd6e 100644 --- a/camelus_replay.ml +++ b/camelus_replay.ml @@ -3,7 +3,6 @@ open Camelus_lib let conf = Conf.read (OpamFile.make (OpamFilename.of_string "opam-ci.conf")) let gh_loop = GH.loop ~conf () - let name = conf.Conf.name let token = conf.Conf.token @@ -16,11 +15,7 @@ let repo = { let base_branch = "master" let dest_branch = "2.0.0" -let get_pr num = - GH.run (fun () -> - let open Github.Monad in - Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= - Github.Response.value) +let get_pr num = GH.request (Pr num) open Lwt.Infix open Github_t @@ -56,27 +51,7 @@ open Github_t * branch dest_branch * ?message title *) -let get_unchecked_pr () = - let open Github.Monad in - GH.run (fun () -> - let open_prs = Github.Pull.for_repo ~token ~state:`Open ~user:repo.user ~repo:repo.name () in - let res_stream = - Github.Stream.map (fun pr -> - let stream = Github.Issue.comments ~token ~user:repo.user ~repo:repo.name ~num:pr.pull_number () in - Github.Stream.find (fun { issue_comment_user = u; _ } -> u.user_login = conf.Conf.name) stream >>= - function - | Some ({ issue_comment_body = b; _ },_) -> - begin try Scanf.sscanf b "Commit: %s\n" - (fun c -> - if String.equal c pr.pull_head.branch_sha - then return [] - else return [pr.pull_number]) - with _ -> return [pr.pull_number] end - | None -> return [pr.pull_number] - ) open_prs - in - Github.Stream.to_list res_stream - ) +let get_unchecked_pr () = GH.(request Needing_check) let replay_check nums = let%lwt gitstore = match%lwt RepoGit.get repo with From bfb0cdcccbf79b4935ce7e9d87149d82556a22d4 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Tue, 26 Nov 2019 15:46:53 +0100 Subject: [PATCH 07/12] Fix ignored commenting and status push --- camelus_lib.ml | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/camelus_lib.ml b/camelus_lib.ml index 3e24673..5ad1242 100644 --- a/camelus_lib.ml +++ b/camelus_lib.ml @@ -164,13 +164,9 @@ end module GH = struct - let mutex = Lwt_mutex.create () - - let run f = Lwt_mutex.with_lock mutex (fun () -> Github.Monad.run @@ f ()) - type _ req = | Count_previous_posts : pull_request -> int req - | Comment : pull_request * string -> unit req + | Comment : pull_request * string -> string req | Status : (pull_request * Github_t.status_state * string option) -> unit req | Pr : int -> Github_t.pull req | Needing_check : int list req @@ -211,7 +207,7 @@ module GH = struct Github.Issue.create_comment ~token ~user ~repo ~num ~body () | Some { issue_comment_id = id; _ } -> Github.Issue.update_comment ~token ~user ~repo ~id ~body () - end >>= fun _ -> return () + end >>~ (fun { issue_comment_html_url = url; _ } -> return url) | Status (pr,status,text) -> let status = { new_status_state = status; @@ -222,7 +218,7 @@ module GH = struct Github.Status.create ~token ~user:pr.base.repo.user ~repo:pr.base.repo.name ~status ~sha:pr.head.sha () - >>= fun _ -> return () + >>~ fun _ -> return () | Pr num -> Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= Github.Response.value @@ -251,7 +247,7 @@ module GH = struct gh_push ( Some ( R ( req, resolve ) ) ); promise - let loop ~conf () = + let loop ?(ntries=3) ?(retry_interval=60.) ~conf () = let step () = match%lwt Lwt_stream.next gh_stream with | exception exn -> @@ -259,18 +255,23 @@ module GH = struct Lwt.return (Github.Monad.return ()) | R ( req, resolve ) -> let repo = conf.Conf.repo in - Lwt.return @@ - ( let open Github.Monad in - catch - (fun () -> eval conf repo req >>= fun res -> - Lwt.wakeup_later resolve res; return () ) - (fun exn -> Lwt.wakeup_later_exn resolve exn; return () ) ) + let rec evaln n = + ( let open Github.Monad in + catch + (fun () -> eval conf repo req >>= fun res -> + Lwt.wakeup_later resolve res; return () ) + (fun exn -> + if n > 0 + then ( embed (Lwt_unix.sleep retry_interval) >>= fun () -> evaln (pred n) ) + else ( Lwt.wakeup_later_exn resolve exn; return () ) ) ) + in + Lwt.return @@ evaln ntries in let rec looper () = let open Github.Monad in step () |> embed |> bind (fun x -> x) >>= looper in - run (fun () -> looper ()) + Github.Monad.run @@ looper () end @@ -1307,7 +1308,8 @@ module Github_comment = struct let push_report ~name ~token ~report:(status,body) pr = let comment () = log "Commenting..."; - GH.request @@ Comment (pr,body) + GH.request @@ Comment (pr,body) >>= fun cmturl -> + Lwt.return @@ log "Comment posted on %s" cmturl in let push_status () = log "Pushing status..."; From f40d5691cd29f3b3d61056d80c6cb01d6e5f3259 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Fri, 27 Mar 2020 17:52:57 +0100 Subject: [PATCH 08/12] Forking ready for testing --- camelus_child.ml | 32 ++++++ camelus_lib.ml | 284 ++++++++++++++++++++++++++++++++++------------ camelus_replay.ml | 34 ++++++ dune | 9 ++ test_linearize.ml | 19 ++++ 5 files changed, 305 insertions(+), 73 deletions(-) create mode 100644 camelus_child.ml create mode 100644 test_linearize.ml diff --git a/camelus_child.ml b/camelus_child.ml new file mode 100644 index 0000000..58ec51b --- /dev/null +++ b/camelus_child.ml @@ -0,0 +1,32 @@ +open Camelus_lib + +let conf = Conf.read (OpamFile.make (OpamFilename.of_string "opam-ci.conf")) + +let name = conf.Conf.name +let token = conf.Conf.token + +let repo = { + user = "ocaml"; + name = "opam-repository"; + auth = Some (name, Github.Token.to_string token); +} + +let base_branch = "master" +let dest_branch = "2.0.0" + +let _ = + let pr = Fork_handler.delinearize_pr Sys.argv 1 in + Lwt_main.run begin + let%lwt gitstore = match%lwt RepoGit.get repo with + | Ok r -> Lwt.return r + | Error e -> Lwt.fail (Failure "Repository loading failed") + in + let%lwt status,body = PrChecks.run_nogit ~conf pr gitstore in + Github.( + Monad.(run @@ begin + let state,text = Github_comment.make_status status in + GH.comment conf pr body >>= fun _ -> + GH.status conf pr state (Some text) + end) + ) + end diff --git a/camelus_lib.ml b/camelus_lib.ml index 5ad1242..b638cc0 100644 --- a/camelus_lib.ml +++ b/camelus_lib.ml @@ -71,6 +71,7 @@ module Conf = struct roles: [ `Pr_checker | `Push_upgrader ] list; base_branch: string; dest_branch: string; + camelus_child_loc : string; } let empty = { @@ -82,6 +83,7 @@ module Conf = struct roles = [ `Pr_checker ]; base_branch = "master"; dest_branch = "2.0.0"; + camelus_child_loc = "./camelus_child.native"; } open OpamPp.Op @@ -130,6 +132,9 @@ module Conf = struct (fun dest_branch t -> {t with dest_branch }) (fun t -> t.dest_branch) OpamFormat.V.string; + "child-process", OpamPp.ppacc (fun camelus_child_loc t -> {t with camelus_child_loc}) (fun t -> t.camelus_child_loc) + OpamFormat.V.string; + ] let pp = @@ -173,71 +178,100 @@ module GH = struct type breq = R : 'a req * 'a Lwt.u -> breq + let count_previous_posts conf { pr_user = user; number; _ } = + let open Github.Monad in + let open Github_t in + let s = Github.Search.issues + ~qualifiers:[`Author user; + `Repo (conf.Conf.repo.user ^"/"^conf.Conf.repo.name);] + ~keywords:[] () + in + bind (function + | None -> return 0 + | Some ({repository_issue_search_total_count = c}, _) -> return c + ) + (Github.Stream.next s) + + let comment conf pr body = + let open Github.Monad in + let open Github_t in + let token = conf.Conf.token in + let user = pr.base.repo.user in + let repo = pr.base.repo.name in + let num = pr.number in + let rec find_comment stream = + Github.Stream.next stream >>= function + | Some (c, s) -> + if c.issue_comment_user.user_login = conf.name then return (Some c) + else find_comment s + | None -> return None + in + begin + find_comment (Github.Issue.comments ~token ~user ~repo ~num ()) + >>= function + | None -> + Github.Issue.create_comment ~token ~user ~repo ~num ~body () + | Some { issue_comment_id = id; _ } -> + Github.Issue.update_comment ~token ~user ~repo ~id ~body () + end >>~ (fun { issue_comment_html_url = url; _ } -> return url) + + let status conf pr status text = + let open Github.Monad in + let open Github_t in + let token = conf.Conf.token in + let status = { + new_status_state = status; + new_status_target_url = None; + new_status_description = text; + new_status_context = Some conf.Conf.name; + } in + Github.Status.create + ~token ~user:pr.base.repo.user ~repo:pr.base.repo.name + ~status ~sha:pr.head.sha () + >>~ fun _ -> return () + + let pr conf repo num = + let open Github.Monad in + let open Github_t in + Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= + Github.Response.value + + let needing_check conf repo = + let open Github.Monad in + let open Github_t in + let token = conf.Conf.token in + Github.Pull.for_repo + ~token ~state:`Open ~user:conf.repo.user ~repo:conf.repo.name () + |> Github.Stream.map (fun pr -> + let stream = Github.Issue.comments + ~token ~user:repo.user ~repo:repo.name ~num:pr.pull_number () + in + Github.Stream.find + (fun { issue_comment_user = u; _ } -> u.user_login = conf.Conf.name) + stream + >>= function + | Some ({ issue_comment_body = b; _ },_) -> + begin + try Scanf.sscanf b "Commit: %s\n" + (fun c -> + if String.equal c pr.pull_head.branch_sha + then return [] + else return [pr.pull_number]) + with _ -> return [pr.pull_number] end + | None -> return [pr.pull_number] + ) + |> Github.Stream.to_list + let eval : type a. Conf.t -> repo -> a req -> a Github.Monad.t = fun conf repo req -> let open Github.Monad in let open Github_t in - let token = conf.Conf.token in match req with - | Count_previous_posts { pr_user = user; number; _ } -> - let s = Github.Search.issues - ~qualifiers:[`Author user; `Repo (conf.Conf.repo.user ^"/"^conf.Conf.repo.name);] - ~keywords:[] () - in - bind (function - | None -> return 0 - | Some ({repository_issue_search_total_count = c}, _) -> return c - ) - (Github.Stream.next s) - | Comment (pr,body) -> - begin - let user = pr.base.repo.user in - let repo = pr.base.repo.name in - let num = pr.number in - let rec find_comment stream = - Github.Stream.next stream >>= function - | Some (c, s) -> - if c.issue_comment_user.user_login = conf.name then return (Some c) - else find_comment s - | None -> return None - in - find_comment (Github.Issue.comments ~token ~user ~repo ~num ()) - >>= function - | None -> - Github.Issue.create_comment ~token ~user ~repo ~num ~body () - | Some { issue_comment_id = id; _ } -> - Github.Issue.update_comment ~token ~user ~repo ~id ~body () - end >>~ (fun { issue_comment_html_url = url; _ } -> return url) - | Status (pr,status,text) -> - let status = { - new_status_state = status; - new_status_target_url = None; - new_status_description = text; - new_status_context = Some conf.Conf.name; - } in - Github.Status.create - ~token ~user:pr.base.repo.user ~repo:pr.base.repo.name - ~status ~sha:pr.head.sha () - >>~ fun _ -> return () - | Pr num -> - Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= - Github.Response.value - | Needing_check -> - Github.Pull.for_repo ~token ~state:`Open ~user:conf.repo.user ~repo:conf.repo.name () - |> Github.Stream.map (fun pr -> - let stream = Github.Issue.comments ~token ~user:repo.user ~repo:repo.name ~num:pr.pull_number () in - Github.Stream.find (fun { issue_comment_user = u; _ } -> u.user_login = conf.Conf.name) stream >>= - function - | Some ({ issue_comment_body = b; _ },_) -> - begin try Scanf.sscanf b "Commit: %s\n" - (fun c -> - if String.equal c pr.pull_head.branch_sha - then return [] - else return [pr.pull_number]) - with _ -> return [pr.pull_number] end - | None -> return [pr.pull_number] - ) - |> Github.Stream.to_list + | Count_previous_posts pr -> count_previous_posts conf pr + | Comment (pr,body) -> comment conf pr body + | Status (pr,s,text) -> status conf pr s text + | Pr num -> pr conf repo num + | Needing_check -> needing_check conf repo let gh_stream, gh_push = Lwt_stream.create () @@ -1256,9 +1290,7 @@ module PrChecks = struct end in Lwt.return @@ Printf.sprintf "Commit: %s\n\n%s\n\n" pr.head.sha hello_msg - - let run ~conf pr gitstore = - let%lwt () = RepoGit.fetch_pr pr gitstore in + let run_nogit ~conf pr gitstore = let%lwt msghead = msg_header ~conf pr in let head = pr.head.sha in let%lwt ancestor = RepoGit.common_ancestor pr gitstore in @@ -1283,6 +1315,9 @@ module PrChecks = struct (Printexc.get_backtrace ()); Lwt.return (stlint, msghead ^ msglint ^ misc_files_body) + let run ~conf pr gitstore = + let%lwt () = RepoGit.fetch_pr pr gitstore in + run_nogit ~conf pr gitstore end module Github_comment = struct @@ -1291,20 +1326,35 @@ module Github_comment = struct let github_max_descr_length = 140 - let make_status ~name ~token pr ?text status = - let status = { - new_status_state = status; - new_status_target_url = None; - new_status_description = text; - new_status_context = Some name; - } in - Github.Status.create - ~token ~user:pr.base.repo.user ~repo:pr.base.repo.name - ~status ~sha:pr.head.sha () + (* let make_status ~name ~token pr ?text status = + * let status = { + * new_status_state = status; + * new_status_target_url = None; + * new_status_description = text; + * new_status_context = Some name; + * } in + * Github.Status.create + * ~token ~user:pr.base.repo.user ~repo:pr.base.repo.name + * ~status ~sha:pr.head.sha () *) let push_status ~name ~token pr ?text status = GH.request (Status ( pr, status, text)) + let make_status = function + | `Passed -> + `Success, "All tests passed" + | `Warnings ps -> + `Success, + let m = "Warnings for "^String.concat ", " ps in + if String.length m <= github_max_descr_length then m else + Printf.sprintf "Warnings for %d packages" (List.length ps) + | `Errors ps -> + `Error, + let m = "Errors for "^String.concat ", " ps in + if String.length m <= github_max_descr_length then m else + Printf.sprintf "Errors for %d packages" (List.length ps) + + let push_report ~name ~token ~report:(status,body) pr = let comment () = log "Commenting..."; @@ -1523,3 +1573,91 @@ module Webhook_handler = struct ~mode:(`TCP (`Port port)) (Server.make ~callback ()) end + +module Fork_handler = struct + + let forktable : (int,unit Lwt.t * Lwt_process.process_none) Hashtbl.t = Hashtbl.create 111 + + let linearize_repo { user; name; auth; } = + match auth with + | None -> [| user; name; ""; "" |] + | Some (a,b) -> [| user; name; a; b |] + let delinearize_repo a offset = + { user = a.(offset); name = a.(offset+1); + auth = + match a.(offset+2), a.(offset+3) with + | "","" -> None + | a,b -> Some (a,b) } + + let l_repo = 4 + + let linearize_full_ref { repo; ref; sha } = + Array.append (linearize_repo repo) [| ref; sha; |] + let delinearize_full_ref a offset = + { repo = delinearize_repo a offset; + ref = a.(offset+l_repo); + sha = a.(offset+l_repo+1); + } + let l_fr = l_repo + 2 + + let linearize_pr { number; base; head; pr_user; message = a,b; } = + Array.concat [ + [| string_of_int number |]; + (linearize_full_ref base); + (linearize_full_ref head); + [|pr_user;a;b|] + ] + let delinearize_pr a offset = + { + number = int_of_string a.(offset); + base = delinearize_full_ref a (succ offset); + head = delinearize_full_ref a (succ offset + l_fr); + pr_user = a.(succ offset + l_fr + l_fr); + message = (a.(offset + l_fr + l_fr + 2), a.(offset + l_fr + l_fr + 3)); + } + + let gen_args conf pr = + Array.append [|conf.Conf.camelus_child_loc|] @@ + linearize_pr pr + + let process ~conf pr = + let commit = pr.head.sha in + let num = pr.number in + begin + match Hashtbl.find_opt forktable num with + | None -> Lwt.return_unit + | Some (old_promise, old_process) -> + old_process#terminate; + Lwt.catch (fun () -> old_promise) (fun _ -> Lwt.return_unit) + end >>= fun () -> + let process = + new Lwt_process.process_none + (conf.Conf.camelus_child_loc, + Array.append + [|conf.Conf.camelus_child_loc|] + (linearize_pr pr) + ) + in + let waiter,wakener = Lwt.wait () in + let promise = + Lwt.finalize + (fun () -> waiter >>= + fun () -> process#status >>= + fun stat -> ( + match stat with + | Unix.WEXITED e -> + log "pr %d commit %s handled, exit status %d" num commit e + | Unix.WSIGNALED s -> + log "pr %d commit %s killed, signal %d" num commit s + | Unix.WSTOPPED s -> + log "pr %d commit %s stopped, signal %d" num commit s + ); + Lwt.return_unit) + (fun () -> Hashtbl.remove forktable num; Lwt.return_unit) + in + Hashtbl.replace forktable num (promise,process); + Lwt.wakeup_later wakener (); + Lwt.return_unit + + +end diff --git a/camelus_replay.ml b/camelus_replay.ml index ca3dd6e..2d8e91f 100644 --- a/camelus_replay.ml +++ b/camelus_replay.ml @@ -53,6 +53,32 @@ open Github_t let get_unchecked_pr () = GH.(request Needing_check) +let replay_pr_fork gitstore num = + Lwt.with_value log_tag (Some (string_of_int num)) (fun () -> + let%lwt pr = get_pr num >|= fun p -> + let get_repo b = { + repo = + (match b.branch_repo with + | None -> repo + | Some gr -> { + user = gr.repository_owner.user_login; + name = gr.repository_name; + auth = None; + }); + ref = b.branch_ref; + sha = b.branch_sha; + } in { + number = num; + base = get_repo p.pull_base; + head = get_repo p.pull_head; + pr_user = p.pull_user.user_login; + message = p.pull_title, p.pull_body; + } + in + RepoGit.fetch_pr pr gitstore >>= fun () -> + Fork_handler.process ~conf pr) + + let replay_check nums = let%lwt gitstore = match%lwt RepoGit.get repo with | Ok r -> Lwt.return r @@ -102,6 +128,14 @@ let () = Lwt_main.run (replay_check nums) end | "auto" -> Lwt_main.run begin get_unchecked_pr () >>= replay_check end + | "autofork" -> Lwt_main.run begin + get_unchecked_pr () >>= fun l -> + let%lwt gitstore = match%lwt RepoGit.get repo with + | Ok r -> Lwt.return r + | Error e -> Lwt.fail (Failure "Repository loading failed") + in + Lwt_list.iter_p (replay_pr_fork gitstore) l + end | _ -> OpamConsole.msg "Usage: %s auto or %s check PR# or %s check-bunch PR#...\n" Sys.argv.(0) Sys.argv.(0) Sys.argv.(0); exit 2 diff --git a/dune b/dune index 75a126c..c60fbc0 100644 --- a/dune +++ b/dune @@ -33,3 +33,12 @@ (libraries camelus) (preprocess (pps lwt_ppx)) ) + +(executable + (name camelus_child) + (public_name camelus_child) + (package camelus) + (modules camelus_child) + (libraries camelus) + (preprocess (pps lwt_ppx)) +) diff --git a/test_linearize.ml b/test_linearize.ml new file mode 100644 index 0000000..ab7a162 --- /dev/null +++ b/test_linearize.ml @@ -0,0 +1,19 @@ +open Camelus_lib + +let pr = { + number = 42; + base = { repo = { user = "pat"; name = "johnson"; auth = None; }; + ref = "PatJ"; + sha = "cha cha"; }; + head = { repo = { user = "tom"; name = "thomas"; auth = Some ("T","B"); }; + ref = "Tom"; + sha = "chi chi"; }; + pr_user = "blanc"; + message = "prout","caca"; +} + +let a = Fork_handler.linearize_pr pr +let a' = Array.append (Array.make 42 "") a +let () = Array.iter print_endline a + +let () = assert Fork_handler.(delinearize_pr a' 42 = pr) From 20d4ce343e0bed685fdfcd8f5305c43027861679 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Tue, 31 Mar 2020 15:34:36 +0200 Subject: [PATCH 09/12] child process spawnable in replay --- camelus_child.ml | 7 ++++++- camelus_lib.ml | 29 +++++++++++++++++------------ camelus_replay.ml | 3 ++- 3 files changed, 25 insertions(+), 14 deletions(-) diff --git a/camelus_child.ml b/camelus_child.ml index 58ec51b..b6b7258 100644 --- a/camelus_child.ml +++ b/camelus_child.ml @@ -16,12 +16,17 @@ let dest_branch = "2.0.0" let _ = let pr = Fork_handler.delinearize_pr Sys.argv 1 in + let msghead = Sys.argv.(pred @@ Array.length Sys.argv) in + Lwt.with_value log_tag (Some (string_of_int pr.number)) @@ + fun () -> + log "Pr handled in child process"; Lwt_main.run begin let%lwt gitstore = match%lwt RepoGit.get repo with | Ok r -> Lwt.return r | Error e -> Lwt.fail (Failure "Repository loading failed") in - let%lwt status,body = PrChecks.run_nogit ~conf pr gitstore in + log "repo gotten, running checks"; + let%lwt status,body = PrChecks.run_nogit ~conf pr gitstore msghead in Github.( Monad.(run @@ begin let state,text = Github_comment.make_status status in diff --git a/camelus_lib.ml b/camelus_lib.ml index b638cc0..9964a20 100644 --- a/camelus_lib.ml +++ b/camelus_lib.ml @@ -1290,8 +1290,7 @@ module PrChecks = struct end in Lwt.return @@ Printf.sprintf "Commit: %s\n\n%s\n\n" pr.head.sha hello_msg - let run_nogit ~conf pr gitstore = - let%lwt msghead = msg_header ~conf pr in + let run_nogit ~conf pr gitstore msghead = let head = pr.head.sha in let%lwt ancestor = RepoGit.common_ancestor pr gitstore in let%lwt opam_files, other_files = changed_opam_files ancestor head gitstore in @@ -1317,7 +1316,8 @@ module PrChecks = struct let run ~conf pr gitstore = let%lwt () = RepoGit.fetch_pr pr gitstore in - run_nogit ~conf pr gitstore + let%lwt msghead = msg_header ~conf pr in + run_nogit ~conf pr gitstore msghead end module Github_comment = struct @@ -1576,7 +1576,8 @@ end module Fork_handler = struct - let forktable : (int,unit Lwt.t * Lwt_process.process_none) Hashtbl.t = Hashtbl.create 111 + let forktable : (int,unit Lwt.t * Lwt_process.process_out) Hashtbl.t = + Hashtbl.create 111 let linearize_repo { user; name; auth; } = match auth with @@ -1617,8 +1618,12 @@ module Fork_handler = struct } let gen_args conf pr = - Array.append [|conf.Conf.camelus_child_loc|] @@ - linearize_pr pr + let%lwt msghead = PrChecks.msg_header ~conf pr in + Lwt.return @@ + (conf.Conf.camelus_child_loc, + Array.concat [ [|conf.Conf.camelus_child_loc|]; + linearize_pr pr; + [|msghead|]; ] ) let process ~conf pr = let commit = pr.head.sha in @@ -1630,13 +1635,11 @@ module Fork_handler = struct old_process#terminate; Lwt.catch (fun () -> old_promise) (fun _ -> Lwt.return_unit) end >>= fun () -> + let%lwt args = gen_args conf pr in let process = - new Lwt_process.process_none - (conf.Conf.camelus_child_loc, - Array.append - [|conf.Conf.camelus_child_loc|] - (linearize_pr pr) - ) + Lwt_process.open_process_out + ~stdout:`Keep ~stderr:`Keep + args in let waiter,wakener = Lwt.wait () in let promise = @@ -1659,5 +1662,7 @@ module Fork_handler = struct Lwt.wakeup_later wakener (); Lwt.return_unit + let pending_processes () = + Hashtbl.fold (fun _ (p,_) l -> p::l) forktable [] end diff --git a/camelus_replay.ml b/camelus_replay.ml index 2d8e91f..4c3c83c 100644 --- a/camelus_replay.ml +++ b/camelus_replay.ml @@ -134,7 +134,8 @@ let () = | Ok r -> Lwt.return r | Error e -> Lwt.fail (Failure "Repository loading failed") in - Lwt_list.iter_p (replay_pr_fork gitstore) l + Lwt_list.iter_p (replay_pr_fork gitstore) l >>= fun () -> + Lwt.join @@ Fork_handler.pending_processes () end | _ -> OpamConsole.msg "Usage: %s auto or %s check PR# or %s check-bunch PR#...\n" Sys.argv.(0) Sys.argv.(0) Sys.argv.(0); From bec9a4768348763892e5d8dfa45dd52d3cb8a36c Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Tue, 31 Mar 2020 15:53:32 +0200 Subject: [PATCH 10/12] Adding semaphore to limit forks --- camelus_lib.ml | 47 ++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 38 insertions(+), 9 deletions(-) diff --git a/camelus_lib.ml b/camelus_lib.ml index 9964a20..61ea7fa 100644 --- a/camelus_lib.ml +++ b/camelus_lib.ml @@ -146,20 +146,43 @@ module Conf = struct include OpamFile.SyntaxFile(C) end +module Semaphore = struct + + type t = + { + max_count : int; + mutable curr_count : int; + signal : unit Lwt_condition.t; + } + + let make max_count = + { max_count; curr_count = 0; + signal = Lwt_condition.create (); } + + let obtain x = + let go () = + x.curr_count <- succ x.curr_count; + Lwt.return_unit + in + if x.curr_count < x.max_count + then go () + else ( Lwt_condition.wait x.signal >>= fun () -> go () ) + + let release x = + x.curr_count <- pred x.curr_count; + Lwt_condition.signal x.signal () + +end + module FdPool = struct let max_count = 50 - let curr_count = ref 0 - let c : unit Lwt_condition.t = Lwt_condition.create () + let c = Semaphore.make max_count - let fd_use () = - if !curr_count < max_count - then ( incr curr_count; Lwt.return_unit ) - else ( Lwt_condition.wait c >>= fun () -> incr curr_count; Lwt.return_unit ) + let fd_use () = Semaphore.obtain c - let fd_free () = - decr curr_count; Lwt_condition.signal c () + let fd_free () = Semaphore.release c let with_fd (f : unit -> 'a Lwt.t) : 'a Lwt.t = begin fd_use () >>= f end @@ -1579,6 +1602,8 @@ module Fork_handler = struct let forktable : (int,unit Lwt.t * Lwt_process.process_out) Hashtbl.t = Hashtbl.create 111 + let fork_sema = Semaphore.make 20 + let linearize_repo { user; name; auth; } = match auth with | None -> [| user; name; ""; "" |] @@ -1636,6 +1661,7 @@ module Fork_handler = struct Lwt.catch (fun () -> old_promise) (fun _ -> Lwt.return_unit) end >>= fun () -> let%lwt args = gen_args conf pr in + let%lwt () = Semaphore.obtain fork_sema in let process = Lwt_process.open_process_out ~stdout:`Keep ~stderr:`Keep @@ -1656,7 +1682,10 @@ module Fork_handler = struct log "pr %d commit %s stopped, signal %d" num commit s ); Lwt.return_unit) - (fun () -> Hashtbl.remove forktable num; Lwt.return_unit) + (fun () -> + Hashtbl.remove forktable num; + Semaphore.release fork_sema; + Lwt.return_unit) in Hashtbl.replace forktable num (promise,process); Lwt.wakeup_later wakener (); From 0106c02db78cd4a6c522e228df13abd6d34ff969 Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Tue, 31 Mar 2020 16:34:54 +0200 Subject: [PATCH 11/12] camelus_child calling added to camelus_main --- camelus_main.ml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/camelus_main.ml b/camelus_main.ml index 28b6deb..4ffb4c0 100644 --- a/camelus_main.ml +++ b/camelus_main.ml @@ -36,12 +36,14 @@ let handler conf gitstore = function pr.head.repo.user pr.head.repo.name pr.head.ref pr.head.sha pr.base.sha; try%lwt - let%lwt report = PrChecks.run ~conf pr gitstore in - Github_comment.push_report - ~name:conf.Conf.name - ~token:conf.Conf.token - ~report - pr + (* let%lwt report = PrChecks.run ~conf pr gitstore in + * Github_comment.push_report + * ~name:conf.Conf.name + * ~token:conf.Conf.token + * ~report + * pr *) + RepoGit.fetch_pr pr gitstore >>= fun () -> + Fork_handler.process ~conf pr with exn -> log "Check failed: %s" (Printexc.to_string exn); let%lwt _ = From f78a3fb612118301d1043416851c84312135ee9d Mon Sep 17 00:00:00 2001 From: Thomas Blanc Date: Wed, 1 Apr 2020 15:50:01 +0200 Subject: [PATCH 12/12] TO DELETE log --- camelus_child.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/camelus_child.ml b/camelus_child.ml index b6b7258..c81532c 100644 --- a/camelus_child.ml +++ b/camelus_child.ml @@ -1,5 +1,7 @@ open Camelus_lib +let () = log "here" + let conf = Conf.read (OpamFile.make (OpamFilename.of_string "opam-ci.conf")) let name = conf.Conf.name