├── opam-ci.install ├── .ocp-indent ├── dune-project ├── Makefile ├── LICENSE ├── dune ├── camelus.opam ├── opam-ci.opam.locked ├── replay.ml ├── README.md ├── camelus_replay.ml ├── camelus_main.ml └── camelus_lib.ml /opam-ci.install: -------------------------------------------------------------------------------- 1 | bin: "opam-ci" 2 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | normal 2 | strict_else=auto 3 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name camelus) 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: opam_ci 2 | opam_ci: 3 | dune build -p camelus 4 | cp _build/default/camelus_main.exe opam-ci 5 | 6 | clean: 7 | rm -rf opam-ci _build 8 | 9 | install: 10 | dune install 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2015 by OCamlPro 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose 4 | with or without fee is hereby granted, provided that the above copyright notice 5 | and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED “AS IS” AND ISC DISCLAIMS ALL WARRANTIES WITH REGARD TO 8 | THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. 9 | IN NO EVENT SHALL ISC BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR 10 | CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 11 | OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 12 | ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 13 | SOFTWARE. 14 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name camelus_lib) 3 | (public_name camelus) 4 | (wrapped false) 5 | (modules camelus_lib) 6 | (libraries cohttp-lwt 7 | cohttp-lwt-unix 8 | conduit-lwt 9 | fpath 10 | github-unix 11 | nocrypto 12 | opam-format 13 | opam-solver 14 | opam-state 15 | yojson 16 | lwt.unix) 17 | (preprocess (pps lwt_ppx)) 18 | ) 19 | 20 | (executable 21 | (name camelus_main) 22 | (public_name camelus) 23 | (modules camelus_main) 24 | (libraries camelus) 25 | (preprocess (pps lwt_ppx)) 26 | ) 27 | 28 | (executable 29 | (name camelus_replay) 30 | (public_name camelus-replay) 31 | (package camelus) 32 | (modules camelus_replay) 33 | (libraries camelus) 34 | (preprocess (pps lwt_ppx)) 35 | ) 36 | -------------------------------------------------------------------------------- /camelus.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "0.2" 3 | synopsis: "Automated checks and management for opam repositories on Github" 4 | maintainer: "Louis Gesbert " 5 | authors: "Louis Gesbert " 6 | homepage: "https://github.com/AltGr/Camelus" 7 | bug-reports: "https://github.com/AltGr/Camelus/issues" 8 | dev-repo: "git+https://github.com/AltGr/Camelus.git" 9 | depends: [ 10 | "cohttp-lwt-unix" { < "2.0.0" } 11 | "dune" 12 | "git-unix" {>= "1.13" & < "2.0" | = "1.11.5" } 13 | "github" 14 | "github-unix" 15 | "opam-format" {>= "2.0.0~beta5"} 16 | "opam-solver" {>= "2.0.0~beta5"} 17 | "opam-state" { >= "2.0.1"} 18 | "tls" 19 | "yojson" 20 | ("ago" | ("utop")) 21 | ("fpath" | "abella") 22 | "lwt_ppx" { build } 23 | "fpath" 24 | ] 25 | build: ["dune" "build" "-p" name] 26 | pin-depends: [ 27 | ["github.3.1.0" "git+https://github.com/AltGr/ocaml-github#21efde3"] 28 | ["github-unix.3.1.0" "git+https://github.com/AltGr/ocaml-github#21efde3"] 29 | ] 30 | -------------------------------------------------------------------------------- /opam-ci.opam.locked: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "0.2" 3 | synopsis: "Automated checks and management for opam repositories on Github" 4 | maintainer: "Louis Gesbert " 5 | authors: "Louis Gesbert " 6 | homepage: "https://github.com/AltGr/Camelus" 7 | bug-reports: "https://github.com/AltGr/Camelus/issues" 8 | dev-repo: "git+https://github.com/AltGr/Camelus.git" 9 | depends: [ 10 | "cohttp-lwt-unix" 11 | "opam-format" {>= "2.0.0~beta5"} 12 | "opam-solver" {>= "2.0.0~beta5"} 13 | "opam-state" {>= "2.0.0~beta5"} 14 | "git-unix" {>= "1.11" & < "2.0"} 15 | "github-unix" 16 | "yojson" 17 | ] 18 | build: make 19 | name: "opam-ci" 20 | pin-depends: [ 21 | ["git-unix.1.11.2" "git+https://github.com/mirage/ocaml-git.git#master"] 22 | ["github.3.0.1" "git+https://github.com/rgrinberg/ocaml-github.git"] 23 | ["git-http.1.11.2" "git+https://github.com/mirage/ocaml-git.git#master"] 24 | ["git.1.11.2" "git+https://github.com/mirage/ocaml-git.git#master"] 25 | ["digestif.0.5.0" "git+https://github.com/mirage/digestif.git#link"] 26 | [ 27 | "angstrom.0.7.0" 28 | "git+https://github.com/dinosaure/angstrom.git#fix-peek-char" 29 | ] 30 | [ 31 | "ocamlfind.1.7.3" 32 | "http://download.camlcity.org/download/findlib-1.7.3.tar.gz" 33 | ] 34 | ] 35 | -------------------------------------------------------------------------------- /replay.ml: -------------------------------------------------------------------------------- 1 | #thread;; 2 | 3 | #require "camelus";; 4 | 5 | #require "lwt.ppx";; 6 | 7 | open Camelus_lib 8 | 9 | let conf = Conf.read (OpamFile.make (OpamFilename.of_string "opam-ci.conf")) 10 | 11 | let name = conf.Conf.name 12 | let token = conf.Conf.token 13 | 14 | let repo = { 15 | user = "ocaml"; 16 | name = "opam-repository"; 17 | auth = Some (name, Github.Token.to_string token); 18 | } 19 | 20 | let base_branch = "master" 21 | let dest_branch = "2.0.0" 22 | 23 | let get_pr num = 24 | Github.Monad.run @@ 25 | let open Github.Monad in 26 | Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= 27 | Github.Response.value 28 | 29 | open Lwt.Infix 30 | open Github_t 31 | 32 | let replay num = 33 | let%lwt gitstore = match%lwt RepoGit.get repo with 34 | | Ok r -> Lwt.return r 35 | | Error e -> Lwt.fail (Failure "Repository loading failed") 36 | in 37 | let%lwt p = get_pr num in 38 | let merge_sha = match p.pull_merged_at, p.pull_merge_commit_sha with 39 | | Some _, Some h -> h 40 | | _ -> failwith "No merge SHA found" 41 | in 42 | let merge_parent_sha = merge_sha^"^" in 43 | log "Upgrading branch from %s to %s" 44 | merge_parent_sha merge_sha; 45 | let%lwt new_branch = 46 | FormatUpgrade.run base_branch dest_branch 47 | merge_parent_sha merge_sha gitstore 48 | repo 49 | in 50 | match new_branch with 51 | | None -> Lwt.return_unit 52 | | Some (branch, msg) -> 53 | let title, message = 54 | match OpamStd.String.cut_at msg '\n' with 55 | | Some (t, m) -> t, Some (String.trim m) 56 | | None -> "Merge changes from 1.2 format repo", None 57 | in 58 | Github_comment.pull_request 59 | ~name ~token repo 60 | branch dest_branch 61 | ?message title 62 | 63 | let () = Lwt_main.run (replay 11570) 64 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## opam-ci: reports on repository pull-requests to guide merge decisions 2 | 3 | This bot runs as an HTTP service that wakes up through a GitHub webhook. It's 4 | based on cohttp (and lwt) for the server part, ocaml-git for checking out the 5 | states corresponding to the pull-request, opam-lib (and dose) for linting and 6 | checking installable packages, and ocaml-github to post back the reports. 7 | 8 | Dependencies: `cohttp`, `conduit`, `opam-lib`, `git`, `yojson`, `github`. The 9 | current version has been tested with: 10 | - camlzip 1.06 11 | - git 1.9.1 12 | - github 2.0.3 13 | - lwt 2.5.2 14 | - nocrypto 0.5.3 15 | - opam-lib pinned to the 1.3 branch at 833e5b22 16 | 17 | The program expects a `opam-ci.conf` in the working directory, with the 18 | following format: 19 | 20 | ``` 21 | name: "opam-ci" 22 | port: 8122 23 | token: "xxx" 24 | secret: "yyy" 25 | repo-user: "ocaml" 26 | repo-name: "opam" 27 | ``` 28 | 29 | The name and token correspond to the GitHub account and token to use (only 30 | public repository access is needed); `repo-user:` and `repo-name:` define the 31 | repository the service will be running on (here "ocaml/opam"). The port and 32 | secret should correspond to the webhook configuration, and the service is at 33 | `/opam-ci`, so your configuration in Github should look like: 34 | - http://opam.ocaml.org:8122/opam-ci 35 | - `secret` must be identical, it's used to authenticate requests coming from 36 | your repository on GitHub 37 | 38 | The repository is cloned (bare) under `name%repo.git/.git` in the current 39 | directory, _e.g._ `opam%opam-repository.git/.git`. 40 | 41 | NOTE: due to limitations of the current `ocaml-git`, cloning the repository may 42 | take up a lot of memory. To workaround, you can do it manually using `git`, but 43 | you also need to unpack: 44 | 45 | ``` 46 | cd opam%opam-repository.git/ 47 | git clone --bare https://github.com/ocaml/opam-repository.git .git 48 | mv .git/objects/pack/* . 49 | git unpack-objects <*.pack 50 | ``` 51 | -------------------------------------------------------------------------------- /camelus_replay.ml: -------------------------------------------------------------------------------- 1 | open Camelus_lib 2 | 3 | let conf = Conf.read (OpamFile.make (OpamFilename.of_string "opam-ci.conf")) 4 | 5 | let name = conf.Conf.name 6 | let token = conf.Conf.token 7 | 8 | let repo = { 9 | user = "ocaml"; 10 | name = "opam-repository"; 11 | auth = Some (name, Github.Token.to_string token); 12 | } 13 | 14 | let base_branch = "master" 15 | let dest_branch = "2.0.0" 16 | 17 | let get_pr num = 18 | Github.Monad.run @@ 19 | let open Github.Monad in 20 | Github.Pull.get ~user:repo.user ~repo:repo.name ~num () >|= 21 | Github.Response.value 22 | 23 | open Lwt.Infix 24 | open Github_t 25 | 26 | let replay_upgrade num = 27 | let%lwt gitstore = match%lwt RepoGit.get repo with 28 | | Ok r -> Lwt.return r 29 | | Error e -> Lwt.fail (Failure "Repository loading failed") 30 | in 31 | let%lwt p = get_pr num in 32 | let merge_sha = match p.pull_merged_at, p.pull_merge_commit_sha with 33 | | Some _, Some h -> h 34 | | _ -> failwith "No merge SHA found" 35 | in 36 | let merge_parent_sha = merge_sha^"^" in 37 | log "Upgrading branch from %s to %s" 38 | merge_parent_sha merge_sha; 39 | let%lwt new_branch = 40 | FormatUpgrade.run base_branch dest_branch 41 | merge_parent_sha merge_sha gitstore 42 | repo 43 | in 44 | match new_branch with 45 | | None -> Lwt.return_unit 46 | | Some (branch, msg) -> 47 | let title, message = 48 | match OpamStd.String.cut_at msg '\n' with 49 | | Some (t, m) -> t, Some (String.trim m) 50 | | None -> "Merge changes from 1.2 format repo", None 51 | in 52 | Github_comment.pull_request 53 | ~name ~token repo 54 | branch dest_branch 55 | ?message title 56 | 57 | let get_unchecked_pr () = 58 | let open Github.Monad in 59 | run @@ 60 | let open_prs = Github.Pull.for_repo ~token ~state:`Open ~user:repo.user ~repo:repo.name () in 61 | let res_stream = 62 | Github.Stream.map (fun pr -> 63 | let stream = Github.Issue.comments ~token ~user:repo.user ~repo:repo.name ~num:pr.pull_number () in 64 | Github.Stream.find (fun { issue_comment_user = u; _ } -> u.user_login = conf.Conf.name) stream >>= 65 | function | Some _ -> return [] 66 | | None -> return [pr.pull_number] 67 | ) open_prs 68 | in 69 | Github.Stream.to_list res_stream 70 | 71 | let replay_check nums = 72 | let%lwt gitstore = match%lwt RepoGit.get repo with 73 | | Ok r -> Lwt.return r 74 | | Error e -> Lwt.fail (Failure "Repository loading failed") 75 | in 76 | Lwt_list.iter_p (fun num -> 77 | let%lwt pr = get_pr num >|= fun p -> 78 | let get_repo b = { 79 | repo = 80 | (match b.branch_repo with 81 | | None -> repo 82 | | Some gr -> { 83 | user = gr.repository_owner.user_login; 84 | name = gr.repository_name; 85 | auth = None; 86 | }); 87 | ref = b.branch_ref; 88 | sha = b.branch_sha; 89 | } in { 90 | number = num; 91 | base = get_repo p.pull_base; 92 | head = get_repo p.pull_head; 93 | pr_user = p.pull_user.user_login; 94 | message = p.pull_title, p.pull_body; 95 | } 96 | in 97 | let%lwt report = PrChecks.run pr gitstore in 98 | Github_comment.push_report ~name ~token ~report pr ) 99 | nums 100 | 101 | let () = 102 | match Sys.argv.(1) with 103 | | "upgrade" -> 104 | let num = int_of_string Sys.argv.(2) in 105 | Lwt_main.run (replay_upgrade num) 106 | | "check" -> 107 | let num = int_of_string Sys.argv.(2) in 108 | Lwt_main.run (replay_check [num]) 109 | | "check-bunch" -> 110 | begin 111 | match Array.to_list Sys.argv with 112 | | [] | [_] -> assert false 113 | | _ :: _ :: prs -> 114 | let nums = List.rev_map int_of_string prs in 115 | Lwt_main.run (replay_check nums) 116 | end 117 | | "auto" -> Lwt_main.run begin get_unchecked_pr () >>= replay_check end 118 | | _ -> 119 | OpamConsole.msg "Usage: %s PR# or %s check-bunch PR#...\n" Sys.argv.(0) Sys.argv.(0); 120 | exit 2 121 | -------------------------------------------------------------------------------- /camelus_main.ml: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* *) 3 | (* Copyright (c) 2015 OCamlPro *) 4 | (* *) 5 | (* Permission to use, copy, modify, and distribute this software for any *) 6 | (* purpose with or without fee is hereby granted, provided that the above *) 7 | (* copyright notice and this permission notice appear in all copies. *) 8 | (* *) 9 | (* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES *) 10 | (* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF *) 11 | (* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR *) 12 | (* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES *) 13 | (* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN *) 14 | (* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF *) 15 | (* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 16 | (* *) 17 | (****************************************************************************) 18 | 19 | open Lwt.Infix 20 | open Camelus_lib 21 | 22 | let log fmt = OpamConsole.msg (fmt ^^ "\n%!") 23 | 24 | let () = Lwt.async_exception_hook := 25 | begin fun exn -> 26 | log "Event async failed: %s" (Printexc.to_string exn) 27 | end 28 | 29 | let handler conf gitstore = function 30 | | `Pr pr when List.mem `Pr_checker conf.Conf.roles -> 31 | (log "=> PR #%d received \ 32 | (onto %s/%s#%s from %s/%s#%s, commit %s over %s)" 33 | pr.number 34 | pr.base.repo.user pr.base.repo.name pr.base.ref 35 | pr.head.repo.user pr.head.repo.name pr.head.ref 36 | pr.head.sha pr.base.sha; 37 | try%lwt 38 | let%lwt report = PrChecks.run pr gitstore in 39 | Github_comment.push_report 40 | ~name:conf.Conf.name 41 | ~token:conf.Conf.token 42 | ~report 43 | pr 44 | with exn -> 45 | log "Check failed: %s" (Printexc.to_string exn); 46 | let%lwt _ = 47 | Github_comment.push_status 48 | ~name:conf.Conf.name ~token:conf.Conf.token pr 49 | ~text:"Could not complete" `Failure 50 | in 51 | Lwt.return_unit) 52 | | `Push p when List.mem `Push_upgrader conf.Conf.roles -> 53 | (log "=> Push received (head %s onto %s)" 54 | p.push_head p.push_ancestor; 55 | let auth = conf.Conf.name, Github.Token.to_string conf.Conf.token in 56 | let%lwt pr_branch = 57 | try%lwt 58 | FormatUpgrade.run conf.Conf.base_branch conf.Conf.dest_branch 59 | p.push_ancestor p.push_head gitstore 60 | { p.push_repo with auth = Some auth } 61 | with exn -> 62 | log "Upgrade commit failed: %s" (Printexc.to_string exn); 63 | Lwt.return None 64 | in 65 | match pr_branch with 66 | | None -> Lwt.return_unit 67 | | Some (branch, msg) -> 68 | let title, message = 69 | match OpamStd.String.cut_at msg '\n' with 70 | | Some (t, m) -> t, Some (String.trim m) 71 | | None -> "Merge changes from 1.2 format repo", None 72 | in 73 | try%lwt 74 | Github_comment.pull_request 75 | ~name:conf.Conf.name ~token:conf.Conf.token conf.Conf.repo 76 | branch conf.Conf.dest_branch 77 | ?message title 78 | with exn -> 79 | log "Pull request failed: %s" (Printexc.to_string exn); 80 | Lwt.return_unit) 81 | | _ -> Lwt.return_unit 82 | 83 | let () = 84 | Logs.(set_reporter (format_reporter ()); set_level (Some Info)); 85 | let conf = 86 | let f = if Array.length Sys.argv > 1 then Sys.argv.(1) else "opam-ci.conf" in 87 | let f = OpamFile.make (OpamFilename.of_string f) in 88 | try Conf.read f with e -> 89 | Printf.eprintf "Invalid conf file %s:\n%s\n" 90 | (OpamFile.to_string f) (Printexc.to_string e); 91 | exit 3 92 | in 93 | let event_stream, event_push = Lwt_stream.create () in 94 | let rec check_loop gitstore = 95 | match%lwt Lwt_stream.next event_stream with 96 | | exception Lwt_stream.Empty -> exit 0 97 | | exception exn -> 98 | log "Event handler failed: %s" (Printexc.to_string exn); 99 | Lwt.return_unit 100 | | event -> 101 | (* The checks are done concurrently *) 102 | Lwt.async (fun () -> handler conf gitstore event); 103 | check_loop gitstore 104 | in 105 | let handler event = 106 | let%lwt () = 107 | match event with 108 | | `Pr pr -> 109 | let%lwt _ = 110 | Github_comment.push_status 111 | ~name:conf.Conf.name ~token:conf.Conf.token pr 112 | ~text:"In progress" `Pending 113 | in 114 | Lwt.return_unit 115 | | _ -> 116 | Lwt.return_unit 117 | in 118 | Lwt.return (event_push (Some event)) 119 | in 120 | Lwt_main.run (Lwt.join [ 121 | (match%lwt RepoGit.get conf.Conf.repo with 122 | | Ok r -> check_loop r 123 | | Error e -> Lwt.fail (Failure "Repository loading failed")); 124 | Webhook_handler.server 125 | ~conf 126 | ~handler; 127 | ]) 128 | -------------------------------------------------------------------------------- /camelus_lib.ml: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* *) 3 | (* Copyright (c) 2015 OCamlPro *) 4 | (* *) 5 | (* Permission to use, copy, modify, and distribute this software for any *) 6 | (* purpose with or without fee is hereby granted, provided that the above *) 7 | (* copyright notice and this permission notice appear in all copies. *) 8 | (* *) 9 | (* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES *) 10 | (* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF *) 11 | (* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR *) 12 | (* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES *) 13 | (* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN *) 14 | (* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF *) 15 | (* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 16 | (* *) 17 | (****************************************************************************) 18 | 19 | open Lwt.Infix 20 | 21 | let log fmt = OpamConsole.msg (fmt ^^ "\n%!") 22 | 23 | let verbose = 24 | try Sys.getenv "CAMELUS_VERBOSE" <> "" 25 | with Not_found -> false 26 | 27 | type repo = { 28 | user: string; 29 | name: string; 30 | auth: (string * string) option; (* user, token *) 31 | } 32 | 33 | type full_ref = { 34 | repo: repo; 35 | ref: string; 36 | sha: string; 37 | } 38 | 39 | type pull_request = { 40 | number: int; 41 | base: full_ref; 42 | head: full_ref; 43 | pr_user: string; 44 | message: string * string; 45 | } 46 | 47 | type push_event = { 48 | push_repo: repo; 49 | push_head: string; 50 | push_ancestor: string; 51 | } 52 | 53 | module FdPool = struct 54 | 55 | let max_count = 50 56 | let curr_count = ref 0 57 | 58 | let c : unit Lwt_condition.t = Lwt_condition.create () 59 | 60 | let fd_use () = 61 | if !curr_count < max_count 62 | then ( incr curr_count; Lwt.return_unit ) 63 | else ( Lwt_condition.wait c >>= fun () -> incr curr_count; Lwt.return_unit ) 64 | 65 | let fd_free () = 66 | decr curr_count; Lwt_condition.signal c () 67 | 68 | let with_fd (f : unit -> 'a Lwt.t) : 'a Lwt.t = 69 | begin fd_use () >>= f end 70 | [%lwt.finally fd_free (); Lwt.return_unit] 71 | 72 | end 73 | 74 | module RepoGit = struct 75 | 76 | module M = OpamStd.String.Map 77 | 78 | type t = repo 79 | 80 | let github_repo_string repo = 81 | Printf.sprintf "https://%sgithub.com/%s/%s.git" 82 | (match repo.auth with 83 | | None -> "" 84 | | Some (user, token) -> Printf.sprintf "%s:%s@" user token) 85 | repo.user repo.name 86 | 87 | let github_repo repo = 88 | Uri.of_string @@ github_repo_string repo 89 | 90 | 91 | let local_mirror repo = 92 | Fpath.v (Fmt.strf "./%s%%%s.git" repo.user repo.name) 93 | 94 | let write_lock = Lwt_mutex.create () 95 | 96 | let git 97 | ?(can_fail=false) ?(silent_fail=false) ?(verbose=verbose) ?(writing=false) 98 | repo ?env ?input args = 99 | let cmd = Array.of_list ("git" :: "-C" :: (Fpath.to_string (local_mirror repo)) :: args) in 100 | let str_cmd = 101 | OpamStd.List.concat_map " " 102 | (fun s -> if String.contains s ' ' then Printf.sprintf "%S" s else s) 103 | (Array.to_list cmd) in 104 | if verbose then log "+ %s" str_cmd; 105 | let env = 106 | match env with 107 | | None -> None 108 | | Some e -> Some (Array.append (Unix.environment ()) e) 109 | in 110 | let git_call () = 111 | let p = Lwt_process.open_process ("git", cmd) ?env in 112 | let ic = p#stdout in 113 | let oc = p#stdin in 114 | let%lwt r = ( 115 | let%lwt () = (match input with 116 | | None -> Lwt.return_unit 117 | | Some s -> Lwt_io.write oc s 118 | ) [%lwt.finally Lwt_io.close oc] 119 | in 120 | Lwt_io.read ic 121 | ) [%lwt.finally Lwt_io.close ic ] 122 | in 123 | if verbose then 124 | List.iter (fun s -> print_string "- "; print_endline s) 125 | (OpamStd.String.split r '\n'); 126 | match%lwt p#close with 127 | | Unix.WEXITED 0 -> Lwt.return r 128 | | Unix.WEXITED i -> 129 | if not silent_fail then log "ERROR: command %s returned %d" str_cmd i; 130 | if can_fail then Lwt.return r else Lwt.fail (Failure str_cmd) 131 | | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> 132 | log "ERROR: command %s interrupted" str_cmd; 133 | Lwt.fail (Failure str_cmd) 134 | in 135 | FdPool.with_fd @@ if writing then (fun () -> Lwt_mutex.with_lock write_lock git_call) else git_call 136 | 137 | let get repo = 138 | OpamSystem.mkdir (Fpath.to_string (local_mirror repo)); 139 | let%lwt _ = git ~writing:true repo ["init"] in 140 | let%lwt _ = git ~writing:true repo ["config"; "receive.denyCurrentBranch"; "ignore"] in 141 | Lwt.return (Ok repo) 142 | 143 | let get_file t sha path = 144 | try%lwt 145 | git t ~verbose:false ~silent_fail:true ["show"; sha ^":"^ path] 146 | >|= OpamStd.Option.some 147 | with Failure _ -> Lwt.return None 148 | 149 | let get_file_exn t sha path = 150 | match%lwt get_file t sha path with 151 | | Some f -> Lwt.return f 152 | | None -> 153 | log "GET_FILE %s: not found" path; 154 | Lwt.fail Not_found 155 | 156 | let get_blob t sha = 157 | try%lwt 158 | git t ~verbose:false ~silent_fail:false ["cat-file"; "blob"; sha] 159 | >|= OpamStd.Option.some 160 | with Failure _ -> Lwt.return_none 161 | 162 | let get_blob_exn t sha = 163 | match%lwt get_blob t sha with 164 | | Some f -> Lwt.return f 165 | | None -> log "GET_BLOB %s: not found" sha; Lwt.fail Not_found 166 | 167 | let branch_reference name = "refs/heads/" ^ name 168 | 169 | let pr_branch pr = "pr/" ^ (string_of_int pr.number) 170 | 171 | let get_branch t branch = 172 | git t ["rev-parse"; branch_reference branch] 173 | >|= String.trim 174 | 175 | let set_branch t name commit_hash = 176 | git t ["branch"; "-f"; branch_reference name; commit_hash] 177 | >|= ignore 178 | 179 | let fetch t ?(manual_branches=[]) ?(branches=[]) repo = 180 | let remote b = "refs/remotes/" ^ repo.user ^ "/" ^ b in 181 | let b = 182 | manual_branches @ 183 | List.map (fun b -> "+" ^ branch_reference b ^ ":" ^ remote b) branches 184 | in 185 | let%lwt _ = git ~writing:true t ("fetch" :: Uri.to_string (github_repo repo) :: b) in 186 | Lwt_list.map_s (fun b -> 187 | log "fetched %s" b; 188 | git t ["rev-parse"; remote b] >|= String.trim) 189 | branches 190 | 191 | let fetch_pr pull_request t = 192 | let%lwt _ = 193 | fetch t ~branches:[pull_request.base.ref] pull_request.base.repo 194 | in 195 | log "fetched upstream"; 196 | let%lwt _head_fetch = 197 | let prn = string_of_int pull_request.number in 198 | fetch t ~manual_branches:[ "+pull/" ^ prn ^"/head:pr/" ^ prn ] pull_request.base.repo 199 | in 200 | log "fetched user pr"; 201 | Lwt.return_unit 202 | 203 | let push ?(force=false) t branch repo = 204 | git t ["push"; Uri.to_string (github_repo repo); 205 | (if force then "+" else "") ^ 206 | branch_reference branch ^":"^ branch] 207 | >|= ignore 208 | 209 | let common_ancestor pull_request t = 210 | git t ["merge-base"; pull_request.base.sha; pull_request.head.sha ] 211 | >|= String.trim 212 | 213 | let changed_files base head t = 214 | git t ["diff-tree"; "-r"; "--name-only"; "--diff-filter=ACMRD"; base; head] 215 | >>= fun s -> 216 | let paths = OpamStd.String.split s '\n' in 217 | Lwt_list.map_s (fun p -> get_file t head p >|= fun c -> p, c) paths 218 | 219 | let opam_hash_and_file_re = 220 | Re.(compile @@ seq [ 221 | bos; 222 | repn digit 6 (Some 6); 223 | str " blob "; 224 | group @@ repn xdigit 40 (Some 40); 225 | char '\t'; 226 | group @@ 227 | seq 228 | [ 229 | str "packages/"; 230 | rep1 @@ diff any (char '/'); 231 | opt @@ seq [char '/'; rep1 @@ diff any (char '/')]; 232 | str "/opam"; 233 | ]; 234 | eos; 235 | ]) 236 | 237 | let opam_files t sha = 238 | git t ["ls-tree"; "-r"; sha; "packages/"] 239 | >|= (fun s -> OpamStd.String.split s '\n') 240 | >>= Lwt_list.filter_map_p (fun s -> 241 | match Re.exec_opt opam_hash_and_file_re s with 242 | | None -> Lwt.return_none 243 | | Some g -> 244 | let hash = Re.Group.get g 1 and f = Re.Group.get g 2 in 245 | let filename = OpamFile.make (OpamFilename.of_string f) in 246 | try%lwt 247 | let%lwt opam = get_blob_exn t hash in 248 | Lwt.return_some (OpamFile.OPAM.read_from_string ~filename opam) 249 | with _ -> Lwt_io.printlf "failed on %s" f >>= fun () -> Lwt.return_none) 250 | 251 | 252 | (* returns a list (rel_filename * contents) *) 253 | let extra_files t sha package = 254 | let ( / ) a b = a ^ "/" ^ b in 255 | let dir = 256 | "packages" / 257 | OpamPackage.name_to_string package / 258 | OpamPackage.to_string package / 259 | "files" / "" 260 | in 261 | git t ["ls-tree"; "-r"; "--name-only"; sha; dir] 262 | >|= (fun s -> OpamStd.String.split s '\n') 263 | >|= List.sort compare 264 | >|= List.rev 265 | >>= Lwt_list.map_s (fun f -> 266 | let%lwt contents = get_file_exn t sha f in 267 | Lwt.return (OpamStd.String.remove_prefix ~prefix:dir f, contents)) 268 | 269 | end 270 | 271 | module Git = struct 272 | module User = struct 273 | type user = { 274 | name: string; 275 | email: string; 276 | date: int64 * unit option; 277 | } 278 | end 279 | end 280 | 281 | module FormatUpgrade = struct 282 | 283 | let git_identity () = { 284 | Git.User. 285 | name = "Camelus"; 286 | email = "opam-commits@lists.ocaml.org"; 287 | date = Int64.of_float (Unix.time ()), None; 288 | } 289 | 290 | let get_updated_opam commit gitstore nv = 291 | let opam_dir = 292 | Printf.sprintf "packages/%s/%s/" 293 | (OpamPackage.name_to_string nv) 294 | (OpamPackage.to_string nv) 295 | in 296 | let opam_file = opam_dir^"opam" in 297 | let%lwt opam_str = RepoGit.get_file_exn gitstore commit opam_file in 298 | let%lwt url_str = RepoGit.get_file gitstore commit (opam_dir^"url") in 299 | let%lwt descr_str = RepoGit.get_file gitstore commit (opam_dir^"descr") in 300 | let opam = 301 | OpamFile.OPAM.read_from_string 302 | ~filename:(OpamFile.make (OpamFilename.of_string opam_file)) 303 | opam_str 304 | in 305 | let opam = match descr_str with 306 | | None -> opam 307 | | Some d -> 308 | OpamFile.OPAM.with_descr (OpamFile.Descr.read_from_string d) opam 309 | in 310 | let opam = match url_str with 311 | | None -> opam 312 | | Some u -> 313 | OpamFile.OPAM.with_url (OpamFile.URL.read_from_string u) opam 314 | in 315 | let opam = OpamFormatUpgrade.opam_file ~quiet:true opam in 316 | let%lwt extra_files = 317 | RepoGit.extra_files gitstore commit nv >>= 318 | Lwt_list.map_s (fun (f, contents) -> 319 | Lwt.return 320 | (OpamFilename.Base.of_string f, 321 | OpamHash.compute_from_string contents)) 322 | in 323 | let opam = OpamFile.OPAM.with_extra_files extra_files opam in 324 | let opam_str = 325 | OpamFile.OPAM.to_string_with_preserved_format 326 | ~format_from_string:opam_str 327 | (OpamFile.make (OpamFilename.of_string opam_file)) 328 | opam 329 | in 330 | Lwt.return opam_str 331 | 332 | module CompilerConversion = struct 333 | (* Taken from OpamAdminRepoUpgrade ; should be generalised and called *) 334 | open OpamStd.Option.Op 335 | open OpamProcess.Job.Op 336 | 337 | let cache_file : string list list OpamFile.t = 338 | OpamFile.make @@ 339 | OpamFilename.of_string "~/.cache/opam-compilers-to-packages/url-hashes" 340 | 341 | let get_url_md5, save_cache = 342 | let url_md5 = Hashtbl.create 187 in 343 | let () = 344 | OpamFile.Lines.read_opt cache_file +! [] |> List.iter @@ function 345 | | [url; md5] -> 346 | Hashtbl.add url_md5 (OpamUrl.of_string url) (OpamHash.of_string md5) 347 | | _ -> failwith "Bad cache, run 'opam admin upgrade --clear-cache'" 348 | in 349 | (fun url -> 350 | try Done (Some (Hashtbl.find url_md5 url)) 351 | with Not_found -> 352 | OpamFilename.with_tmp_dir_job @@ fun dir -> 353 | OpamProcess.Job.ignore_errors ~default:None 354 | (fun () -> 355 | OpamDownload.download ~overwrite:false url dir @@| fun f -> 356 | let hash = OpamHash.compute (OpamFilename.to_string f) in 357 | Hashtbl.add url_md5 url hash; 358 | Some hash)), 359 | (fun () -> 360 | Hashtbl.fold 361 | (fun url hash l -> [OpamUrl.to_string url; OpamHash.to_string hash]::l) 362 | url_md5 [] |> 363 | OpamFile.Lines.write cache_file) 364 | 365 | let opam_of_comp comp_name comp descr = 366 | let nv = 367 | match OpamStd.String.cut_at comp_name '+' with 368 | | None -> 369 | OpamPackage.create (OpamPackage.Name.of_string "ocaml-base-compiler") 370 | (OpamPackage.Version.of_string comp_name) 371 | | Some (version,variant) -> 372 | OpamPackage.create (OpamPackage.Name.of_string "ocaml-variants") 373 | (OpamPackage.Version.of_string (version^"+"^variant)) 374 | in 375 | let opam = 376 | OpamFormatUpgrade.comp_file ~package:nv ?descr comp |> 377 | OpamFile.OPAM.with_conflict_class 378 | [OpamPackage.Name.of_string "ocaml-core-compiler"] 379 | in 380 | let opam = 381 | match OpamFile.OPAM.url opam with 382 | | Some urlf when OpamFile.URL.checksum urlf = [] -> 383 | (match OpamProcess.Job.run (get_url_md5 (OpamFile.URL.url urlf)) with 384 | | None -> 385 | Printf.ksprintf failwith "Could not get the archive of %s." 386 | (OpamPackage.to_string nv) 387 | | Some hash -> 388 | OpamFile.OPAM.with_url (OpamFile.URL.with_checksum [hash] urlf) 389 | opam) 390 | | _ -> opam 391 | in 392 | let patches = OpamFile.Comp.patches comp in 393 | if patches <> [] then 394 | log "Fetching patches of %s to check their hashes...\n" 395 | (OpamPackage.to_string nv); 396 | let extra_sources = 397 | (* Download them just to get their MD5 *) 398 | OpamParallel.map 399 | ~jobs:3 400 | ~command:(fun url -> 401 | get_url_md5 url @@| function 402 | | Some md5 -> url, md5 403 | | None -> 404 | Printf.ksprintf failwith 405 | "Could not get patch file for %s from %s, skipping" 406 | (OpamPackage.to_string nv) (OpamUrl.to_string url)) 407 | (OpamFile.Comp.patches comp) 408 | in 409 | OpamFile.OPAM.with_extra_sources 410 | (List.map (fun (url, hash) -> 411 | OpamFilename.Base.of_string (OpamUrl.basename url), 412 | OpamFile.URL.create ~checksum:[hash] url) 413 | extra_sources) 414 | opam 415 | 416 | end 417 | 418 | let get_compiler_opam commit gitstore comp_name = 419 | let bname = 420 | Printf.sprintf "compilers/%s/%s/%s" 421 | (match OpamStd.String.cut_at comp_name '+' 422 | with Some (v,_) -> v | None -> comp_name) 423 | comp_name comp_name 424 | in 425 | let filename = bname^".comp" in 426 | let%lwt comp_str = RepoGit.get_file_exn gitstore commit filename in 427 | let%lwt descr_str = RepoGit.get_file gitstore commit (bname^".descr") in 428 | let comp = 429 | OpamFile.Comp.read_from_string 430 | ~filename:(OpamFile.make (OpamFilename.of_string filename)) 431 | comp_str 432 | in 433 | let descr = 434 | OpamStd.Option.map OpamFile.Descr.read_from_string descr_str 435 | in 436 | let opam = 437 | CompilerConversion.opam_of_comp comp_name comp descr 438 | in 439 | let opam_str = 440 | OpamFile.OPAM.write_to_string 441 | (opam 442 | |> OpamFile.OPAM.with_name_opt None 443 | |> OpamFile.OPAM.with_version_opt None) 444 | ^"\n" 445 | in 446 | Lwt.return (OpamFile.OPAM.package opam, opam_str) 447 | 448 | let pkg_of_comp c = 449 | let ocaml_official_pkgname = OpamPackage.Name.of_string "ocaml-base-compiler" in 450 | let ocaml_variants_pkgname = OpamPackage.Name.of_string "ocaml-variants" in 451 | match OpamStd.String.cut_at c '+' with 452 | | None -> 453 | OpamPackage.create ocaml_official_pkgname 454 | (OpamPackage.Version.of_string c) 455 | | Some (version,variant) -> 456 | OpamPackage.create ocaml_variants_pkgname 457 | (OpamPackage.Version.of_string (version^"+"^variant)) 458 | 459 | let get_updated_subtree commit gitstore changed_files = 460 | let compilers, packages, files, removed = 461 | List.fold_left (fun (compilers, packages, files, removed) (f, contents) -> 462 | try Scanf.sscanf f "compilers/%_s@/%s@/" 463 | (fun s -> 464 | if contents = None then 465 | compilers, packages, files, 466 | OpamPackage.Set.add (pkg_of_comp s) removed 467 | else 468 | OpamStd.String.Set.add s compilers, 469 | packages, files, removed) 470 | with Scanf.Scan_failure _ -> try 471 | Scanf.sscanf f "packages/%_s@/%s@/%s@/" 472 | (fun s -> function 473 | | "opam" when contents = None -> 474 | compilers, packages, files, 475 | OpamPackage.Set.add (OpamPackage.of_string s) removed 476 | | "opam" | "url" | "descr" -> 477 | compilers, 478 | OpamPackage.Set.add (OpamPackage.of_string s) packages, 479 | files, removed 480 | | "files" -> 481 | compilers, packages, 482 | OpamStd.String.Map.add f contents files, 483 | removed 484 | | _ -> compilers, packages, files, removed) 485 | with Scanf.Scan_failure _ -> compilers, packages, files, removed) 486 | (OpamStd.String.Set.empty, 487 | OpamPackage.Set.empty, 488 | OpamStd.String.Map.empty, 489 | OpamPackage.Set.empty) 490 | changed_files 491 | in 492 | let%lwt compiler_packages = 493 | Lwt_list.fold_left_s (fun acc comp_name -> 494 | let%lwt nv, opam = get_compiler_opam commit gitstore comp_name in 495 | Lwt.return (OpamPackage.Map.add nv opam acc)) 496 | OpamPackage.Map.empty 497 | (OpamStd.String.Set.elements compilers) 498 | in 499 | let%lwt upgraded_packages = 500 | Lwt_list.fold_left_s (fun acc nv -> 501 | try%lwt 502 | let%lwt opam = get_updated_opam commit gitstore nv in 503 | Lwt.return (OpamPackage.Map.add nv opam acc) 504 | with Not_found -> Lwt.return acc) 505 | compiler_packages 506 | (OpamPackage.Set.elements packages) 507 | in 508 | let pkg_filename nv = 509 | Printf.sprintf "packages/%s/%s/opam" 510 | (OpamPackage.name_to_string nv) 511 | (OpamPackage.to_string nv) 512 | in 513 | Lwt.return @@ 514 | (OpamPackage.keys upgraded_packages, 515 | removed, 516 | OpamPackage.Map.fold (fun nv opam -> 517 | OpamStd.String.Map.add (pkg_filename nv) (Some opam)) 518 | upgraded_packages @@ 519 | OpamPackage.Set.fold (fun nv -> 520 | OpamStd.String.Map.add (pkg_filename nv) None) 521 | removed @@ 522 | files) 523 | 524 | (* 525 | let rec add_file_to_tree gitstore tree path contents = 526 | let add_to_tree entry t = 527 | let name = entry.S.Value.Tree.name in 528 | S.Value.Tree.of_list 529 | (entry :: 530 | List.filter (fun e -> e.S.Value.Tree.name <> name) 531 | (S.Value.Tree.to_list t)) 532 | in 533 | match path with 534 | | [] -> Lwt.fail (Failure "Empty path") 535 | | [file] -> 536 | (match%lwt 537 | S.write gitstore 538 | (S.Value.blob (S.Value.Blob.of_string contents)) 539 | with 540 | | Ok (hash, i) -> 541 | let entry = { S.Value.Tree.perm = `Normal; name = file; node = hash } in 542 | Lwt.return (add_to_tree entry tree) 543 | | Error s -> Lwt.fail (Failure "Could not write new blob to git")) 544 | | dir::path -> 545 | let subtree = 546 | try 547 | Some (List.find 548 | (fun e -> 549 | e.S.Value.Tree.name = dir && e.S.Value.Tree.perm = `Dir) 550 | (S.Value.Tree.to_list tree)).S.Value.Tree.node 551 | with Not_found -> None 552 | in 553 | let%lwt subtree = 554 | match subtree with 555 | | Some h -> RepoGit.get_tree gitstore h 556 | | None -> Lwt.return (S.Value.Tree.of_list []) 557 | in 558 | let%lwt subtree = add_file_to_tree gitstore subtree path contents in 559 | match%lwt S.write gitstore (S.Value.tree subtree) with 560 | | Ok (hash, _) -> 561 | let entry = { S.Value.Tree.perm = `Dir; name = dir; node = hash } in 562 | Lwt.return (add_to_tree entry tree) 563 | | Error e -> Lwt.fail (Failure "Could not write new subtree") 564 | 565 | let get ~err x = 566 | match%lwt x with 567 | | Error e -> Lwt.fail (Failure (Fmt.strf "%a" err e)) 568 | | Ok (x, _) -> Lwt.return x 569 | *) 570 | let gen_upgrade_commit 571 | ~merge changed_files head onto gitstore author message = 572 | let%lwt packages, removed_packages, replace_files = 573 | get_updated_subtree head gitstore changed_files 574 | in 575 | if OpamPackage.Set.(is_empty packages && is_empty removed_packages) && 576 | OpamStd.String.Map.is_empty replace_files 577 | then Lwt.return None 578 | else 579 | let%lwt _ = 580 | RepoGit.git gitstore 581 | ["reset"; "-q"; "--mixed"; if merge then onto else head] 582 | in 583 | let%lwt () = 584 | Lwt_list.iter_s (fun (path, contents) -> 585 | match contents with 586 | | Some contents -> 587 | let%lwt hash = 588 | RepoGit.git gitstore ["hash-object"; "-w"; "--stdin"] ~input:contents 589 | >|= String.trim 590 | in 591 | let%lwt _ = 592 | RepoGit.git gitstore 593 | ["update-index"; "--ignore-missing"; "--add"; 594 | "--cacheinfo"; "100644,"^hash^","^path] 595 | in 596 | Lwt.return_unit 597 | | None -> 598 | let%lwt _ = 599 | RepoGit.git gitstore 600 | ["update-index"; "--ignore-missing"; "--remove"; "--"; path] 601 | in 602 | Lwt.return_unit) 603 | (OpamStd.String.Map.bindings replace_files) 604 | in 605 | let%lwt tree = RepoGit.git gitstore ["write-tree"] >|= String.trim in 606 | let committer = git_identity () in 607 | let env = [| 608 | "GIT_AUTHOR_NAME="^ author.Git.User.name; 609 | "GIT_AUTHOR_EMAIL="^ author.Git.User.email; 610 | "GIT_COMMITTER_NAME="^ committer.Git.User.name; 611 | "GIT_COMMITTER_EMAIL="^ committer.Git.User.email; 612 | |] in 613 | let message = 614 | message (OpamPackage.Set.elements 615 | (OpamPackage.Set.union packages removed_packages)) 616 | in 617 | RepoGit.git gitstore ~env 618 | ("commit-tree" :: 619 | "-m" :: message :: 620 | (if merge then ["-p"; onto] else []) @ 621 | [ "-p"; head; 622 | tree ]) 623 | >|= String.trim 624 | >|= fun hash -> Some (hash, message) 625 | 626 | (** We have conflicts if [onto] was changed in the meantime, i.e. the rewrite 627 | of [ancestor] doesn't match what we have at the current [onto]. This is 628 | the case where we don't want to force an overwrite *) 629 | let check_for_conflicts changed_files ancestor onto gitstore = 630 | let%lwt changed_files_on_ancestor = 631 | Lwt_list.map_s (fun (f, _) -> 632 | RepoGit.get_file gitstore ancestor f >|= fun c -> f, c) 633 | changed_files 634 | in 635 | let%lwt _packages, _removed, rewritten_ancestor_tree = 636 | get_updated_subtree ancestor gitstore 637 | changed_files_on_ancestor 638 | in 639 | let rec changed = function 640 | | (path, contents) :: r -> 641 | let%lwt c = RepoGit.get_file gitstore onto path in 642 | if c <> contents then 643 | (log "Conflict on %s:\n<<<<<<\n%s======\n%s>>>>>>" path 644 | (OpamStd.Option.to_string (fun s -> s) contents) 645 | (OpamStd.Option.to_string (fun s -> s) c); 646 | changed r >>= fun acc -> Lwt.return (path::acc)) 647 | else 648 | changed r 649 | | [] -> Lwt.return [] 650 | in 651 | changed (OpamStd.String.Map.bindings rewritten_ancestor_tree) 652 | 653 | let run base_branch onto_branch ancestor head_hash gitstore repo = 654 | log "Format upgrade: %s to %s" base_branch onto_branch; 655 | let%lwt _head_hash, onto_hash = 656 | match%lwt 657 | RepoGit.fetch 658 | ~branches:[base_branch; onto_branch] 659 | gitstore repo 660 | with 661 | | [head_hash; onto_hash] -> Lwt.return (head_hash, onto_hash) 662 | | _ -> Lwt.fail (Failure "Branch fetch failed") 663 | in 664 | (* assert (head = head_hash); *) 665 | (* let%lwt remote_onto = 666 | * try Lwt.return (List.assoc (RepoGit.branch_reference onto_branch) refs) 667 | * with Not_found -> Lwt.fail (Failure ("Branch "^onto_branch^" not found")) 668 | * in *) 669 | (* let%lwt remote_onto = 670 | * RepoGit.get_branch gitstore ("origin/"^onto_branch) 671 | * in *) 672 | log "Fetched new commits: head %s onto %s" head_hash onto_hash; 673 | (* let%lwt _ = 674 | * RepoGit.set_branch gitstore onto_branch remote_onto 675 | * in 676 | * log "Updated branch"; *) 677 | try%lwt 678 | (* let%lwt onto_head = RepoGit.get_commit gitstore onto_hash in 679 | * let%lwt head_commit = RepoGit.get_commit gitstore head_hash in *) 680 | let author = git_identity () in 681 | log "Rewriting commit %s (and possible parents)" (*" by %s"*) 682 | head_hash (* (S.Value.Commit.author head_commit).Git.User.name *); 683 | let%lwt changed_files = 684 | RepoGit.changed_files ancestor head_hash gitstore 685 | in 686 | let%lwt conflicts = 687 | check_for_conflicts changed_files ancestor onto_hash gitstore 688 | in 689 | let rec firstn n = if n <= 0 then fun _ -> ["..."] else function 690 | | x::r -> x::firstn (n-1) r 691 | | [] -> [] 692 | in 693 | let message packages = 694 | if conflicts <> [] then 695 | Printf.sprintf 696 | "Partial format upgrade (%s)\n\n\ 697 | Update done by Camelus based on opam-lib %s\n\ 698 | This might overwrite changes done on the current %s branch, so it \ 699 | was not automatically merged. Conflicting files:\n%s" 700 | (String.concat ", " 701 | (firstn 5 (List.map OpamPackage.to_string packages))) 702 | OpamVersion.(to_string (full ())) 703 | onto_branch 704 | (OpamStd.Format.itemize (fun s -> s) conflicts) 705 | else 706 | Printf.sprintf 707 | "Format upgrade merge (%s)\n\n\ 708 | Merge done by Camelus based on opam-lib %s" 709 | (OpamStd.List.concat_map ", " OpamPackage.to_string packages) 710 | OpamVersion.(to_string (full ())) 711 | in 712 | match%lwt 713 | gen_upgrade_commit ~merge:true 714 | changed_files head_hash onto_hash gitstore author message 715 | with 716 | | None -> 717 | log "No changes needed to %s branch" onto_branch; 718 | Lwt.return None 719 | | Some (commit_hash, msg) -> 720 | let dest_branch = 721 | if conflicts <> [] then "camelus-"^(String.sub head_hash 0 8) 722 | else onto_branch 723 | in 724 | let%lwt _ = RepoGit.set_branch gitstore dest_branch commit_hash in 725 | log "Pushing new commit %s onto %s (there are %sconflicts)" 726 | ((* S.Hash.to_hex *)commit_hash) dest_branch 727 | (if conflicts <> [] then "" else "no "); 728 | let%lwt () = 729 | RepoGit.push ~force:(conflicts<>[]) gitstore dest_branch repo 730 | in 731 | log "Upgrade done"; 732 | Lwt.return (if conflicts <> [] then Some (dest_branch, msg) else None) 733 | with e -> 734 | log "Upgrade and push to branch %s failed: %s\n%s" onto_branch 735 | (Printexc.to_string e) 736 | (Printexc.get_backtrace ()); 737 | Lwt.return None 738 | 739 | end 740 | 741 | module PrChecks = struct 742 | 743 | let pkg_to_string p = Printf.sprintf "`%s`" (OpamPackage.to_string p) 744 | 745 | let max_items_in_post = 50 746 | 747 | let changed_opam_files ancestor head gitstore = 748 | let%lwt files = RepoGit.changed_files ancestor head gitstore in 749 | Lwt.return @@ 750 | let opamfiles, others = List.partition (fun (s,c) -> 751 | match c with 752 | | Some c when 753 | OpamStd.String.starts_with ~prefix:"packages/" s && 754 | OpamStd.String.ends_with ~suffix:"/opam" s 755 | -> true 756 | | _ -> false) 757 | files 758 | in 759 | List.map (function (s, Some c) -> (OpamFilename.of_string s, c) | (_,None) -> assert false) opamfiles, 760 | List.map fst others 761 | 762 | let lint head gitstore opam_files = 763 | let%lwt lint = 764 | Lwt_list.map_s (fun (file,contents) -> 765 | let nv = 766 | match OpamPackage.of_filename file with 767 | | Some nv -> nv 768 | | None -> OpamPackage.of_string "invalid-package-name.v" 769 | in 770 | let%lwt check_extra_files = 771 | RepoGit.extra_files gitstore head nv >>= 772 | Lwt_list.map_s (fun (f, contents) -> 773 | Lwt.return 774 | (OpamFilename.Base.of_string f, 775 | fun h -> 776 | OpamHash.compute_from_string ~kind:(OpamHash.kind h) 777 | contents 778 | = h)) 779 | in 780 | let r, opamopt = 781 | OpamFileTools.lint_string ~check_extra_files 782 | (OpamFile.make file) 783 | contents 784 | in 785 | Lwt.return (file, r, opamopt)) 786 | opam_files 787 | in 788 | let unwanted_warns = [] in 789 | let lint = 790 | List.map (fun (f,r,o) -> 791 | f, List.filter (fun (n,_,_) -> not (List.mem n unwanted_warns)) r, o) 792 | lint 793 | in 794 | let passed, failed = 795 | List.partition (function _, [], Some _ -> true | _ -> false) lint 796 | in 797 | let errors, warnings = 798 | List.partition (fun (_, we, _) -> 799 | List.exists (function _, `Error, _ -> true | _ -> false) we) 800 | failed 801 | in 802 | let title = 803 | if errors <> [] then 804 | "##### :cloud_with_lightning: opam-lint errors" 805 | else if warnings <> [] then 806 | "##### :sun_behind_small_cloud: opam-lint warnings" 807 | else if passed <> [] then 808 | "##### :sunny: All lint checks passed" 809 | else 810 | "##### :sunny: No new or changed opam files" 811 | in 812 | let title = 813 | Printf.sprintf "%s %s\n\n" title head 814 | in 815 | let pkgname (f,_,_) = 816 | OpamStd.Option.Op.( 817 | (OpamPackage.of_filename f >>| pkg_to_string) 818 | +! OpamFilename.to_string f) 819 | in 820 | let pass = 821 | OpamStd.List.concat_map ", " 822 | ~nil:"" 823 | ~left:"* These packages passed lint tests: " 824 | ~right:"\n" 825 | pkgname passed 826 | in 827 | let warns = 828 | if List.length warnings + List.length errors > max_items_in_post then 829 | OpamStd.List.concat_map 830 | ~left:"* **Packages with warnings**: " ~right:"\n" ", " 831 | pkgname warnings 832 | else 833 | OpamStd.List.concat_map "\n\n" 834 | (fun ((_, warns, _) as fe) -> 835 | Printf.sprintf "* **%s** has some warnings:\n\n%s\n" 836 | (pkgname fe) 837 | (OpamStd.Format.itemize ~bullet:" * " 838 | (fun (num,_,msg) -> 839 | Printf.sprintf "**warning %d**: %s" num msg) 840 | warns)) 841 | warnings 842 | in 843 | let errs = 844 | if List.length errors > max_items_in_post then 845 | OpamStd.List.concat_map 846 | ~left:"* **Packages with errors**: " ~right:"\n" ", " 847 | pkgname errors 848 | else 849 | OpamStd.List.concat_map "\n\n" 850 | (fun ((_, we, _) as fe) -> 851 | Printf.sprintf "* **%s** has errors:\n\n%s\n" 852 | (pkgname fe) 853 | (OpamStd.Format.itemize ~bullet:" * " 854 | (fun (num,kind,msg) -> 855 | let kind = match kind with 856 | | `Warning -> "warning" 857 | | `Error -> "error" 858 | in 859 | Printf.sprintf "**%s %d:** %s" kind num msg) 860 | we)) 861 | errors 862 | in 863 | let status = 864 | if errors <> [] then `Errors (List.map pkgname errors) 865 | else if warnings <> [] then `Warnings (List.map pkgname warnings) 866 | else `Passed 867 | in 868 | Lwt.return 869 | (status, String.concat "" [title; errs; warns; pass]) 870 | 871 | let get_universe gitstore sha ~name = 872 | let%lwt opams = RepoGit.opam_files gitstore sha in 873 | log "opam files at %s %s: %d" name sha (List.length opams); 874 | let open OpamTypes in 875 | let m = 876 | List.fold_left (fun m o -> 877 | let nv = 878 | OpamPackage.create 879 | (OpamFile.OPAM.name o) (OpamFile.OPAM.version o) 880 | in 881 | OpamPackage.Map.add nv o m) 882 | OpamPackage.Map.empty opams 883 | in 884 | let all_packages = 885 | OpamPackage.Set.of_list (OpamPackage.Map.keys m) 886 | in 887 | let env_global v = 888 | match OpamVariable.Full.scope v, 889 | OpamVariable.(to_string (Full.variable v)) 890 | with 891 | | OpamVariable.Full.Global, "opam-version" -> 892 | Some (S OpamVersion.(to_string current)) 893 | | OpamVariable.Full.Global, "with-test" -> Some (B false) 894 | | OpamVariable.Full.Global, "with-doc" -> Some (B false) 895 | | OpamVariable.Full.Global, "dev" -> Some (B false) 896 | | _ -> None 897 | in 898 | let env nv v = 899 | match OpamVariable.Full.scope v, 900 | OpamVariable.(to_string (Full.variable v)) 901 | with 902 | | (OpamVariable.Full.Global | OpamVariable.Full.Self), "name" -> 903 | Some (S (OpamPackage.Name.to_string nv.name)) 904 | | (OpamVariable.Full.Global | OpamVariable.Full.Self), "version" -> 905 | Some (S (OpamPackage.Version.to_string nv.version)) 906 | | _ -> env_global v 907 | in 908 | Lwt.return { 909 | u_packages = all_packages; 910 | u_action = Query; 911 | u_installed = OpamPackage.Set.empty; 912 | u_available = 913 | OpamPackage.Map.filter (fun _ opam -> 914 | OpamFilter.eval_to_bool ~default:true env_global 915 | (OpamFile.OPAM.available opam)) 916 | m 917 | |> OpamPackage.keys; 918 | u_depends = 919 | OpamPackage.Map.mapi 920 | (fun nv o -> 921 | OpamFile.OPAM.depends o |> 922 | OpamFilter.partial_filter_formula (env nv)) 923 | m; 924 | u_depopts = 925 | OpamPackage.Map.mapi 926 | (fun nv o -> 927 | OpamFile.OPAM.depopts o |> 928 | OpamFilter.partial_filter_formula (env nv)) 929 | m; 930 | u_conflicts = 931 | OpamPackage.Map.mapi 932 | (fun nv o -> 933 | OpamFile.OPAM.conflicts o |> 934 | OpamFilter.filter_formula ~default:false (env nv)) 935 | m; 936 | u_installed_roots = OpamPackage.Set.empty; 937 | u_pinned = OpamPackage.Set.empty; 938 | u_base = OpamPackage.Set.empty; 939 | u_attrs = []; 940 | u_reinstall = OpamPackage.Set.empty; 941 | } 942 | 943 | let reverse_dependencies universe packages = 944 | OpamPackage.Set.union packages @@ 945 | OpamPackage.Set.of_list @@ 946 | OpamSolver.reverse_dependencies 947 | ~depopts:false ~build:true ~post:true ~installed:false ~unavailable:true 948 | universe packages 949 | 950 | let installable universe packages ~name = 951 | let packages = 952 | OpamPackage.Set.inter packages universe.OpamTypes.u_packages 953 | in 954 | log "At %s: among %d packages..." name (OpamPackage.Set.cardinal packages); 955 | let%lwt installable = 956 | Lwt_preemptive.detach (OpamSolver.installable_subset universe) packages 957 | in 958 | log "... %d are installable" 959 | (OpamPackage.Set.cardinal installable); 960 | Lwt.return (packages, installable) 961 | 962 | let installability_check ancestor head gitstore packages = 963 | let open OpamPackage.Set.Op in 964 | let%lwt univ_before = get_universe gitstore ancestor ~name:"ANCESTOR" in 965 | let%lwt univ_after = get_universe gitstore head ~name:"HEAD" in 966 | let consider_packages = 967 | reverse_dependencies univ_before packages ++ 968 | reverse_dependencies univ_after packages 969 | in 970 | log "Considering %d related packages" 971 | (OpamPackage.Set.cardinal consider_packages); 972 | let%lwt packages_before, installable_before = 973 | installable univ_before consider_packages ~name:"ANCESTOR" 974 | in 975 | let%lwt packages_after, installable_after = 976 | installable univ_after consider_packages ~name:"HEAD" 977 | in 978 | let fresh = packages_after -- packages_before in 979 | let broken_before = packages_before -- installable_before in 980 | let broken_after = packages_after -- installable_after in 981 | let breaks = broken_after -- broken_before in 982 | let repairs = broken_before -- broken_after in 983 | let no_breaks = OpamPackage.Set.is_empty breaks in 984 | let title = 985 | Printf.sprintf "\n\n##### :%s: Installability check (%+d)\n\n" 986 | (if no_breaks then "sunny" else "sun_behind_small_cloud") 987 | (OpamPackage.Set.cardinal installable_after - 988 | OpamPackage.Set.cardinal installable_before) 989 | in 990 | let msg (s,set) = 991 | if OpamPackage.Set.is_empty set then None else 992 | Some (Printf.sprintf "%s (%d): %s" s 993 | (OpamPackage.Set.cardinal set) 994 | (OpamStd.List.concat_map " " pkg_to_string 995 | (OpamPackage.Set.elements set))) 996 | in 997 | let status = 998 | if no_breaks then `Passed else 999 | `Errors (List.map pkg_to_string 1000 | (OpamPackage.Set.elements breaks)) 1001 | in 1002 | Lwt.return ( 1003 | status, 1004 | title ^ 1005 | OpamStd.Format.itemize ~bullet:"* " (fun s -> s) @@ 1006 | OpamStd.List.filter_map msg [ 1007 | "these releases are **not installable** anymore", 1008 | breaks %% packages_before; 1009 | "these releases can now be installed, well done", 1010 | repairs %% packages_after; 1011 | "new installable packages", 1012 | fresh %% installable_after; 1013 | "new **broken** packages", 1014 | fresh -- installable_after; 1015 | "removed broken packages", 1016 | broken_before -- packages_after; 1017 | "removed installable packages", 1018 | installable_before -- packages_after; 1019 | ] 1020 | ) 1021 | 1022 | let add_status st1 st2 = match st1, st2 with 1023 | | `Errors a, `Errors b -> `Errors (a@b) 1024 | | `Errors _ as e, _ | _, (`Errors _ as e) -> e 1025 | | `Warnings a, `Warnings b -> `Warnings (a@b) 1026 | | `Warnings _ as w, _ | _, (`Warnings _ as w) -> w 1027 | | `Passed, `Passed -> `Passed 1028 | 1029 | let notice_misc_files = function 1030 | | [] -> "" 1031 | | l -> "\n\n---\n\n##### :sun_behind_small_cloud: " ^ (string_of_int @@ List.length l ) ^ " ignored non-opam files:\n\n" ^ 1032 | OpamStd.Format.itemize ~bullet:"* " (fun s -> s) l 1033 | 1034 | let run pr gitstore = 1035 | let%lwt () = RepoGit.fetch_pr pr gitstore in 1036 | let head = pr.head.sha in 1037 | let%lwt ancestor = RepoGit.common_ancestor pr gitstore in 1038 | let%lwt opam_files, other_files = changed_opam_files ancestor head gitstore in 1039 | let misc_files_body = notice_misc_files other_files in 1040 | let%lwt (stlint,msglint) = lint head gitstore opam_files in 1041 | let packages = 1042 | List.fold_left (fun pkgs (f,_) -> match OpamPackage.of_filename f with 1043 | | None -> pkgs 1044 | | Some nv -> OpamPackage.Set.add nv pkgs) 1045 | OpamPackage.Set.empty 1046 | opam_files 1047 | in 1048 | try%lwt 1049 | let%lwt (stinst,msginst) = 1050 | installability_check ancestor head gitstore packages 1051 | in 1052 | Lwt.return (add_status stlint stinst, 1053 | msglint ^ "\n\n---\n" ^ msginst ^ misc_files_body) 1054 | with e -> 1055 | log "Installability check failed: %s%s" (Printexc.to_string e) 1056 | (Printexc.get_backtrace ()); 1057 | Lwt.return (stlint, msglint ^ misc_files_body) 1058 | 1059 | end 1060 | 1061 | module Github_comment = struct 1062 | 1063 | open Github.Monad 1064 | open Github_t 1065 | 1066 | let github_max_descr_length = 140 1067 | 1068 | let github_mutex = Lwt_mutex.create () 1069 | let run cmd = 1070 | Lwt.bind (Lwt_mutex.lock github_mutex) 1071 | (fun () -> 1072 | Lwt.finalize (fun () -> run cmd) 1073 | (fun () -> Lwt_mutex.unlock github_mutex; Lwt.return_unit) 1074 | ) 1075 | 1076 | let make_status ~name ~token pr ?text status = 1077 | let status = { 1078 | new_status_state = status; 1079 | new_status_target_url = None; 1080 | new_status_description = text; 1081 | new_status_context = Some name; 1082 | } in 1083 | Github.Status.create 1084 | ~token ~user:pr.base.repo.user ~repo:pr.base.repo.name 1085 | ~status ~sha:pr.head.sha () 1086 | 1087 | let push_status ~name ~token pr ?text status = 1088 | run (make_status ~name ~token pr ?text status) 1089 | 1090 | let push_report ~name ~token ~report:(status,body) pr = 1091 | let user = pr.base.repo.user in 1092 | let repo = pr.base.repo.name in 1093 | let num = pr.number in 1094 | let comment () = 1095 | log "Commenting..."; 1096 | let rec find_comment stream = 1097 | Github.Stream.next stream >>= function 1098 | | Some (c, s) -> 1099 | if c.issue_comment_user.user_login = name then return (Some c) 1100 | else find_comment s 1101 | | None -> return None 1102 | in 1103 | find_comment (Github.Issue.comments ~token ~user ~repo ~num ()) 1104 | >>= function 1105 | | None -> 1106 | Github.Issue.create_comment ~token ~user ~repo ~num ~body () 1107 | | Some { issue_comment_id = id; _ } -> 1108 | Github.Issue.update_comment ~token ~user ~repo ~id ~body () 1109 | in 1110 | let push_status () = 1111 | log "Pushing status..."; 1112 | let state, text = match status with 1113 | | `Passed -> 1114 | `Success, "All tests passed" 1115 | | `Warnings ps -> 1116 | `Success, 1117 | let m = "Warnings for "^String.concat ", " ps in 1118 | if String.length m <= github_max_descr_length then m else 1119 | Printf.sprintf "Warnings for %d packages" (List.length ps) 1120 | | `Errors ps -> 1121 | `Error, 1122 | let m = "Errors for "^String.concat ", " ps in 1123 | if String.length m <= github_max_descr_length then m else 1124 | Printf.sprintf "Errors for %d packages" (List.length ps) 1125 | in 1126 | make_status ~name ~token pr ~text state 1127 | in 1128 | run ( 1129 | comment () >>= fun _ -> 1130 | push_status () >>= fun _ -> 1131 | return (log "Comment posted back to PR #%d" pr.number); 1132 | ) 1133 | 1134 | let pull_request ~name ~token repo branch target_branch ?message title = 1135 | log "Pull-requesting..."; 1136 | let pr () = 1137 | let rec find_pr stream = 1138 | Github.Stream.next stream >>= function 1139 | | Some (pr, s) -> 1140 | if pr.pull_head.branch_ref = branch && 1141 | pr.pull_base.branch_ref = target_branch 1142 | then return (Some pr) 1143 | else find_pr s 1144 | | None -> return None 1145 | in 1146 | find_pr (Github.Pull.for_repo 1147 | ~token ~state:`Open ~user:repo.user ~repo:repo.name ()) 1148 | >>= function 1149 | | None -> 1150 | let pull = { 1151 | new_pull_title = title; 1152 | new_pull_body = message; 1153 | new_pull_base = target_branch; 1154 | new_pull_head = branch; 1155 | } in 1156 | Github.Pull.create ~token ~user:repo.user ~repo:repo.name ~pull () 1157 | | Some pr -> 1158 | let update_pull = { 1159 | update_pull_title = Some title; 1160 | update_pull_body = message; 1161 | update_pull_state = None; 1162 | update_pull_base = None; 1163 | } in 1164 | Github.Pull.update ~token ~user:repo.user ~repo:repo.name 1165 | ~num:pr.pull_number ~update_pull () 1166 | in 1167 | run ( 1168 | pr () >>= fun resp -> 1169 | return (log "Filed pull-request #%d" resp#value.pull_number) 1170 | ) 1171 | 1172 | end 1173 | 1174 | module Conf = struct 1175 | module C = struct 1176 | let internal = ".opam-ci" 1177 | 1178 | type t = { 1179 | port: int; 1180 | name: string; 1181 | token: Github.Token.t; 1182 | secret: Cstruct.t; 1183 | repo: repo; 1184 | roles: [ `Pr_checker | `Push_upgrader ] list; 1185 | base_branch: string; 1186 | dest_branch: string; 1187 | } 1188 | 1189 | let empty = { 1190 | port = 8122; 1191 | name = "opam-ci"; 1192 | token = Github.Token.of_string ""; 1193 | secret = Cstruct.of_string ""; 1194 | repo = { user="ocaml"; name="opam-repository"; auth=None }; 1195 | roles = [ `Pr_checker ]; 1196 | base_branch = "master"; 1197 | dest_branch = "2.0.0"; 1198 | } 1199 | 1200 | open OpamPp.Op 1201 | 1202 | let role_of_string = function 1203 | | "pr_checker" -> `Pr_checker 1204 | | "push_upgrader" -> `Push_upgrader 1205 | | _ -> failwith "Invalid role (accepted are pr_checker, push_upgrader)" 1206 | 1207 | let role_to_string = function 1208 | | `Pr_checker -> "pr_checker" 1209 | | `Push_upgrader -> "push_upgrader" 1210 | 1211 | let fields = [ 1212 | "port", OpamPp.ppacc (fun port t -> {t with port}) (fun t -> t.port) 1213 | OpamFormat.V.pos_int; 1214 | "name", OpamPp.ppacc (fun name t -> {t with name}) (fun t -> t.name) 1215 | OpamFormat.V.string; 1216 | "token", OpamPp.ppacc (fun token t -> {t with token}) (fun t -> t.token) 1217 | (OpamFormat.V.string -| 1218 | OpamPp.of_module "token" (module Github.Token)); 1219 | "secret", OpamPp.ppacc 1220 | (fun secret t -> {t with secret}) (fun t -> t.secret) 1221 | (OpamFormat.V.string -| 1222 | OpamPp.of_pair "secret" 1223 | Cstruct.((of_string ?allocator:None ?off:None ?len:None), to_string)); 1224 | "repo-user", OpamPp.ppacc 1225 | (fun user t -> {t with repo = {t.repo with user}}) 1226 | (fun t -> t.repo.user) 1227 | OpamFormat.V.string; 1228 | "repo-name", OpamPp.ppacc 1229 | (fun name t -> {t with repo = {t.repo with name}}) 1230 | (fun t -> t.repo.name) 1231 | OpamFormat.V.string; 1232 | "roles", OpamPp.ppacc 1233 | (fun roles t -> {t with roles }) 1234 | (fun t -> t.roles) 1235 | (OpamFormat.V.map_list ~depth:1 @@ 1236 | OpamFormat.V.ident -| 1237 | OpamPp.of_pair "role" (role_of_string, role_to_string)); 1238 | "base-branch", OpamPp.ppacc 1239 | (fun base_branch t -> {t with base_branch }) 1240 | (fun t -> t.base_branch) 1241 | OpamFormat.V.string; 1242 | "dest-branch", OpamPp.ppacc 1243 | (fun dest_branch t -> {t with dest_branch }) 1244 | (fun t -> t.dest_branch) 1245 | OpamFormat.V.string; 1246 | ] 1247 | 1248 | let pp = 1249 | OpamFormat.I.map_file @@ 1250 | OpamFormat.I.fields ~name:internal ~empty fields -| 1251 | OpamFormat.I.show_errors ~name:internal ~strict:true () 1252 | end 1253 | include C 1254 | include OpamFile.SyntaxFile(C) 1255 | end 1256 | 1257 | module Webhook_handler = struct 1258 | 1259 | 1260 | module Camelus_conf = Conf 1261 | open Cohttp 1262 | open Cohttp_lwt_unix 1263 | 1264 | let uri_path = "/opam-ci" 1265 | let exp_method = `POST 1266 | let exp_ua_prefix = "GitHub-Hookshot/" 1267 | 1268 | (** Check that the request is well-formed and originated from GitHub *) 1269 | let check_github ~secret req body = 1270 | let headers = Request.headers req in 1271 | Uri.path (Request.uri req) = uri_path && 1272 | Request.meth req = exp_method && 1273 | OpamStd.Option.Op.( 1274 | (Header.get headers "user-agent" >>| 1275 | OpamStd.String.starts_with ~prefix:exp_ua_prefix) +! false) && 1276 | Header.get_media_type headers = Some "application/json" && 1277 | Header.get headers "x-github-event" <> None && 1278 | OpamStd.Option.Op.( 1279 | Header.get headers "x-hub-signature" >>| 1280 | OpamStd.String.remove_prefix ~prefix:"sha1=" >>| 1281 | Nocrypto.Uncommon.Cs.of_hex >>| 1282 | Cstruct.equal (Nocrypto.Hash.mac `SHA1 ~key:secret (Cstruct.of_string body)) 1283 | ) = Some true 1284 | 1285 | module JS = struct 1286 | let (-.-) json key = match json with 1287 | | `Assoc dic -> List.assoc key dic 1288 | | _ -> log "field %s not found" key; raise Not_found 1289 | let to_string = function 1290 | | `String s -> s 1291 | | `Null -> "" 1292 | | j -> 1293 | log "JSON error: not a string %s" (Yojson.Safe.to_string j); 1294 | raise Not_found 1295 | let to_int = function 1296 | | `Int i -> i 1297 | | j -> 1298 | log "JSON error: not an int %s" (Yojson.Safe.to_string j); 1299 | raise Not_found 1300 | end 1301 | 1302 | let pull_request_of_json base_branch json = 1303 | let open JS in 1304 | match json -.- "action" |> to_string with 1305 | | "opened" | "reopened" | "synchronize" -> 1306 | let number = json -.- "number" |> to_int in 1307 | let pr = json -.- "pull_request" in 1308 | let full_repo r = { 1309 | repo = { user = r -.- "user" -.- "login" |> to_string; 1310 | name = r -.- "repo" -.- "name" |> to_string; 1311 | auth = None; }; 1312 | ref = r -.- "ref" |> to_string; 1313 | sha = r -.- "sha" |> to_string; 1314 | } in 1315 | let base = full_repo (pr -.- "base") in 1316 | let head = full_repo (pr -.- "head") in 1317 | if base.ref <> base_branch then 1318 | (log "Ignoring PR to %S (!= %S)" base.ref base_branch; None) 1319 | else 1320 | let pr_user = pr -.- "user" -.- "login" |> to_string in 1321 | let message = 1322 | pr -.- "title" |> to_string, 1323 | pr -.- "body" |> to_string 1324 | in 1325 | Some { number; base; head; pr_user; message } 1326 | | a -> 1327 | log "Ignoring %s PR action" a; 1328 | None 1329 | 1330 | let push_event_of_json base_branch json = 1331 | let open JS in 1332 | let ref = json -.- "ref" |> to_string in 1333 | let push_head = json -.- "after" |> to_string in 1334 | let push_ancestor = json -.- "before" |> to_string in 1335 | let r = json -.- "repository" in 1336 | let push_repo = { 1337 | user = r -.- "owner" -.- "name" |> to_string; 1338 | name = r -.- "name" |> to_string; 1339 | auth = None; 1340 | } in 1341 | if (* RepoGit.GitStore.Reference.equal *) 1342 | ((* RepoGit.GitStore.Reference.of_string *) ref) = 1343 | (RepoGit.branch_reference base_branch) 1344 | then 1345 | Some { push_head; push_ancestor; push_repo } 1346 | else 1347 | (log "Ignoring push to %s" ref; None) 1348 | 1349 | let server ~(conf:Camelus_conf.t) ~handler = 1350 | let port = conf.port and secret = conf.secret 1351 | and base_branch = conf.base_branch in 1352 | let callback (conn, _) req body = 1353 | let%lwt body = Cohttp_lwt.Body.to_string body in 1354 | if not (check_github ~secret req body) then 1355 | (log "Ignored invalid request:\n%s" 1356 | (OpamStd.Format.itemize (fun s -> s) 1357 | (Uri.path (Request.uri req) :: 1358 | Code.string_of_method (Request.meth req) :: 1359 | OpamStd.Option.to_string (fun x -> x) 1360 | (Header.get_media_type (Request.headers req)) :: 1361 | OpamStd.List.filter_map (Header.get (Request.headers req)) 1362 | ["user-agent"; "content-type"; 1363 | "x-hub-signature"; "x-github-event"; ])); 1364 | Server.respond_not_found ()) 1365 | else 1366 | match Yojson.Safe.from_string body with 1367 | | exception Failure err -> 1368 | log "Error: invalid json (%s):\n%s" err body; 1369 | Server.respond_error ~body:"Invalid JSON" () 1370 | | json -> 1371 | match Header.get (Request.headers req) "x-github-event" with 1372 | | Some "pull_request" -> 1373 | (match pull_request_of_json base_branch json with 1374 | | Some pr -> 1375 | let%lwt () = handler (`Pr pr) in 1376 | Server.respond ~status:`OK ~body:Cohttp_lwt.Body.empty () 1377 | | None -> 1378 | Server.respond ~status:`OK ~body:Cohttp_lwt.Body.empty () 1379 | | exception Not_found -> 1380 | log "Error: could not get PR data from JSON:\n%s" 1381 | (Yojson.Safe.to_string json); 1382 | Server.respond_error ~body:"Invalid format" ()) 1383 | | Some "push" -> 1384 | (match push_event_of_json base_branch json with 1385 | | Some push -> 1386 | let%lwt () = handler (`Push push) in 1387 | Server.respond ~status:`OK ~body:Cohttp_lwt.Body.empty () 1388 | | None -> 1389 | Server.respond ~status:`OK ~body:Cohttp_lwt.Body.empty () 1390 | | exception Not_found -> 1391 | log "Error: could not get push event data from JSON:\n%s" 1392 | (Yojson.Safe.to_string json); 1393 | Server.respond_error ~body:"Invalid format" ()) 1394 | | Some a -> 1395 | log "Ignored %s event" a; 1396 | Server.respond ~status:`OK ~body:Cohttp_lwt.Body.empty () 1397 | | None -> 1398 | Server.respond_error ~body:"Invalid format" () 1399 | in 1400 | log "Listening on port %d" port; 1401 | Server.create 1402 | ~on_exn:(fun e -> log "Server exn: %s" (Printexc.to_string e)) 1403 | ~mode:(`TCP (`Port port)) 1404 | (Server.make ~callback ()) 1405 | end 1406 | --------------------------------------------------------------------------------