diff --git a/deployer.opam b/deployer.opam index 87d14fc..5c3897d 100644 --- a/deployer.opam +++ b/deployer.opam @@ -35,6 +35,7 @@ depends: [ "current_ssh" "ocluster-api" "capnp-rpc-unix" + "sexplib" "fmt" "ppx_deriving_yojson" "ppx_deriving" diff --git a/dune-project b/dune-project index 967625e..4a09fdf 100644 --- a/dune-project +++ b/dune-project @@ -21,6 +21,7 @@ ocluster-api ; Opam dependencies capnp-rpc-unix + sexplib fmt ppx_deriving_yojson ppx_deriving diff --git a/src/build.ml b/src/build.ml index 04ecc33..19bfb81 100644 --- a/src/build.ml +++ b/src/build.ml @@ -29,20 +29,28 @@ let head_of ?github repo name = let notify ?channel ~web_ui ~service ~commit ~repo x = match channel with | None -> x - | Some channel -> + | Some { Slack_channel.uri; mode; repositories = _ } -> let s = - let+ state = Current.state x + let+ state = Current.state ~hidden:true x and+ commit in - let uri = Github.Api.Commit.uri commit in - Fmt.str "@[Deploy <%a|%a> as %s: <%s|%a>@]" - Uri.pp uri Github.Api.Commit.pp_short commit - service - (Uri.to_string (web_ui repo)) (Current_term.Output.pp Current.Unit.pp) state + match state, mode with + | Error (`Msg _), Slack_channel.Failure + | _, Slack_channel.All -> ( + let uri = Github.Api.Commit.uri commit in + let s = Fmt.str "@[Deploy <%a|%a> as %s: <%s|%a>@]" + Uri.pp uri Github.Api.Commit.pp_short commit + service + (Uri.to_string (web_ui repo)) (Current_term.Output.pp Current.Unit.pp) state + in + Some s) + | _ -> None in - Current.all [ - Current_slack.post channel ~key:("deploy-" ^ service) s; - x (* If [x] fails, the whole pipeline should fail too. *) - ] + Current.(option_iter + (fun s -> all [ + Current_slack.post uri ~key:("deploy-" ^ service) s; + x (* If [x] fails, the whole pipeline should fail too. *) + ] + )) s let label l x = Current.component "%s" l |> @@ -58,7 +66,19 @@ module Make(T : S.T) = struct | Error (`Active _) -> Github.Api.CheckRunStatus.v ~url `Queued | Error (`Msg m) -> Github.Api.CheckRunStatus.v ~url (`Completed (`Failure m)) ~summary:m - let repo ?channel ~web_ui ~org:(org, github) ?additional_build_args ~name build_specs = + let send_slack_message ~web_ui ~service ~commit ~repo_name deploy channels = + let f channel = + match channel.Slack_channel.repositories with + | All_repos -> notify ~channel ~web_ui ~service ~commit ~repo:repo_name deploy + | Some_repos repositories -> + if List.exists (String.equal repo_name) repositories then + notify ~channel ~web_ui ~service ~commit ~repo:repo_name deploy + else + deploy + in + List.map f channels + + let repo ?channels ~web_ui ~org:(org, github) ?additional_build_args ~name build_specs = let repo_name = Printf.sprintf "%s/%s" org name in let repo = { Github.Repo_id.owner = org; name } in let root = Current.return ~label:repo_name () in (* Group by repo in the diagram *) @@ -72,9 +92,9 @@ module Make(T : S.T) = struct |> Current.list_iter (module Github.Api.Commit) @@ fun commit -> let src = Current.map Github.Api.Commit.id commit in Current.all ( - List.map (fun (build_info, _) -> - T.build ?additional_build_args build_info repo src - ) build_specs + List.map (fun (build_info, _) -> + T.build ?additional_build_args build_info repo src + ) build_specs ) |> status_of_build ~url |> Github.Api.CheckRun.set_status commit "deployability" @@ -85,19 +105,19 @@ module Make(T : S.T) = struct Current.with_context root @@ fun () -> Current.all ( build_specs |> List.map (fun (build_info, deploys) -> - Current.all ( - deploys |> List.map (fun (branch, deploy_info) -> - let service = T.name deploy_info in - let commit, src = head_of ?github repo branch in - let deploy = T.deploy build_info deploy_info ?additional_build_args src in - match channel, commit with - | Some channel, Some commit -> notify ~channel ~web_ui ~service ~commit ~repo:repo_name deploy - | _ -> deploy - ) - ) + Current.all ( + deploys |> List.map (fun (branch, deploy_info) -> + let service = T.name deploy_info in + let commit, src = head_of ?github repo branch in + let deploy = T.deploy build_info deploy_info ?additional_build_args src in + match channels, commit with + | Some channels, Some commit -> + send_slack_message ~web_ui ~service ~commit ~repo_name deploy channels + | _ -> [ deploy ] + ) |> List.flatten ) - ) - |> Current.collapse ~key:"repo" ~value:repo_name ~input:root + ) + ) |> Current.collapse ~key:"repo" ~value:repo_name ~input:root in Current.all (deployment :: Option.to_list builds) end diff --git a/src/build.mli b/src/build.mli index 882ee21..fa496b8 100644 --- a/src/build.mli +++ b/src/build.mli @@ -13,7 +13,7 @@ val api : org -> Current_github.Api.t option module Make(T : S.T) : sig val repo : - ?channel:Current_slack.channel -> + ?channels:Slack_channel.t list -> web_ui:(string -> Uri.t) -> org:org -> ?additional_build_args:string list Current.t -> diff --git a/src/dune b/src/dune index 158c086..f9a9cae 100644 --- a/src/dune +++ b/src/dune @@ -47,6 +47,6 @@ str lwt lwt.unix) - (modules index pipeline aws caddy logging mirage s build) + (modules index pipeline aws caddy logging mirage s build slack_channel) (preprocess (pps ppx_deriving.std ppx_deriving_yojson))) diff --git a/src/local.ml b/src/local.ml index 5ce187e..da3f867 100644 --- a/src/local.ml +++ b/src/local.ml @@ -14,16 +14,26 @@ let read_first_line path = Fun.protect (fun () -> input_line ch) ~finally:(fun () -> close_in ch) -let main () config mode app sched staging_password_file repo flavour = +let read_file path = + let ch = open_in path in + Fun.protect (fun () -> really_input_string ch (in_channel_length ch)) + ~finally:(fun () -> close_in ch) + +let main () config mode app slack sched staging_password_file repo flavour = Logs.info (fun f -> f "Is this thing on?"); + let channels = + Option.(map (fun s -> Slack_channel.parse_json @@ read_file s) slack + |> value ~default:[]) + in let filter = Option.map (=) repo in let vat = Capnp_rpc_unix.client_only_vat () in + let sched = Current_ocluster.Connection.create (Capnp_rpc_unix.Vat.import_exn vat sched) in let staging_auth = staging_password_file |> Option.map (fun path -> staging_user, read_first_line path) in let engine = match flavour with - | `Tarides -> Current.Engine.create ~config (Pipeline.tarides ?app ~sched ~staging_auth ?filter) - | `OCaml -> Current.Engine.create ~config (Pipeline.ocaml_org ?app ~sched ~staging_auth ?filter) - | `Mirage -> Current.Engine.create ~config (Pipeline.mirage ?app ~sched ~staging_auth) + | `Tarides -> Current.Engine.create ~config (Pipeline.tarides ?app ~notify:channels ~sched ~staging_auth ?filter) + | `OCaml -> Current.Engine.create ~config (Pipeline.ocaml_org ?app ~notify:channels ~sched ~staging_auth ?filter) + | `Mirage -> Current.Engine.create ~config (Pipeline.mirage ?app ~notify:channels ~sched ~staging_auth) in let webhook_secret = Option.value ~default:webhook_secret @@ Option.map Current_github.App.webhook_secret app in let has_role = Current_web.Site.allow_all in @@ -41,6 +51,14 @@ let main () config mode app sched staging_password_file repo flavour = (* Command-line parsing *) open Cmdliner +let slack = + Arg.value @@ + Arg.opt Arg.(some file) None @@ + Arg.info + ~doc:"A file containing the URI of the endpoint for status updates." + ~docv:"URI-FILE" + ["slack"] + let submission_service = Arg.required @@ Arg.opt Arg.(some Capnp_rpc_unix.sturdy_uri) None @@ @@ -68,7 +86,7 @@ let repo = let cmd = let doc = "build and deploy services from Git" in let cmd_t = Term.(term_result (const main $ Logging.cmdliner $ Current.Config.cmdliner $ Current_web.cmdliner - $ Current_github.App.cmdliner_opt $ submission_service $ staging_password $ repo $ Pipeline.Flavour.cmdliner)) in + $ Current_github.App.cmdliner_opt $ slack $ submission_service $ staging_password $ repo $ Pipeline.Flavour.cmdliner)) in let info = Cmd.info "deploy" ~doc in Cmd.v info cmd_t diff --git a/src/main.ml b/src/main.ml index fd9c7f7..4da8c33 100644 --- a/src/main.ml +++ b/src/main.ml @@ -16,12 +16,10 @@ let read_first_line path = Fun.protect (fun () -> input_line ch) ~finally:(fun () -> close_in ch) -let read_channel_uri path = - try - let uri = read_first_line path in - Current_slack.channel (Uri.of_string (String.trim uri)) - with ex -> - Fmt.failwith "Failed to read slack URI from %S: %a" path Fmt.exn ex +let read_file path = + let ch = open_in path in + Fun.protect (fun () -> really_input_string ch (in_channel_length ch)) + ~finally:(fun () -> close_in ch) (* Access control policy for Tarides. *) let has_role_tarides user role = @@ -84,18 +82,21 @@ let has_role_ocaml user role = let main () config mode app slack auth staging_password_file flavour = let vat = Capnp_rpc_unix.client_only_vat () in - let channel = read_channel_uri slack in + let channels = + Option.(map (fun s -> Slack_channel.parse_json @@ read_file s) slack + |> value ~default:[]) + in let staging_auth = staging_password_file |> Option.map (fun path -> staging_user, read_first_line path) in let engine = match flavour with | Tarides sched -> let sched = Current_ocluster.Connection.create (Capnp_rpc_unix.Vat.import_exn vat sched) in - Current.Engine.create ~config (Pipeline.tarides ~app ~notify:channel ~sched ~staging_auth) + Current.Engine.create ~config (Pipeline.tarides ~app ~notify:channels ~sched ~staging_auth) | OCaml sched -> let sched = Current_ocluster.Connection.create (Capnp_rpc_unix.Vat.import_exn vat sched) in - Current.Engine.create ~config (Pipeline.ocaml_org ~app ~notify:channel ~sched ~staging_auth) + Current.Engine.create ~config (Pipeline.ocaml_org ~app ~notify:channels ~sched ~staging_auth) | Mirage sched -> let sched = Current_ocluster.Connection.create (Capnp_rpc_unix.Vat.import_exn vat sched) in - Current.Engine.create ~config (Pipeline.mirage ~app ~notify:channel ~sched ~staging_auth) + Current.Engine.create ~config (Pipeline.mirage ~app ~notify:channels ~sched ~staging_auth) in let authn = Option.map Current_github.Auth.make_login_uri auth in let webhook_secret = Current_github.App.webhook_secret app in @@ -122,7 +123,7 @@ let main () config mode app slack auth staging_password_file flavour = open Cmdliner let slack = - Arg.required @@ + Arg.value @@ Arg.opt Arg.(some file) None @@ Arg.info ~doc:"A file containing the URI of the endpoint for status updates." diff --git a/src/pipeline.ml b/src/pipeline.ml index 3be7bdd..40133aa 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -327,7 +327,7 @@ let build_kit (v : Cluster_api.Docker.Spec.options) = { v with buildkit = true } For each one, it lists the builds that are made from that repository. For each build, it says which which branch gives the desired live version of the service, and where to deploy it. *) -let tarides ?app ?notify:channel ?filter ~sched ~staging_auth () = +let tarides ?app ?notify:channels ?filter ~sched ~staging_auth () = (* [web_ui collapse_value] is a URL back to the deployment service, for links in status messages. *) let web_ui = @@ -338,7 +338,7 @@ let tarides ?app ?notify:channel ?filter ~sched ~staging_auth () = let ocurrent = Build.org ?app ~account:"ocurrent" 12497518 in let ocaml_bench = Build.org ?app ~account:"ocaml-bench" 19839896 in - let build (org, name, builds) = Cluster_build.repo ?channel ~web_ui ~org ~name builds in + let build (org, name, builds) = Cluster_build.repo ?channels ~web_ui ~org ~name builds in let docker ?archs = let timeout = match archs with | Some archs when List.mem `Linux_riscv64 archs -> Int64.mul timeout 2L @@ -402,7 +402,7 @@ let tarides ?app ?notify:channel ?filter ~sched ~staging_auth () = For each one, it lists the builds that are made from that repository. For each build, it says which which branch gives the desired live version of the service, and where to deploy it. *) -let ocaml_org ?app ?notify:channel ?filter ~sched ~staging_auth () = +let ocaml_org ?app ?notify:channels ?filter ~sched ~staging_auth () = (* [web_ui collapse_value] is a URL back to the deployment service, for links in status messages. *) let web_ui = @@ -415,7 +415,7 @@ let ocaml_org ?app ?notify:channel ?filter ~sched ~staging_auth () = let ocaml_opam = Build.org ?app ~account:"ocaml-opam" 23690708 in let build ?additional_build_args (org, name, builds) = - Cluster_build.repo ?channel ?additional_build_args ~web_ui ~org ~name builds in + Cluster_build.repo ?channels ?additional_build_args ~web_ui ~org ~name builds in let docker_with_timeout timeout = docker ~sched:(Current_ocluster.v ~timeout ?push_auth:staging_auth sched) in @@ -440,19 +440,19 @@ let ocaml_org ?app ?notify:channel ?filter ~sched ~staging_auth () = ]; ocurrent, "docker-base-images", [ - (* Docker base images @ images.ci.ocaml.org *) - docker "Dockerfile" ["live", "ocurrent/base-images:live", [`Ocamlorg_images "base-images_builder"]]; - ]; + (* Docker base images @ images.ci.ocaml.org *) + docker "Dockerfile" ["live", "ocurrent/base-images:live", [`Ocamlorg_images "base-images_builder"]]; + ]; ocurrent, "ocaml-docs-ci", [ - docker "Dockerfile" ["live", "ocurrent/docs-ci:live", [`Docs "infra_docs-ci"]]; - docker "docker/init/Dockerfile" ["live", "ocurrent/docs-ci-init:live", [`Docs "infra_init"]]; - docker "docker/storage/Dockerfile" ["live", "ocurrent/docs-ci-storage-server:live", [`Docs "infra_storage-server"]]; - docker "Dockerfile" ["staging", "ocurrent/docs-ci:staging", [`Staging_docs "infra_docs-ci"]]; - docker "docker/init/Dockerfile" ["staging", "ocurrent/docs-ci-init:staging", [`Staging_docs "infra_init"]]; - docker "docker/storage/Dockerfile" ["staging", "ocurrent/docs-ci-storage-server:staging", [`Staging_docs "infra_storage-server"]]; - ]; - ] in + docker "Dockerfile" ["live", "ocurrent/docs-ci:live", [`Docs "infra_docs-ci"]]; + docker "docker/init/Dockerfile" ["live", "ocurrent/docs-ci-init:live", [`Docs "infra_init"]]; + docker "docker/storage/Dockerfile" ["live", "ocurrent/docs-ci-storage-server:live", [`Docs "infra_storage-server"]]; + docker "Dockerfile" ["staging", "ocurrent/docs-ci:staging", [`Staging_docs "infra_docs-ci"]]; + docker "docker/init/Dockerfile" ["staging", "ocurrent/docs-ci-init:staging", [`Staging_docs "infra_init"]]; + docker "docker/storage/Dockerfile" ["staging", "ocurrent/docs-ci-storage-server:staging", [`Staging_docs "infra_storage-server"]]; + ]; + ] in let head_of repo id = match Build.api ocaml_opam with @@ -507,7 +507,7 @@ let unikernel dockerfile ~target args services = |> List.map (fun (branch, service) -> branch, { Packet_unikernel.service }) in (build_info, deploys) -let mirage ?app ?notify:channel ~sched ~staging_auth () = +let mirage ?app ?notify:channels ~sched ~staging_auth () = (* [web_ui collapse_value] is a URL back to the deployment service, for links in status messages. *) let web_ui = @@ -517,14 +517,14 @@ let mirage ?app ?notify:channel ~sched ~staging_auth () = (* GitHub organisations to monitor. *) let mirage = Build.org ?app ~account:"mirage" 7175142 in let ocurrent = Build.org ?app ~account:"ocurrent" 6853813 in - let build_unikernel (org, name, builds) = Build_unikernel.repo ?channel ~web_ui ~org ~name builds in - let build_docker (org, name, builds) = Cluster_build.repo ?channel ~web_ui ~org ~name builds in + let build_unikernel (org, name, builds) = Build_unikernel.repo ?channels ~web_ui ~org ~name builds in + let build_docker (org, name, builds) = Cluster_build.repo ?channels ~web_ui ~org ~name builds in let sched = Current_ocluster.v ~timeout ?push_auth:staging_auth sched in let docker = docker ~sched in Current.all @@ (List.map build_unikernel [ mirage, "mirage-www", [ unikernel "Dockerfile" ~target:"hvt" ["EXTRA_FLAGS=--tls=true --metrics --separate-networks"] ["master", "www"]; - unikernel "Dockerfile" ~target:"xen" ["EXTRA_FLAGS=--tls=true"] []; (* (no deployments) *) + unikernel "Dockerfile" ~target:"xen" ["EXTRA_FLAGS=--tls=true"] []; (* (no deployments) *) unikernel "Dockerfile" ~target:"hvt" ["EXTRA_FLAGS=--tls=true --metrics --separate-networks"] ["next", "next"]; ]; ] @ List.map build_docker [ diff --git a/src/pipeline.mli b/src/pipeline.mli index 81da85c..345fa26 100644 --- a/src/pipeline.mli +++ b/src/pipeline.mli @@ -9,7 +9,7 @@ end val tarides : ?app:Current_github.App.t -> - ?notify:Current_slack.channel -> + ?notify:Slack_channel.t list -> ?filter:(Current_github.Repo_id.t -> bool) -> sched:Current_ocluster.Connection.t -> staging_auth:(string * string) option -> @@ -17,7 +17,7 @@ val tarides : val ocaml_org : ?app:Current_github.App.t -> - ?notify:Current_slack.channel -> + ?notify:Slack_channel.t list -> ?filter:(Current_github.Repo_id.t -> bool) -> sched:Current_ocluster.Connection.t -> staging_auth:(string * string) option -> @@ -25,7 +25,7 @@ val ocaml_org : val mirage : ?app:Current_github.App.t -> - ?notify:Current_slack.channel -> + ?notify:Slack_channel.t list -> sched:Current_ocluster.Connection.t -> staging_auth:(string * string) option -> unit -> unit Current.t diff --git a/src/slack_channel.ml b/src/slack_channel.ml new file mode 100644 index 0000000..f02a368 --- /dev/null +++ b/src/slack_channel.ml @@ -0,0 +1,46 @@ +type mode = + | All + | Failure + +type repositories = + | All_repos + | Some_repos of string list + +type t = { uri : Current_slack.channel; mode : mode; repositories : repositories } + +open Yojson.Safe + +let mode_of_json_string t = + let open Yojson.Safe in + match Util.to_string t with + | "all" -> All + | "failure" -> Failure + | _ -> raise (Util.Type_error ("\"mode\" must be: \"all\", or \"failure\"", t)) + +let repositories_of_json_string = function + | `Null -> All_repos + | l -> Some_repos (List.map Util.to_string @@ Util.to_list l) + +let parse_json s = + let read_channel ch = + let uri = + Util.(member "uri" ch |> to_string) + |> String.trim + |> Uri.of_string + |> Current_slack.channel in + let mode = + Util.member "mode" ch + |> mode_of_json_string + in + let repositories = + Util.member "repositories" ch + |> repositories_of_json_string + in + { uri; mode; repositories } + in + try + from_string s |> Util.to_list |> List.map read_channel + with _ -> + let uri = Current_slack.channel @@ Uri.of_string @@ String.trim s in + [ { uri; mode = All; repositories = All_repos } ] + (* Fmt.failwith "Failed to parse slack URIs '%S': %a" s Fmt.exn e *) diff --git a/src/slack_channel.mli b/src/slack_channel.mli new file mode 100644 index 0000000..396ae1f --- /dev/null +++ b/src/slack_channel.mli @@ -0,0 +1,43 @@ +type mode = All | Failure +(** The condition on which we send a Slack message *) + +type repositories = All_repos | Some_repos of string list +(** The set of repos that we send Slack messages for *) + +type t = { uri : Current_slack.channel; mode : mode; repositories : repositories } + +val parse_json : string -> t list +(** [parse_json s] parses the JSON string [s], the format of which is a list of objects with fields: + + - [uri], the URI endpoint for the Slack application, of the form + ["https://hooks.slack.com/services/***/***/***"] + - [mode], which is the condition on which we send a Slack message. + ["all"] corresponds to [All], ["failure"] corresponds to [Failure] + - [repositories], an optional parameter. If it is not present, then + we apply the record to all repositories being deployed. If it is + present, then it must contain a list of repositories, each being + represented as a string of the format ["org/repo"], e.g. + ["ocurrent/ocaml-ci"]. + + Here is an example of a valid JSON string: + {[ + \[ + { + uri:"https://hooks.slack.com/services/***/***/***", + mode:"failure", + repositories:["ocurrent/ocaml-ci", "ocurrent/opam-repo-ci"] + }, + { + uri:"https://hooks.slack.com/services/***/***/***", + mode:"all" + } + \] + ]} + + The first record in the list says that when there is a deploy + failure on the [ocurrent/ocaml-ci] or the [ocurrent/opam-repo-ci] + repos, send a Slack message to the specified URI. + + The second record says that for every repo, for each event on the + deployment of those repos (successes and failures), send a Slack + message to the specified URI. *) diff --git a/test/test.ml b/test/test.ml index f202274..9b43e3b 100644 --- a/test/test.ml +++ b/test/test.ml @@ -5,4 +5,4 @@ let () = Unix.putenv "EMAIL" "test@example.com"; Lwt_main.run @@ Alcotest_lwt.run "deployer" - [ ("index", Test_index.tests); ] + [ ("index", Test_index.tests); ]