Add a Docker Compose v2 deployment path

.gitignore

@@ -3,3 +3,6 @@ _build
 *.install
 /var/
 _opam/
+
+# Local secrets — never commit
+/secrets/

create-config.sh

@@ -4,6 +4,7 @@
 docker context create "ci3.ocamllabs.io" --description "Ci3 - Tarides" --docker "host=ssh://root@ci3.ocamllabs.io"
 docker context create "ci4.ocamllabs.io" --description "Ci4 - Tarides" --docker "host=ssh://root@ci4.ocamllabs.io"
 docker context create "chives.caelum.ci.dev" --description "Ci - Mirage" --docker "host=ssh://root@chives.caelum.ci.dev"
+docker context create "dill.caelum.ci.dev" --description "ocaml-docs-ci - dill.caelum.ci.dev" --docker "host=ssh://root@dill.caelum.ci.dev"
 docker context create "ci.ocamllabs.io" --description "Toxis - Tarides" --docker "host=ssh://root@ci.ocamllabs.io"
 docker context create "deploy.ci.ocaml.org" --description "OCaml - deploy.ci.ocaml.org" --docker "host=ssh://root@deploy.ci.ocaml.org"
 docker context create "dev1.ocamllabs.io" --description "OCaml - opam-repo-ci" --docker "host=ssh://root@dev1.ocamllabs.io"
@@ -31,6 +32,7 @@ for host in \
   ci3.ocamllabs.io \
   ci4.ocamllabs.io \
   chives.caelum.ci.dev \
+  dill.caelum.ci.dev \
   ci.ocamllabs.io \
   deploy.ci.ocaml.org \
   dev1.ocamllabs.io \

plugins/compose_v2/compose_v2.ml

