build.ml

open Current.Syntax

module Github = Current_github

let timeout = Duration.of_min 50
let password_path = "/run/secrets/ocurrent-hub"
let push_repo = "ocurrentbuilder/staging"

let auth : (string * string) option option ref = ref None

let get_auth () =
  match !auth with
  | Some a -> a
  | None ->
    if Sys.file_exists password_path then (
      let ch = open_in_bin password_path in
      let len = in_channel_length ch in
      let password = really_input_string ch len |> String.trim in
      close_in ch;
      auth := Some (Some ("ocurrent", password))
    ) else (
      Logs.warn (fun f -> f "Password file %S not found; images will not be pushed to hub@." password_path);
      auth := Some (None)
    );
    Option.join !auth

type org = string * Current_github.Api.t option

let account = fst
let api = snd

let org ?app ~account id =
  let api =
    app |> Option.map @@ fun app ->
    Current_github.App.installation app ~account id
    |> Current_github.Installation.api
  in
  account, api

let head_of ?github repo name =
  let gref = `Ref ("refs/heads/" ^ name) in
  match github with
  | None ->
    None, Github.Api.Anonymous.head_of repo gref
  | Some github ->
    let commit = Github.Api.head_of github repo gref in
    Some commit, Current.map Github.Api.Commit.id commit

(* Push a Slack notification to [channel] to say that [x] is updating [service] to [commit].
   [repo] is used for the URL in the message. *)
let notify ?channel ~web_ui ~service ~commit ~repo x =
  match channel with
  | None -> x
  | Some channel ->
    let s =
      let+ state = Current.state x
      and+ commit in
      let uri = Github.Api.Commit.uri commit in
      Fmt.str "@[<h>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
    Current.all [
      Current_slack.post channel ~key:("deploy-" ^ service) s;
      x   (* If [x] fails, the whole pipeline should fail too. *)
    ]

let label l x =
  Current.component "%s" l |>
  let> x in
  Current.Primitive.const x

module Make(T : S.T) = struct
  (* TODO Summarise build results. *)
  let status_of_build ~url build =
    let+ state = Current.state build in
    match state with
    | Ok _              -> Github.Api.CheckRunStatus.v ~url (`Completed `Success) ~summary:"Passed"
    | 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 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 *)
    Current.with_context root @@ fun () ->
    let builds = github |> Option.map @@ fun github ->
      let refs = Github.Api.ci_refs github repo in
      let collapse_value = repo_name ^ "-builds" in
      let url = web_ui collapse_value in
      let pipeline =
        refs
        |> 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
        )
        |> status_of_build ~url
        |> Github.Api.CheckRun.set_status commit "deployability"
      in
      Current.collapse ~key:"repo" ~value:collapse_value ~input:refs pipeline
    and deployment =
      let root = label "deployments" root in
      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.collapse ~key:"repo" ~value:repo_name ~input:root
    in
    Current.all (deployment :: Option.to_list builds)
end