@@ -0,0 +1,112 @@
+open Lwt.Infix
+
+type t = {
+  pull: bool ;
+}
+
+let id = "docker-compose-v2"
+
+module Key = struct
+  type t = {
+    commit : [ `No_context | `Git of Current_git.Commit.t | `Dir of Fpath.t ];
+    docker_context : string option;
+    docker_compose_file : [`File of Fpath.t | `Contents of string];
+    path : Fpath.t option;
+    detach : bool;
+    up_args: string list;
+    project_name: string;
+  }
+
+  let digest_docker_compose_file = function
+    | `File name -> `Assoc [ "file", `String (Fpath.to_string name) ]
+    | `Contents contents -> `Assoc [ "contents", `String (Digest.string contents |> Digest.to_hex) ]
+
+  let source_to_json = function
+    | `No_context -> `Null
+    | `Git commit -> `String (Current_git.Commit.hash commit)
+    | `Dir path -> `String (Fpath.to_string path)
+
+  let to_json { commit; docker_compose_file; docker_context; detach; project_name; up_args; path } =
+    `Assoc [
+      "commit", source_to_json commit;
+      "docker_context", [%derive.to_yojson:string option] docker_context;
+      "docker_compose_file", digest_docker_compose_file docker_compose_file;
+      "path", Option.(value ~default:`Null (map (fun v -> `String (Fpath.to_string v)) path));
+      "detach", [%derive.to_yojson:bool] detach;
+      "up_args", [%derive.to_yojson:string list] up_args;
+      "project_name", [%derive.to_yojson:string] project_name;
+    ]
+
+  let digest t = Yojson.Safe.to_string (to_json t)
+
+  let pp f t = Yojson.Safe.pretty_print f (to_json t)
+end
+
+module Value = struct
+  type t = {
+    repos : Repo.t list;
+  }
+
+  let digest { repos } =
+    Yojson.Safe.to_string @@ `Assoc [
+      "image", `String (List.map (fun image -> Repo.digest image) repos |> String.concat ";");
+    ]
+end
+
+module Outcome = Current.Unit
+
+let or_raise = function
+  | Ok x -> x
+  | Error (`Msg m) -> raise (Failure m)
+
+let with_context ~job context fn =
+  let open Lwt_result.Infix in
+  match context with
+  | `No_context -> Current.Process.with_tmpdir ~prefix:"build-context-" fn
+  | `Dir path ->
+      Current.Process.with_tmpdir ~prefix:"build-context-" @@ fun dir ->
+      Current.Process.exec ~cwd:dir ~cancellable:true ~job ("", [| "rsync"; "-aHq"; Fpath.to_string path ^ "/"; "." |]) >>= fun () ->
+      fn dir
+  | `Git commit -> Current_git.with_checkout ~job commit fn
+
+let search_and_replace needle haystack replacement =
+  match Astring.String.find_sub ~sub:needle haystack with
+  | None -> haystack
+  | Some len -> (Astring.String.with_range ~len haystack) ^ replacement ^ (Astring.String.with_range ~first:(len + String.length needle) haystack)
+
+let publish { pull } job key { Value.repos } =
+  let { Key.commit; docker_context; docker_compose_file; detach; up_args; project_name; path } = key in
+  Current.Job.start job ~level:Current.Level.Dangerous >>= fun () ->
+  with_context ~job commit @@ fun dir ->
+  let dir = match path with
+    | Some path -> Fpath.(dir // path)
+    | None -> dir
+  in
+  let contents, name =
+    match docker_compose_file with
+    | `Contents contents -> contents ^ "\n", Fpath.(dir / "docker-compose.yml")
+    | `File name -> Bos.OS.File.read Fpath.(dir // name) |> or_raise, name
+  in
+  let contents = List.fold_left (fun acc repo -> search_and_replace (Repo.name repo) acc (Repo.digest repo)) contents repos
+  in
+  let file =
+    Bos.OS.File.write Fpath.(dir // name) contents |> or_raise;
+    Current.Job.log job "@[<v2>%s\n%a@]" Fpath.(to_string name) Fmt.string contents;
+    match docker_compose_file with
+    | `Contents _ -> []
+    | `File name -> ["-f"; Fpath.(to_string (dir // name))]
+  in
+  let args = ["compose"; "-p"; project_name] @ file in
+  let p =
+    if pull then Current.Process.exec ~cancellable:true ~job (Current_docker.Raw.Cmd.docker ~docker_context (args @ ["pull"]))
+    else Lwt.return (Ok ())
+  in
+  p >>= function
+  | Error _ as e -> Lwt.return e
+  | Ok () -> Current.Process.exec ~cancellable:true ~job (Current_docker.Raw.Cmd.docker ~docker_context (args @ ["up"] @ (if detach then ["-d"] else []) @ up_args))
+
+let pp f (key, value) =
+  let { Key.commit = _; docker_context = _; docker_compose_file = _; path = _; detach = _; up_args = _; project_name } = key in
+  Fmt.pf f "%s %s" project_name (Value.digest value)
+
+let auto_cancel = false

plugins/compose_v2/current_compose_v2.ml

@@ -0,0 +1,38 @@
+open Current.Syntax
+
+module Repo = Repo
+
+type source = [
+  | `No_context
+  | `Dir of Fpath.t Current.t
+  | `Git of Current_git.Commit.t Current.t
+]
+
+module Raw = struct
+  module CV2 = Current_cache.Output(Compose_v2)
+
+  let compose_v2 ?docker_compose_file ?path ?(pull=true) ?(detach=true) ?(up_args = []) ~docker_context ~project_name ~repos commit =
+    let docker_compose_file =
+      match docker_compose_file with
+      | None -> `File (Fpath.v "docker-compose.yml")
+      | Some (`File _ as f) -> f
+      | Some (`Contents c) -> `Contents c
+    in
+    CV2.set Compose_v2.{ pull }
+      { Compose_v2.Key.commit; docker_compose_file; path; docker_context; detach; up_args; project_name }
+      { Compose_v2.Value.repos }
+end
+
+let get_build_context = function
+  | `No_context -> Current.return `No_context
+  | `Git commit -> Current.map (fun x -> `Git x) commit
+  | `Dir path -> Current.map (fun path -> `Dir path) path
+
+let compose_v2 ?docker_compose_file ?path ?pull ?detach ?up_args ~docker_context ~project_name ~repos src =
+  Current.component "docker-compose-v2@,%s" project_name |>
+  let names, images = List.split repos in
+  let> commit = get_build_context src
+  and> images = Current.list_seq images
+  and> docker_compose_file = Current.option_seq docker_compose_file in
+  let repos = List.map2 (fun name image -> { Repo.name; image }) names images in
+  Raw.compose_v2 ?docker_compose_file ?path ?pull ?detach ?up_args ~docker_context ~project_name ~repos commit

plugins/compose_v2/current_compose_v2.mli

@@ -0,0 +1,60 @@
+(** Keep a Docker Compose v2 deployment up-to-date, pinning built images by
+    digest into the compose file.
+
+    Unlike {!Current_docker.S.DOCKER.compose_cli}, this supports multiple
+    dependent images keyed by name and can read the [docker-compose.yml]
+    straight from the build source (e.g. a Git checkout) rather than only from
+    an in-memory string. *)
+
+type source = [
+  | `No_context
+  | `Dir of Fpath.t Current.t
+  | `Git of Current_git.Commit.t Current.t
+]
+
+module Raw : sig
+  val compose_v2 :
+    ?docker_compose_file:[`File of Fpath.t | `Contents of string] ->
+    ?path:Fpath.t ->
+    ?pull:bool ->
+    ?detach:bool ->
+    ?up_args:string list ->
+    docker_context:string option ->
+    project_name:string ->
+    repos:Repo.t list ->
+    [ `Git of Current_git.Commit.t | `Dir of Fpath.t | `No_context ] ->
+    unit Current.Primitive.t
+end
+
+val compose_v2 :
+  ?docker_compose_file:[`File of Fpath.t | `Contents of string] Current.t ->
+  ?path:Fpath.t ->
+  ?pull:bool ->
+  ?detach:bool ->
+  ?up_args:string list ->
+  docker_context:string option ->
+  project_name:string ->
+  repos:(string * Current_docker.Raw.Image.t Current.t) list ->
+  source ->
+  unit Current.t
+(** [compose_v2 ~docker_context ~project_name ~repos src] keeps a Docker
+    Compose v2 deployment up-to-date.
+
+    [src] provides the build context; with a [`Git] source and the default
+    [docker_compose_file] of [`File "docker-compose.yml"], the compose file is
+    read from the checked-out repository. For each [(name, image)] in [repos],
+    the first occurrence of [name] in the compose file is replaced with
+    [image]'s pinned digest reference before running {e docker compose pull}
+    (when [pull] is set) and {e docker compose up}.
+
+    @param docker_compose_file [`File path] to read from the source, or
+           [`Contents yaml] to use a literal compose file (default
+           [`File "docker-compose.yml"]).
+    @param path Sub-directory within the source to run from.
+    @param pull Whether to {e docker compose pull} first (default [true]).
+    @param detach Pass [-d] to {e docker compose up} (default [true]).
+    @param up_args Extra arguments appended to {e docker compose up}. *)
+
+(** {2 Repositories} *)
+
+module Repo = Repo

plugins/compose_v2/dune

@@ -0,0 +1,19 @@
+(library
+ (name current_compose_v2)
+ (public_name deployer.compose_v2)
+ (libraries
+  astring
+  bos
+  current
+  current.cache
+  current.term
+  current_git
+  current_docker
+  fmt
+  fpath
+  logs
+  lwt
+  lwt.unix
+  ppx_deriving_yojson.runtime)
+ (preprocess
+  (pps ppx_deriving.std ppx_deriving_yojson)))

plugins/compose_v2/repo.ml

@@ -0,0 +1,9 @@
+type t = {
+  name : string;
+  image : Current_docker.Raw.Image.t;
+}
+
+(* The value substituted into the compose file in place of [name].
+   [Image.hash] is a pinned pull reference (e.g. [repo@sha256:...]). *)
+let digest t = Current_docker.Raw.Image.hash t.image
+let name t = t.name

plugins/compose_v2/repo.mli

@@ -0,0 +1,7 @@
+type t = {
+  name : string;
+  image : Current_docker.Raw.Image.t;
+}
+
+val digest : t -> string
+val name : t -> string

src/cluster.ml

@@ -39,9 +39,20 @@ type service = {
   uri : string option;
 }
 
+(* A Docker Compose v2 deployment: after the image is built and pushed, run
+   [docker compose up] on [compose_context], using the [docker-compose.yml]
+   from the build source and pinning [image_name] to the freshly-built digest. *)
+type compose = {
+  compose_context : (module Current_docker.S.DOCKER);
+  project_name : string;
+  image_name : string;        (* the [image:] reference in docker-compose.yml to pin *)
+  compose_path : Fpath.t option;
+}
+
 type deploy_info = {
   hub_id : Cluster_api.Docker.Image_id.t;
   services : service list;
+  compose : compose option;
 }
 
 let show_service (org, name, builds) =
@@ -135,7 +146,8 @@ let build_and_push ?level ?label ?cache_hint t ~push_target ~pool ~src ~options
   and> src in
   Current_ocluster.Raw.build_and_push ?level ?cache_hint t ~push_target ~pool ~src ~options dockerfile
 
-let deploy { sched; dockerfile; options; archs } { hub_id; services } ?(additional_build_args=Current.return []) src =
+let deploy { sched; dockerfile; options; archs } { hub_id; services; compose } ?(additional_build_args=Current.return []) src =
+  let commit_id = src in
   let src = Current.map (fun x -> [x]) src in
   let image_label = Cluster_api.Docker.Image_id.repo hub_id in
   Metrics.Build.inc_deployments "cluster" image_label;
@@ -155,9 +167,28 @@ let deploy { sched; dockerfile; options; archs } { hub_id; services } ?(addition
   | None -> Current.all (Current.fail "No auth configured; can't push final image" :: List.map Current.ignore_value images)
   | Some auth ->
     let multi_hash = Current_docker.push_manifest ~auth images ~tag:(Cluster_api.Docker.Image_id.to_string hub_id) in
-    match services with
+    let service_deploys = List.map (pull_and_serve `Service multi_hash) services in
+    let compose_deploys =
+      match compose with
+      | None -> []
+      | Some { compose_context; project_name; image_name; compose_path } ->
+        let module D = (val compose_context : Current_docker.S.DOCKER) in
+        (* Pull the freshly-pushed manifest on the target host to resolve it to
+           a pinned image reference, then run [docker compose up] there with the
+           [docker-compose.yml] checked out from the build source. *)
+        let image =
+          Current.component "pull" |>
+          let> repo_id = multi_hash in
+          Current_docker.Raw.pull repo_id ?auth:(Build.get_auth ()) ~docker_context:D.docker_context ~schedule:no_schedule
+        in
+        let commit = Current_git.fetch commit_id in
+        [ Current_compose_v2.compose_v2
+            ~docker_context:D.docker_context
+            ~project_name
+            ?path:compose_path
+            ~repos:[ (image_name, image) ]
+            (`Git commit) ]
+    in
+    match service_deploys @ compose_deploys with
     | [] -> Current.ignore_value multi_hash
-    | services ->
-      services
-      |> List.map (pull_and_serve `Service multi_hash)
-      |> Current.all
+    | deploys -> Current.all deploys

src/dune

@@ -35,6 +35,7 @@
   current_git
   current_github
   current_docker
+  current_compose_v2
   current_ocluster
   current_slack
   current_web

src/main.ml

@@ -20,12 +20,12 @@ let read_channel_uri path =
 
 let main () config mode app slack auth staging_password_file ((deployer : Pipeline.deployer), sched) prometheus_config =
   let vat = Capnp_rpc_unix.client_only_vat () in
-  let channel = read_channel_uri slack in
+  let channel = Option.map read_channel_uri slack in
   let staging_auth = staging_password_file |> Option.map (fun path -> staging_user, read_first_line path) in
   let authn = Option.map Current_github.Auth.make_login_uri auth in
   let webhook_secret = Current_github.App.webhook_secret app in
   let sched = Current_ocluster.Connection.create (Capnp_rpc_unix.Vat.import_exn vat sched) in
-  let engine = Current.Engine.create ~config (fun () -> deployer.pipeline ~app ~notify:channel ~sched ~staging_auth ()) in
+  let engine = Current.Engine.create ~config (fun () -> deployer.pipeline ~app ?notify:channel ~sched ~staging_auth ()) in
   let has_role =
     if auth = None then
       Current_web.Site.allow_all
@@ -52,10 +52,11 @@ let main () config mode app slack auth staging_password_file ((deployer : Pipeli
 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."
+    ~doc:"A file containing the URI of the endpoint for status updates. If \
+          omitted, no Slack notifications are sent."
     ~docv:"URI-FILE"
     ["slack"]