From 3f0fc09e72a48ddfd38762e174e58554d0f748b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Tue, 25 May 2021 08:40:58 +0200 Subject: [PATCH] Introduce a Docker backend for OBuilder --- .gitattributes | 3 + README.md | 37 ++-- dune-project | 6 +- example.spec | 16 +- lib/btrfs_store.ml | 7 +- lib/build.ml | 407 ++++++++++++++++++++++++++++++++++++++++- lib/build.mli | 6 + lib/docker.ml | 207 ++++++++++++++++++--- lib/docker.mli | 95 +++++++++- lib/docker_sandbox.ml | 245 +++++++++++++++++++++++++ lib/docker_sandbox.mli | 25 +++ lib/docker_store.ml | 207 +++++++++++++++++++++ lib/docker_store.mli | 7 + lib/dune | 7 + lib/manifest.ml | 15 +- lib/manifest.mli | 6 +- lib/obuilder.ml | 5 +- lib/os.ml | 85 +++++++++ lib/runc_sandbox.ml | 2 +- lib/store_spec.ml | 2 +- lib/tar_transfer.ml | 144 +++++++++++---- lib/tar_transfer.mli | 26 +++ lib/zfs_store.ml | 4 +- lib_spec/docker.ml | 18 +- lib_spec/spec.ml | 37 +++- lib_spec/spec.mli | 16 +- main.ml | 56 ++++-- obuilder.opam | 12 +- obuilder.opam.template | 6 + static/Dockerfile | 15 ++ static/extract.cmd | 13 ++ static/manifest.bash | 159 ++++++++++++++++ stress/stress.ml | 32 ++-- test/dune | 4 +- test/mock_exec.ml | 2 +- test/test.ml | 116 ++++++++---- 36 files changed, 1870 insertions(+), 180 deletions(-) create mode 100644 .gitattributes create mode 100644 lib/docker_sandbox.ml create mode 100644 lib/docker_sandbox.mli create mode 100644 lib/docker_store.ml create mode 100644 lib/docker_store.mli create mode 100644 obuilder.opam.template create mode 100644 static/Dockerfile create mode 100644 static/extract.cmd create mode 100755 static/manifest.bash diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000..c8c34fc1 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,3 @@ +*.cmd text eol=crlf +*.bash text eol=lf +*.sh text eol=lf diff --git a/README.md b/README.md index 0c6aa829..199e05e4 100644 --- a/README.md +++ b/README.md @@ -2,11 +2,13 @@ OBuilder takes a build script (similar to a Dockerfile) and performs the steps in it in a sandboxed environment. -After each step, OBuild uses the snapshot feature of the filesystem (ZFS or Btrfs) to store the state of the build. -Repeating a build will reuse the cached results where possible. +After each step, OBuilder uses the snapshot feature of the filesystem (ZFS or +Btrfs) to store the state of the build. On Linux, it uses `runc` to sandbox the +build steps, but any system that can run a command safely in a chroot could be +used. Repeating a build will reuse the cached results where possible. -OBuilder aims to be portable, although currently only Linux support is present. -On Linux, it uses `runc` to sandbox the build steps, but any system that can run a command safely in a chroot could be used. +OBuilder can also use Docker as a backend (fully replacing of `runc` and the +snapshotting filesystem) on any system supported by Docker (Linux, Windows, …). OBuilder stores the log output of each build step. This is useful for CI, where you may still want to see the output even if the result was cached from some other build. @@ -70,7 +72,7 @@ runc then sync operations will instead fail with `EPERM`. ## The build specification language -The spec files are loosly based on the [Dockerfile][] format. +The spec files are loosely based on the [Dockerfile][] format. The main difference is that the format uses S-expressions rather than a custom format, which should make it easier to generate and consume it automatically. @@ -99,9 +101,9 @@ The initial filesystem snapshot is `BASE`. `run` and `copy` operations create ne The initial context is supplied by the user (see [build.mli](lib/build.mli) for details). By default: - The environment is taken from the Docker configuration of `BASE`. -- The user is `(uid 0) (gid 0)`. -- The workdir is `/`. -- The shell is `/bin/bash -c`. +- The user is `(uid 0) (gid 0)` on Linux, `(name ContainerAdministrator)` on Windows. +- The workdir is `/`, `C:/` on Windows. +- The shell is `/bin/bash -c`, `C:/Windows/System32/cmd.exe` on Windows. ### Multi-stage builds @@ -125,7 +127,6 @@ For example: At the moment, the `(build ...)` items must appear before the `(from ...)` line. - ### workdir ```sexp @@ -164,7 +165,6 @@ The command run will be this list of arguments followed by the single argument ` (network NETWORK...)? (secrets SECRET...)? (shell COMMAND)) - ``` Examples: @@ -205,9 +205,9 @@ the image. Each `SECRET` entry is under the form `(ID (target PATH))`, where `ID `PATH` is the location of the mounted secret file within the container. The sandbox context API contains a `secrets` parameter to provide values to the runtime. If a requested secret isn't provided with a value, the runtime fails. -With the command line interface `obuilder`, use the `--secret ID:PATH` option to provide the path of the file -containing the secret for `ID`. -When used with Docker, make sure to use the **buildkit** syntax, as only buildkit supports a `--secret` option. +Use the `--secret ID:PATH` option to provide the path of the file containing the +secret for `ID`. +When used with Docker, make sure to use the **BuildKit** syntax, as only BuildKit supports a `--secret` option. (See https://docs.docker.com/develop/develop-images/build_enhancements/#new-docker-build-secret-information) ### copy @@ -256,13 +256,20 @@ Notes: - Both `SRC` and `DST` use `/` as the directory separator on all platforms. -- The copy is currently done by running `tar` inside the container to receive the files. - Therefore, the filesystem must have a working `tar` binary. +- The copy is currently done by running `tar` inside the container to receive + the files. Therefore, the filesystem must have a working `tar` binary. On + Windows when using the Docker backend, OBuilder provides a `tar` binary. + +- On Windows, copying from a build step image based on [Nano Server][nanoserver] + isn't supported. + +[nanoserver]: https://hub.docker.com/_/microsoft-windows-nanoserver ### user ```sexp (user (uid UID) (gid GID)) +(user (name NAME)) ; on Windows ``` Example: diff --git a/dune-project b/dune-project index 1fbad428..7afacfe0 100644 --- a/dune-project +++ b/dune-project @@ -17,15 +17,17 @@ (fmt (>= 0.8.9)) logs cmdliner - tar-unix + (tar (>= 1.2)) + (tar-unix (>= 1.2)) yojson sexplib ppx_deriving ppx_sexp_conv sha sqlite3 + (crunch :build) (obuilder-spec (= :version)) - (ocaml (>= 4.10.0)) + (ocaml (>= 4.13.0)) (alcotest-lwt :with-test))) (package (name obuilder-spec) diff --git a/example.spec b/example.spec index 74289039..9860c70d 100644 --- a/example.spec +++ b/example.spec @@ -1,4 +1,4 @@ -; This script builds OBuilder itself using a snapshot of the ocaml/opam:debian-10-4.12 base image. +; This script builds OBuilder itself using a snapshot of the ocaml/opam:debian-10-4.13 base image. ; ; Run it from the top-level of the OBuilder source tree, e.g. ; @@ -7,11 +7,11 @@ ; The result can then be found in /tank/HASH/rootfs/ (where HASH is displayed at the end of the build). ((build dev - ((from ocaml/opam@sha256:116c960addbbda19190d47b49e42310916cf42fe432fa5e37eb6104c488218d6) - (workdir /src) + ((from ocaml/opam@sha256:236175bf94d96d8b93d8ead26f0f7dc942ec7dcd4a5ed53b9c37982c85f24f61) + (workdir /project) (user (uid 1000) (gid 1000)) ; Build as the "opam" user - (run (shell "sudo chown opam /src")) - (env OPAM_HASH "de818e3f460f5fd30db492fc65de68d0957dfdd1") ; Fix the version of opam-repository we want + (run (shell "sudo chown opam /project")) + (env OPAM_HASH "bf04be33f42bfc33931df57adea016f1fa259d7a") ; Fix the version of opam-repository we want (run (network host) (shell @@ -35,8 +35,8 @@ (shell "opam install --deps-only -t obuilder")) (copy ; Copy the rest of the source code (src .) - (dst /src/) - (exclude .git _build)) + (dst /project/) + (exclude .git _build _opam)) (run (shell "opam exec -- dune build @install @runtest")))) ; Build and test ; Now generate a small runtime image with just the resulting binary: (from debian:10) @@ -44,6 +44,6 @@ (network host) (shell "apt-get update && apt-get install -y libsqlite3-0 --no-install-recommends")) (copy (from (build dev)) - (src /src/_build/default/main.exe) + (src /project/_build/default/main.exe) (dst /usr/local/bin/obuilder)) (run (shell "obuilder --help"))) diff --git a/lib/btrfs_store.ml b/lib/btrfs_store.ml index 7550a22c..fd8a46ea 100644 --- a/lib/btrfs_store.ml +++ b/lib/btrfs_store.ml @@ -165,8 +165,11 @@ let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t = (* Create writeable clone. *) let gen = cache.gen in Btrfs.subvolume_snapshot `RW ~src:snapshot tmp >>= fun () -> - let { Obuilder_spec.uid; gid } = user in - Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; tmp] >>= fun () -> + begin match user with + | `Unix { Obuilder_spec.uid; gid } -> + Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; tmp] + | _ -> assert false + end >>= fun () -> let release () = Lwt_mutex.with_lock cache.lock @@ fun () -> begin diff --git a/lib/build.ml b/lib/build.ml index 2951d4c2..ae55c5e3 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -2,15 +2,16 @@ open Lwt.Infix open Sexplib.Std let ( / ) = Filename.concat +let ( // ) p1 p2 = if Sys.win32 then p1 ^ "/" ^ p2 else Filename.concat p1 p2 let ( >>!= ) = Lwt_result.bind let hostname = "builder" -let healthcheck_base = "busybox" +let healthcheck_base = if Sys.win32 then "mcr.microsoft.com/windows/servercore:20H2" else "busybox" let healthcheck_ops = let open Obuilder_spec in [ - shell ["/bin/sh"; "-c"]; + shell (if Sys.win32 then ["cmd"; "/S"; "/C"] else ["/bin/sh"; "-c"]); run "echo healthcheck" ] @@ -29,7 +30,9 @@ module Context = struct secrets : (string * string) list; } - let v ?switch ?(env=[]) ?(user=Obuilder_spec.root) ?(workdir="/") ?(shell=["/bin/bash"; "-c"]) ?(secrets=[]) ~log ~src_dir () = + let v ?switch ?(env=[]) ?(user=Obuilder_spec.root) ?workdir ?shell ?(secrets=[]) ~log ~src_dir () = + let workdir = Option.value ~default:(if Sys.win32 then {|C:/|} else "/") workdir in + let shell = Option.value ~default:(if Sys.win32 then ["cmd"; "/S"; "/C"] else ["/bin/bash"; "-c"]) shell in { switch; env; src_dir; user; workdir; shell; log; scope = Scope.empty; secrets } let with_binding name value t = @@ -306,3 +309,401 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st let store = Store.wrap store in { store; sandbox } end + +module Docker = struct + module Store = Db_store.Make(Docker_store) + + type t = { + store : Store.t; + sandbox : Docker_sandbox.t; + } + + (* Inputs to run that should affect the hash. i.e. if anything in here changes + then we need a fresh build. *) + type run_input = { + base : S.id; + workdir : string; + user : Obuilder_spec.user; + env : Config.env; + cmd : string; + shell : string list; + network : string list; + mount_secrets : Config.Secret.t list; + } [@@deriving sexp_of] + + let docker_teardown_sandbox id ~commit = + let container = Docker.docker_container id in + let base_image = Docker.docker_image ~tmp:true id in + let target_image = Docker.docker_image id in + begin if commit then Docker.commit base_image container target_image else Lwt.return_unit end >>= fun () -> + Docker.rm [container] + + let run t ~switch ~log ~cache run_input = + let id = + sexp_of_run_input run_input + |> Sexplib.Sexp.to_string_mach + |> Sha256.string + |> Sha256.to_hex + in + let { base; workdir; user; env; cmd; shell; network; mount_secrets } = run_input in + Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log _ -> + let to_release = ref [] in + Lwt.finalize + (fun () -> + cache |> Lwt_list.map_s (fun { Obuilder_spec.Cache.id; target; buildkit_options = _ } -> + Store.cache ~user t.store id >|= fun (src, release) -> + to_release := release :: !to_release; + { Config.Mount.src; dst = target; readonly = false } + ) + >>= fun mounts -> + let argv = shell @ [cmd] in + let config = Config.v ~cwd:workdir ~argv ~hostname ~user ~env ~mounts ~mount_secrets ~network () in + Os.with_pipe_to_child @@ fun ~r:stdin ~w:close_me -> + Lwt_unix.close close_me >>= fun () -> + Lwt_result.bind_lwt + (Docker_sandbox.run ~cancelled ~stdin ~log t.sandbox config id) + (fun () -> docker_teardown_sandbox id ~commit:true) + ) + (fun () -> + !to_release |> Lwt_list.iter_s (fun f -> f ()) + ) + ) + + type copy_details = { + base : S.id; + user : Obuilder_spec.user; + op : [`Copy_items of Manifest.t list * string | `Copy_item of Manifest.t * string]; + } [@@deriving sexp_of] + + let rec sequence = function + | [] -> Ok [] + | Error e :: _ -> Error e + | Ok x :: xs -> + match sequence xs with + | Ok xs -> Ok (x :: xs) + | e -> e + + let to_copy_op ~dst = function + | [] -> Fmt.error_msg "No source items for copy!" + | items when dst.[String.length dst - 1] = '/' -> Ok (`Copy_items (items, dst)) + | [item] -> Ok (`Copy_item (item, dst)) + | _ -> Fmt.error_msg "When copying multiple items, the destination must end with '/'" + + let tarball_from_context ~src_dir op user ~to_untar = + Log.debug (fun f -> f "tarball_from_context"); + match op with + | `Copy_items (src_manifest, dst_dir) -> + Tar_transfer.send_files ~src_dir ~src_manifest ~dst_dir ~to_untar ~user + | `Copy_item (src_manifest, dst) -> + Tar_transfer.send_file ~src_dir ~src_manifest ~dst ~to_untar ~user + + let mount_point_inside_unix = if Sys.win32 then "/cygdrive/c" else "/var/lib/obuilder" + let mount_point_inside_native = if Sys.win32 then {|C:/|} else mount_point_inside_unix + + let manifest_from_build ~base ~exclude src workdir user = + let obuilder_volume = Docker.obuilder_volume () in + let docker_argv = [ + "--mount"; Printf.sprintf "type=volume,src=%s,dst=%s,readonly" obuilder_volume (mount_point_inside_native / obuilder_volume); + "--entrypoint"; if Sys.win32 then mount_point_inside_native / obuilder_volume / "bash.exe" else "bash"; + "--env"; Printf.sprintf "PATH=%s" (if Sys.win32 then mount_point_inside_unix // obuilder_volume else "/bin:/usr/bin"); + "--workdir"; workdir; + "--user"; match user with `Unix { Obuilder_spec.uid; gid } -> Printf.sprintf "%d:%d" uid gid | `Windows { Obuilder_spec.name } -> name + (* FIXME: we don't have access to isolation type here. *) + ] in + let manifest_bash = + (* FIXME: does Filename.quote always use Bash quoting rules? *) + Printf.sprintf "exec %s %S %S %d %s %d %s" + (mount_point_inside_unix // obuilder_volume // "manifest.bash") + workdir + "/" + (List.length exclude) + (String.concat " " (List.map Filename.quote exclude)) + (List.length src) + (String.concat " " (List.map Filename.quote src)) + in + let argv = [ "--login"; "-c"; manifest_bash ] in + let pp f = Os.pp_cmd f ["Generating source manifest"] in + Docker.run_pread_result ~pp ~rm:true docker_argv (Docker.docker_image base) argv >>!= fun manifests -> + match Parsexp.Many.parse_string manifests with + | Ok ts -> List.rev_map Manifest.t_of_sexp ts |> Lwt_result.return + | Error e -> Lwt_result.fail (`Msg (Parsexp.Parse_error.message e)) + + let manifest_files_from op fd = + let copy_root manifest = + let list = Manifest.to_from_files ~null:true manifest in + Os.write_all_string fd list 0 (String.length list) + in + match op with + | `Copy_items (src_manifest, _) -> Lwt_list.iter_s copy_root src_manifest + | `Copy_item (src_manifest, _) -> copy_root src_manifest + + let tarball_from_build t ~files_from ~tar workdir user id = + Log.debug (fun f -> f "docker_tarball_from_build"); + let argv = + ["--login"; "-c"; + String.concat " " + ([ if Sys.win32 then "tar.exe" else "tar"; + "-c"; "--format=ustar"; + "--directory"; workdir; + (* Beware, the order is meaningfull: --files-from should come last. *) + "--verbatim-files-from"; "--null"; "--absolute-names"; "--files-from=-"; + "-f-"])] + in + let config = + let obuilder_volume = Docker.obuilder_volume () in + Config.v + ~cwd:workdir + ~argv + ~hostname + ~user + ~env:["PATH", if Sys.win32 then mount_point_inside_unix // obuilder_volume else "/bin:/usr/bin"] + ~mount_secrets:[] + ~mounts:Config.Mount.[ + {src = obuilder_volume; dst = mount_point_inside_native / obuilder_volume; readonly = true}] + ~network:[] + ~entrypoint:(if Sys.win32 then mount_point_inside_native / obuilder_volume / "bash.exe" else "/bin/bash") + () + in + let docker_args, args = Docker_sandbox.Docker_config.make config t in + Docker.run ~stdin:(`FD_move_safely files_from) ~stdout:(`FD_move_safely tar) + ~rm:true docker_args (Docker.docker_image id) args + + let transform op ~user ~from_tar ~to_untar = + match op with + | `Copy_items (src_manifest, dst_dir) -> + Tar_transfer.transform_files ~from_tar ~src_manifest ~dst_dir ~user ~to_untar + | `Copy_item (src_manifest, dst) -> + Tar_transfer.transform_file ~from_tar ~src_manifest ~dst ~user ~to_untar + + let untar t ~cancelled ~stdin ~log id = + let obuilder_volume = Docker.obuilder_volume () in + let mounts = + if Sys.win32 then [Config.Mount.{ + src = obuilder_volume; + dst = mount_point_inside_native / obuilder_volume; + readonly = true; }] + else [] + in + let entrypoint = + if Sys.win32 then Printf.sprintf {|C:\%s\tar.exe|} obuilder_volume + else "/usr/bin/env" in + let argv = ["-xf"; "-"] + |> if not Sys.win32 then List.cons "tar" else Fun.id + in + let config = Config.v + ~cwd:(if Sys.unix then "/" else "C:/") + ~argv + ~hostname + ~user:Obuilder_spec.root + ~env:[] + ~mount_secrets:[] + ~mounts + ~network:[] + ~entrypoint + () + in + Lwt_result.bind_lwt + (Docker_sandbox.run ~cancelled ~stdin ~log t.sandbox config id) + (fun () -> docker_teardown_sandbox id ~commit:true) + + let copy t ~context ~base { Obuilder_spec.from; src; dst; exclude } = + let { Context.switch; src_dir; workdir; user; log; shell = _; env = _; scope; secrets = _ } = context in + let dst = if Filename.is_relative dst then workdir / dst else dst in + begin + match from with + | `Context -> Lwt_result.return (`Context src_dir) + | `Build name -> + match Scope.find_opt name scope with + | None -> Fmt.failwith "Unknown build %S" name (* (shouldn't happen; gets caught earlier) *) + | Some id -> + Store.result t.store id >>= function + | None -> + Lwt_result.fail (`Msg (Fmt.str "Build result %S not found" id)) + | Some dir -> + Lwt_result.return (`Build (id, dir)) + end >>!= fun src_dir -> + begin match src_dir with + | `Context src_dir -> sequence (List.map (Manifest.generate ~exclude ~src_dir) src) |> Lwt.return + | `Build (id, _) -> manifest_from_build ~base:id ~exclude src workdir user + end >>= fun src_manifest -> + match Result.bind src_manifest (to_copy_op ~dst) with + | Error _ as e -> Lwt.return e + | Ok op -> + let details = { + base; + op; + user; + } in + Log.debug (fun f -> f "COPY: %a@." Sexplib.Sexp.pp_hum (sexp_of_copy_details details)); + let id = Sha256.to_hex (Sha256.string (Sexplib.Sexp.to_string (sexp_of_copy_details details))) in + Store.build t.store ?switch ~base ~id ~log (fun ~cancelled ~log _ -> + (* If a sending thread finishes (or fails), close the + writing end of the previous pipes immediately so that the + receiving processes may finish too. *) + begin match src_dir with + | `Context src_dir -> + Os.with_pipe_between_children @@ fun ~r:stdin ~w:to_untar -> + let p1 = Lwt.finalize (fun () -> + let to_untar = Lwt_unix.of_unix_file_descr to_untar.raw in + tarball_from_context ~src_dir op user ~to_untar) + (fun () -> Lwt.return @@ Os.ensure_closed_unix to_untar) in + let p2 = untar t ~cancelled ~stdin ~log id in + Lwt.all [Lwt_result.ok p1; p2] + | `Build (from_id, _) -> + Os.with_pipe_to_child @@ fun ~r:files_from ~w:files_from_out -> + let f () = Os.ensure_closed_lwt files_from_out in + let p1 = Lwt.finalize (fun () -> manifest_files_from op files_from_out) f in + Os.with_pipe_between_children @@ fun ~r:from_tar ~w:tar -> + let f () = Os.ensure_closed_unix tar; f () in + let p2 = Lwt.finalize (fun () -> + tarball_from_build t.sandbox ~files_from ~tar workdir user from_id) f in + Os.with_pipe_between_children @@ fun ~r:stdin ~w:to_untar -> + let f () = Os.ensure_closed_unix to_untar; f () in + let p3 = Lwt.finalize (fun () -> + let from_tar = Lwt_unix.of_unix_file_descr from_tar.raw in + let to_untar = Lwt_unix.of_unix_file_descr to_untar.raw in + transform op ~user ~from_tar ~to_untar) f in + let p4 = untar t ~cancelled ~stdin ~log id in + Lwt.all [Lwt_result.ok p1; Lwt_result.ok p2; Lwt_result.ok p3; p4] + end >>= fun all -> + Lwt.return @@ List.fold_left (fun r p -> match p with Ok _ -> r | Error _ -> p) (Result.ok ()) all) + + let pp_op ~(context:Context.t) f op = + Fmt.pf f "@[%s: %a@]" context.workdir Obuilder_spec.pp_op op + + let update_workdir ~(context:Context.t) path = + let workdir = + if Astring.String.is_prefix ~affix:(if Sys.win32 then {|C:/|} else "/") path then path + else Filename.concat context.workdir path + in + { context with workdir } + + let mount_secret (values : (string * string) list) (secret: Obuilder_spec.Secret.t) = + match List.assoc_opt secret.id values with + | None -> Error (`Msg ("Couldn't find value for requested secret '"^secret.id^"'") ) + | Some value -> Ok Config.Secret.{value; target=secret.target} + + let resolve_secrets (values : (string * string) list) (secrets: Obuilder_spec.Secret.t list) = + let (>>=) = Result.bind in + let (>>|) x y = Result.map y x in + List.fold_left (fun result secret -> + result >>= fun result -> + mount_secret values secret >>| fun resolved_secret -> + (resolved_secret :: result) ) (Ok []) secrets + + let rec run_steps t ~(context:Context.t) ~base = function + | [] -> Lwt_result.return base + | op :: ops -> + context.log `Heading Fmt.(strf "%a" (pp_op ~context) op); + let k = run_steps t ops in + match op with + | `Comment _ -> k ~base ~context + | `Workdir workdir -> k ~base ~context:(update_workdir ~context workdir) + | `User user -> k ~base ~context:{context with user} + | `Run { shell = cmd; cache; network; secrets = mount_secrets } -> + let result = + let { Context.switch; workdir; user; env; shell; log; src_dir = _; scope = _; secrets } = context in + resolve_secrets secrets mount_secrets |> Result.map @@ fun mount_secrets -> + (switch, { base; workdir; user; env; cmd; shell; network; mount_secrets }, log) + in + Lwt.return result >>!= fun (switch, run_input, log) -> + run t ~switch ~log ~cache run_input >>!= fun base -> + k ~base ~context + | `Copy x -> + copy t ~context ~base x >>!= fun base -> + k ~base ~context + | `Env ((key, _) as e) -> + let env = e :: (List.remove_assoc key context.env) in + k ~base ~context:{context with env} + | `Shell shell -> + k ~base ~context:{context with shell} + + let get_base t ~log base = + log `Heading (Fmt.strf "(from %a)" Sexplib.Sexp.pp_hum (Atom base)); + let id = Sha256.to_hex (Sha256.string base) in + Store.build t.store ~id ~log (fun ~cancelled:_ ~log tmp -> + ignore log; + Log.info (fun f -> f "Base image not present; importing %S..." base); + let rootfs = tmp / "rootfs" in + Os.sudo ["mkdir"; "--mode=755"; "--"; rootfs] >>= fun () -> + Docker.pull (`Docker_image base) >>= fun () -> + Os.write_file ~path:(tmp / "env") + (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env=[]})) >>= fun () -> + Docker.tag (`Docker_image base) (Docker.docker_image id) >>= fun () -> + Lwt_result.return () + ) + >>!= fun id -> Store.result t.store id + >|= Option.get >>= fun path -> + Lwt_unix.file_exists (path / "env") >>= fun b -> begin + if b then Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) + else { Saved_context.env = [] } end |> Lwt.return + >>= fun { Saved_context.env } -> + Lwt_result.return (id, env) + + let rec build ~scope t context { Obuilder_spec.child_builds; from = base; ops } = + let rec aux context = function + | [] -> Lwt_result.return context + | (name, child_spec) :: child_builds -> + context.Context.log `Heading Fmt.(strf "(build %S ...)" name); + build ~scope t context child_spec >>!= fun child_result -> + context.Context.log `Note Fmt.(strf "--> finished %S" name); + let context = Context.with_binding name child_result context in + aux context child_builds + in + aux context child_builds >>!= fun context -> + get_base t ~log:context.Context.log base >>!= fun (id, env) -> + let context = { context with env = context.env @ env } in + run_steps t ~context ~base:id ops + + let build t context spec = + let r = build ~scope:[] t context spec in + (r : (string, [ `Cancelled | `Msg of string ]) Lwt_result.t :> (string, [> `Cancelled | `Msg of string ]) Lwt_result.t) + + let delete ?log t id = + Store.delete ?log t.store id + + let prune ?log t ~before limit = + Store.prune ?log t.store ~before limit + + let log_to buffer tag x = + match tag with + | `Heading | `Note -> Buffer.add_string buffer (x ^ "\n") + | `Output -> Buffer.add_string buffer x + + let healthcheck ?(timeout=30.0) t = + Os.with_pipe_from_child (fun ~r ~w -> + let pp f = Fmt.string f "docker version" in + let result = Os.exec_result ~pp ~stdout:`Dev_null ~stderr:(`FD_move_safely w) ["docker"; "version"] in + let r = Lwt_io.(of_fd ~mode:input) r ~close:Lwt.return in + Lwt_io.read r >>= fun err -> + result >>= function + | Ok () -> Lwt_result.return () + | Error (`Msg m) -> Lwt_result.fail (`Msg (Fmt.str "%s@.%s" m (String.trim err))) + ) >>!= fun () -> + let buffer = Buffer.create 1024 in + let log = log_to buffer in + (* Get the base image first, before starting the timer. *) + let switch = Lwt_switch.create () in + let context = Context.v ~switch ~log ~src_dir:"/tmp" () in + get_base t ~log healthcheck_base >>= function + | Error (`Msg _) as x -> Lwt.return x + | Error `Cancelled -> failwith "Cancelled getting base image (shouldn't happen!)" + | Ok (id, env) -> + let context = { context with env } in + (* Start the timer *) + Lwt.async (fun () -> + Lwt_unix.sleep timeout >>= fun () -> + Lwt_switch.turn_off switch + ); + run_steps t ~context ~base:id healthcheck_ops >>= function + | Ok id -> Store.delete t.store id >|= Result.ok + | Error (`Msg msg) as x -> + let log = String.trim (Buffer.contents buffer) in + if log = "" then Lwt.return x + else Lwt.return (Fmt.error_msg "%s@.%s" msg log) + | Error `Cancelled -> Lwt.return (Fmt.error_msg "Timeout running healthcheck") + + let v ~store ~sandbox = + let store = Store.wrap store in + { store; sandbox } +end diff --git a/lib/build.mli b/lib/build.mli index 5f94b364..f69434b4 100644 --- a/lib/build.mli +++ b/lib/build.mli @@ -27,3 +27,9 @@ module Make (Store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) : sig val v : store:Store.t -> sandbox:Sandbox.t -> t end + +module Docker : sig + include S.BUILDER with type context := Context.t + + val v : store:Docker_store.t -> sandbox:Docker_sandbox.t -> t +end diff --git a/lib/docker.ml b/lib/docker.ml index c52f1fd2..6ca79d52 100644 --- a/lib/docker.ml +++ b/lib/docker.ml @@ -1,37 +1,184 @@ -open Lwt.Infix - -let export_env base : Config.env Lwt.t = - Os.pread ["docker"; "image"; "inspect"; - "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|}; - "--"; base] >|= fun env -> - String.split_on_char '\x00' env - |> List.filter_map (function - | "\n" -> None - | kv -> - match Astring.String.cut ~sep:"=" kv with - | None -> Fmt.failwith "Invalid environment in Docker image %S (should be 'K=V')" kv - | Some _ as pair -> pair - ) +open Lwt.Syntax + +type ids = [ + | `Docker_image of string | `Docker_container of string + | `Docker_volume of string | `Obuilder_id of string +] + +let prefix = ref "obuilder-" +let set_prefix prefix' = prefix := prefix' + +let image_prefix () = !prefix ^ "image-" +let container_prefix () = !prefix ^ "container-" +let cache_prefix () = !prefix ^ "cache-" +let volume_prefix () = !prefix ^ "copy-" + +let obuilder_volume () = !prefix ^ "volume" +let image_name ?(tmp=false) name = image_prefix () ^ (if tmp then "tmp-" else "") ^ name +let container_name name = container_prefix () ^ name +let volume_cache_name ?(tmp=false) name = cache_prefix () ^ (if tmp then "tmp-" else "") ^ name +let volume_copy_name ?(tmp=false) name = volume_prefix () ^ (if tmp then "tmp-" else "") ^ name + +let result root id = Filename.concat root id + +let docker_image ?(tmp=false) id = `Docker_image (image_name ~tmp id) +let docker_container id = `Docker_container (container_name id) +let docker_volume_cache ?(tmp=false) id = `Docker_volume (volume_cache_name ~tmp id) +let docker_volume_copy ?(tmp=false) id = `Docker_volume (volume_copy_name ~tmp id) + +let extract_name = function `Docker_image name | `Docker_container name | `Docker_volume name -> name + +let pread' ?stderr argv = + Os.pread ?stderr ("docker" :: argv) + +let pread_result' ~pp ?stderr argv = + Os.pread_result ~pp ?stderr ("docker" :: argv) + +let exec' ?stdin ?stdout ?stderr argv = + Os.exec ?stdin ?stdout ?stderr ("docker" :: argv) + +let exec_result' ?stdin ?stdout ?stderr ~pp argv = + Os.exec_result ?stdin ?stdout ?stderr ~pp ("docker" :: argv) + +let create ?stderr (`Docker_image base) = + pread' ?stderr ("create" :: ["--"; base]) + +let export ?stdout (`Docker_container id) = + exec' ?stdout ["export"; "--"; id] + +let image ?stdout cmd (`Docker_image id) = + exec' ?stdout ["image"; cmd; id] + +let rm ?stdout containers = + exec' ?stdout ("rm" :: "--force" :: "--" :: (List.rev_map extract_name containers)) + +let tag ?stdout ?stderr (`Docker_image source) (`Docker_image target) = + exec' ?stdout ?stderr ["tag"; source; target] + +let commit ?stdout (`Docker_image base_image) (`Docker_container container) (`Docker_image target_image) = + (* Restore CMD and ENTRYPOINT *) + let* entrypoint = pread' ["inspect"; "--type=image"; "--format={{json .Config.Entrypoint }}"; "--"; base_image] in + let* cmd = pread' ["inspect"; "--type=image"; "--format={{json .Config.Cmd }}"; "--"; base_image] in + let entrypoint, cmd = String.trim entrypoint, String.trim cmd in + let argv = [ "--"; container; target_image ] in + let argv = if entrypoint = "null" then argv else ("--change=ENTRYPOINT " ^ entrypoint) :: argv in + let argv = if cmd = "null" then argv else ("--change=CMD " ^ cmd) :: argv in + exec' ?stdout ("commit" :: argv) + +let pull ?stderr (`Docker_image base) = + exec' ?stderr ["pull"; base] + +let exists id = + let pp f = Fmt.string f "docker inspect" in + let pp' f = Fmt.string f "docker volume inspect" in + let pp, argv = match id with + | `Docker_container id -> pp, ["inspect"; "--type=container"; "--"; id] + | `Docker_image id -> pp, ["inspect"; "--type=image"; "--"; id] + | `Docker_volume id -> pp', ["volume"; "inspect"; "--"; id] + in + exec_result' ~stdout:`Dev_null ~stderr:`Dev_null ~pp argv + +let build docker_argv (`Docker_image image) context_path = + exec' ("build" :: docker_argv @ ["-t"; image; context_path]) + +let run ?stdin ?stdout ?stderr ?name ?(rm=false) docker_argv (`Docker_image image) argv = + let docker_argv = if rm then "--rm" :: docker_argv else docker_argv in + let docker_argv = Option.fold ~none:docker_argv ~some:(fun (`Docker_container name) -> "--name" :: name :: docker_argv) name in + let docker_argv = match stdin with Some (`FD_move_safely _) -> "-i" :: docker_argv | _ -> docker_argv in + let argv = docker_argv @ image :: argv in + exec' ?stdin ?stdout ?stderr ("run" :: argv) + +let run_result ?stdin ?stdout ?stderr ~pp ?name ?(rm=false) docker_argv (`Docker_image image) argv = + let docker_argv = if rm then "--rm" :: docker_argv else docker_argv in + let docker_argv = Option.fold ~none:docker_argv ~some:(fun (`Docker_container name) -> "--name" :: name :: docker_argv) name in + let docker_argv = match stdin with Some (`FD_move_safely _) -> "-i" :: docker_argv | _ -> docker_argv in + let argv = docker_argv @ image :: argv in + exec_result' ?stdin ?stdout ?stderr ~pp ("run" :: argv) + +let run_pread_result ?stderr ~pp ?name ?(rm=false) docker_argv (`Docker_image image) argv = + let docker_argv = if rm then "--rm" :: docker_argv else docker_argv in + let docker_argv = Option.fold ~none:docker_argv ~some:(fun (`Docker_container name) -> "--name" :: name :: docker_argv) name in + let argv = docker_argv @ image :: argv in + pread_result' ?stderr ~pp ("run" :: argv) + +let stop ~pp (`Docker_container name) = + exec_result' ~pp ["stop"; name] + +let volume = function + | `Create (`Docker_volume name) -> pread' ("volume" :: "create" :: "--" :: name :: []) + | `Inspect (volumes, `Mountpoint) -> + let volumes = List.rev_map extract_name volumes in + let format = "{{ .Mountpoint }}" in + pread' ("volume" :: "inspect" :: "--format" :: format :: "--" :: volumes) + | `List (filter) -> + let filter = match filter with None -> [] | Some filter -> ["--filter"; filter] in + pread' ("volume" :: "ls" :: "--quiet" :: filter) + | `Remove volumes -> + let volumes = List.rev_map extract_name volumes in + pread' ("volume" :: "rm" :: "--" :: volumes) + +let mount_point name = + let* s = volume (`Inspect ([name], `Mountpoint)) in + Lwt.return (String.trim s) + +let rmi ?stdout images = + exec' ?stdout ("rmi" :: (List.rev_map extract_name images)) + +let obuilder_images () = + let* images = pread' ["images"; "--format={{ .Repository }}"; !prefix ^ "*"] in + String.split_on_char '\n' images + |> List.filter_map (function "" -> None | id -> Some (`Docker_image id)) + |> Lwt.return + +let obuilder_containers () = + let* containers = pread' ["container"; "ls"; "--all"; "--filter"; "name=^" ^ !prefix; "-q"] in + String.split_on_char '\n' containers + |> List.filter_map (function "" -> None | id -> Some (`Docker_container id)) + |> Lwt.return + +let obuilder_volumes () = + let* volumes = volume (`List (Some ("name=^" ^ !prefix))) in + String.split_on_char '\n' volumes + |> List.filter_map (function "" -> None | id -> Some (`Docker_volume id)) + |> Lwt.return let with_container ~log base fn = - Os.with_pipe_from_child (fun ~r ~w -> + let* cid = Os.with_pipe_from_child (fun ~r ~w -> (* We might need to do a pull here, so log the output to show progress. *) let copy = Build_log.copy ~src:r ~dst:log in - Os.pread ~stderr:(`FD_move_safely w) ["docker"; "create"; "--"; base] >>= fun cid -> - copy >|= fun () -> + let* cid = create ~stderr:(`FD_move_safely w) (`Docker_image base) in + let+ () = copy in String.trim cid - ) >>= fun cid -> + ) + in Lwt.finalize (fun () -> fn cid) - (fun () -> Os.exec ~stdout:`Dev_null ["docker"; "rm"; "--"; cid]) - - -let fetch ~log ~rootfs base = - with_container ~log base (fun cid -> - Os.with_pipe_between_children @@ fun ~r ~w -> - let exporter = Os.exec ~stdout:(`FD_move_safely w) ["docker"; "export"; "--"; cid] in - let tar = Os.sudo ~stdin:(`FD_move_safely r) ["tar"; "-C"; rootfs; "-xf"; "-"] in - exporter >>= fun () -> - tar - ) >>= fun () -> - export_env base + (fun () -> rm ~stdout:`Dev_null [`Docker_container cid]) + +module Extract = struct + let export_env base : Config.env Lwt.t = + let+ env = + pread' ["image"; "inspect"; + "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|}; + "--"; base] in + String.split_on_char '\x00' env + |> List.filter_map (function + | "\n" -> None + | kv -> + match Astring.String.cut ~sep:"=" kv with + | None -> Fmt.failwith "Invalid environment in Docker image %S (should be 'K=V')" kv + | Some _ as pair -> pair + ) + + let fetch ~log ~rootfs base = + Log.debug (fun f -> f "Docker fetcher extract rootfs:%s base:%s" rootfs base); + let* () = with_container ~log base (fun cid -> + Os.with_pipe_between_children @@ fun ~r ~w -> + let exporter = export ~stdout:(`FD_move_safely w) (`Docker_container cid) in + let tar = Os.sudo ~stdin:(`FD_move_safely r) ["tar"; "-C"; rootfs; "-xf"; "-"] in + let* () = exporter in + tar + ) + in + export_env base +end diff --git a/lib/docker.mli b/lib/docker.mli index 1738c712..ecd50faf 100644 --- a/lib/docker.mli +++ b/lib/docker.mli @@ -1,3 +1,94 @@ -(** Fetching of base images using Docker *) +(** Docker interface over the CLI tool *) -include S.FETCHER +type ids = [ + | `Docker_container of string | `Docker_image of string + | `Docker_volume of string + | `Obuilder_id of string +] + +val set_prefix : string -> unit +(** Set the prefix for Docker images, containers, and volumes managed + by the current OBuilder instance. *) + +val obuilder_volume : unit -> string +val image_name : ?tmp:bool -> S.id -> string +val container_name : S.id -> string +val volume_copy_name : ?tmp:bool -> S.id -> string + +val docker_image : ?tmp:bool -> S.id -> [> `Docker_image of string ] +val docker_container : S.id -> [> `Docker_container of string ] +val docker_volume_cache : ?tmp:bool -> S.id -> [> `Docker_volume of string ] +val docker_volume_copy : ?tmp:bool -> S.id -> [> `Docker_volume of string ] + +val result : string -> string -> string + +val pull : ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + [< `Docker_image of string ] -> unit Lwt.t +val export : ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + [< `Docker_container of string ] -> unit Lwt.t +val image : ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + string -> [< `Docker_image of string ] -> unit Lwt.t +val rm : ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + [ `Docker_container of string ] list -> unit Lwt.t +val rmi : ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + [ `Docker_image of string ] list -> unit Lwt.t +val tag : ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + [< `Docker_image of string ] -> [< `Docker_image of string ] -> + unit Lwt.t +val commit : ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + [< `Docker_image of string ] -> + [< `Docker_container of string ] -> + [< `Docker_image of string ] -> + unit Lwt.t +val volume : + [< `Create of [< `Docker_volume of string ] + | `Inspect of [< `Docker_volume of string ] list * [< `Mountpoint ] + | `List of string option + | `Remove of [< `Docker_volume of string ] list ] -> + string Lwt.t +val mount_point : [< `Docker_volume of string ] -> string Lwt.t +val build : string list -> [< `Docker_image of string ] -> string -> unit Lwt.t +val run : ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?name:[< `Docker_container of string ] -> + ?rm:bool -> + string list -> + [< `Docker_image of string ] -> + string list -> + unit Lwt.t +val run_result : ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + pp:(Format.formatter -> unit) -> + ?name:[< `Docker_container of string ] -> + ?rm:bool -> + string list -> + [< `Docker_image of string ] -> + string list -> + (unit, [> `Msg of string ]) Result.result Lwt.t +val run_pread_result : ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + pp:(Format.formatter -> unit) -> + ?name:[< `Docker_container of string ] -> + ?rm:bool -> + string list -> + [< `Docker_image of string ] -> + string list -> + (string, [> `Msg of string ]) Result.result Lwt.t +val stop : pp:(Format.formatter -> unit) -> + [< `Docker_container of string ] -> + (unit, [> `Msg of string ]) Result.result Lwt.t + +val exists : [< `Docker_container of string | `Docker_image of string + | `Docker_volume of string ] -> + (unit, [> `Msg of string ]) result Lwt.t + +val obuilder_images : unit -> [ `Docker_image of string ] list Lwt.t +val obuilder_containers : unit -> [ `Docker_container of string ] list Lwt.t +val obuilder_volumes : unit -> [ `Docker_volume of string ] list Lwt.t + +(** Fetch (pull and extract) base images using Docker *) +module Extract : sig + include S.FETCHER +end diff --git a/lib/docker_sandbox.ml b/lib/docker_sandbox.ml new file mode 100644 index 00000000..7d21d730 --- /dev/null +++ b/lib/docker_sandbox.ml @@ -0,0 +1,245 @@ +open Lwt.Syntax +open Sexplib.Conv + +let ( / ) = Filename.concat + +type isolation = [ `HyperV | `Process | `Default ] [@@deriving sexp] +let isolations : (isolation * string) list = [(`HyperV, "hyperv"); (`Process, "process"); (`Default, "default")] + +type t = { + state_dir : string; + docker_cpus : int; + docker_isolation : isolation; +} + +type config = { + docker_cpus : int; + docker_isolation : isolation; + docker_clean : bool; +} [@@deriving sexp] + +let secrets_guest_root = if Sys.win32 then {|C:\ProgramData\obuilder\|} else "/run/secrets/obuilder" +let secret_dir id = "secrets" / string_of_int id + +module Docker_config = struct + let make {Config.cwd; argv; hostname; user; env; mounts; network; mount_secrets; entrypoint} + ?(config_dir="") ({docker_cpus; docker_isolation; _} : t) = + let mounts = mounts |> List.concat_map (fun mount -> + [ "--mount"; Config.Mount.(Printf.sprintf "type=volume,src=%s,dst=%s%s" + mount.src mount.dst (if mount.readonly then ",readonly" else "")) ]) in + let env = env |> List.concat_map (fun (k, v) -> [ "--env"; Printf.sprintf "%s=%s" k v ]) in + let network = network |> List.concat_map (fun network -> ["--network"; network]) in + let user = + match user with + | `Unix { Obuilder_spec.uid; gid } when not Sys.win32 -> ["--user"; Printf.sprintf "%d:%d" uid gid] + | `Windows { name } when Sys.win32 -> ["--user"; name] + | _ -> assert false + in + let (_, mount_secrets) = + List.fold_left (fun (id, mount_secrets) _ -> + let host, guest = config_dir / secret_dir id, secrets_guest_root / secret_dir id in + let argv = "--mount" :: (Printf.sprintf "type=bind,src=%s,dst=%s,readonly" host guest) :: mount_secrets in + id + 1, argv) + (0, []) mount_secrets in + let entrypoint = Option.fold ~none:[] ~some:(fun exe -> ["--entrypoint"; exe]) entrypoint in + let docker_argv = [ + "--cpus"; string_of_int docker_cpus; + "--isolation"; (List.assoc docker_isolation isolations); + "--hostname"; hostname; + "--workdir"; cwd; + ] @ user @ env @ mounts @ mount_secrets @ network @ entrypoint in + docker_argv, argv +end + +let secrets_layer mount_secrets base_image container docker_argv = + (* FIXME: the shell, mkdir mklink/ln should come from a trusted + volume rather than the container itself. *) + let link id link = + let target = secrets_guest_root / secret_dir id / "secret" in + if Sys.win32 then + ["mkdir"; Filename.dirname link; "&&"; + "mklink"; link; target] + else + ["mkdir"; "-p"; Filename.(dirname link |> quote); "&&"; + "ln"; "-s"; "--"; Filename.quote target; Filename.quote link] + in + let (_, argv) = + List.fold_left (fun (id, argv) {Config.Secret.target; _} -> + let argv = if argv = [] then link id target else argv @ "&&" :: link id target in + id + 1, argv) + (0, []) mount_secrets + in + if mount_secrets = [] then + Lwt_result.ok Lwt.return_unit + else + let docker_argv, argv = + if Sys.win32 then + docker_argv @ ["--entrypoint"; {|C:\Windows\System32\cmd.exe|}], + ["/S"; "/C"; String.concat " " argv] + else + docker_argv @ ["--entrypoint"; {|/bin/sh|}], + ["-c"; String.concat " " argv] + in + let pp f = Os.pp_cmd f ("docker" :: "run" :: docker_argv @ argv) in + Lwt_result.bind_lwt + (Docker.run_result ~pp ~name:container docker_argv base_image argv) + (fun () -> + let* () = Docker.commit base_image container base_image in + Docker.rm [container]) + +let run ~cancelled ?stdin ~log t config (id:S.id) = + Lwt_io.with_temp_dir ~perm:0o700 ~prefix:"obuilder-docker-" @@ fun tmp -> + let docker_argv, argv = Docker_config.make config ~config_dir:tmp t in + let* _ = Lwt_list.fold_left_s + (fun id Config.Secret.{value; _} -> + Os.ensure_dir (tmp / "secrets"); + Os.ensure_dir (tmp / secret_dir id); + let+ () = Os.write_file ~path:(tmp / secret_dir id / "secret") value in + id + 1 + ) 0 config.mount_secrets + in + let container = Docker.docker_container id in + let base_image = Docker.docker_image ~tmp:true id in + Os.with_pipe_from_child @@ fun ~r:out_r ~w:out_w -> + let stdout = `FD_move_safely out_w in + let stderr = stdout in + let copy_log = Build_log.copy ~src:out_r ~dst:log in + let proc = + Lwt_result.bind + (secrets_layer config.Config.mount_secrets base_image container docker_argv) + (fun () -> + let stdin = Option.map (fun x -> `FD_move_safely x) stdin in + let pp f = Os.pp_cmd f ("docker" :: "run" :: docker_argv @ argv) in + Docker.run_result ?stdin ~stdout ~stderr ~pp ~name:container docker_argv base_image argv) + in + Lwt.on_termination cancelled (fun () -> + let rec aux () = + if Lwt.is_sleeping proc then ( + let pp f = Fmt.pf f "docker stop %S" id in + let* r = Docker.stop ~pp container in + match r with + | Ok () -> Lwt.return_unit + | Error (`Msg m) -> + (* This might be because it hasn't been created yet, so retry. *) + Log.warn (fun f -> f "stop failed: %s (will retry in 10s)" m); + let* () = Lwt_unix.sleep 10.0 in + aux () + ) else Lwt.return_unit (* Process has already finished *) + in + Lwt.async aux + ); + let* r = proc in + let* () = copy_log in + let* () = match r with + | Ok () -> Lwt.return_unit + | _ -> Docker.rm [container] + in + if Lwt.is_sleeping cancelled then Lwt.return (r :> (unit, [`Msg of string | `Cancelled]) result) + else Lwt_result.fail `Cancelled + +let clean_docker ?(docker_data=false) dir = + let* () = + if docker_data then begin + Log.warn (fun f -> f "Removing left-over Docker containers"); + let* containers = Docker.obuilder_containers () in + let* () = if containers <> [] then Docker.rm containers else Lwt.return_unit in + Log.warn (fun f -> f "Removing left-over Docker images"); + let* images = Docker.obuilder_images () in + let* () = if images <> [] then Docker.rmi images else Lwt.return_unit in + Log.warn (fun f -> f "Removing left-over Docker volumes"); + let* volumes = Docker.obuilder_volumes () in + let* _ = if volumes <> [] then Docker.volume (`Remove volumes) else Lwt.return "" in + Lwt.return_unit + end else Lwt.return_unit in + Sys.readdir dir + |> Array.to_list + |> Lwt_list.iter_s (fun item -> + Log.warn (fun f -> f "Removing left-over docker sandbox data %S" item); + Os.delete_recursively item + ) + +(* Windows ships a bsdtar that doesn't support symlinks (neither when + creating the tar archive, nor when extracting it). We need a + working tar for copying files in and out Docker images, so we pull + Cygwin, install it, and extract tar and its dependencies in a + Docker volume that is mounted each time we need tar. + + On Linux, we assume a tar is always present in /usr/bin/tar. + + We use `manifest.bash', an implementation of {!Manifest} in Bash, to + extract the tar manifest from the Docker image. *) +let create_tar_volume isolation = + Log.info (fun f -> f "Preparing tar volume..."); + let* _ = Docker.volume (`Create (`Docker_volume (Docker.obuilder_volume ()))) in + let* () = if Sys.win32 then begin + let cygwin_root = {|C:\cygwin64|} in + let* () = Lwt_io.(with_temp_dir ~perm:0o700 @@ fun temp_dir -> + let* () = Lwt_list.iter_p (fun name -> + with_file ~perm:0o400 ~mode:Output (temp_dir / name) @@ fun ch -> + fprint ch (Option.get (Static_files.read name))) ["Dockerfile"; "extract.cmd"] in + Array.iter (fun s -> Log.debug (fun f -> f "%s"s )) (Sys.readdir temp_dir); + let docker_argv = [ + "--isolation"; List.assoc isolation isolations; + Printf.sprintf "--build-arg=CYGWIN_ROOT=%s" cygwin_root; + "--network"; "Default Switch"; + ] in + Docker.build docker_argv (`Docker_image (Docker.obuilder_volume ())) temp_dir) in + let destination = Printf.sprintf {|C:\%s|} (Docker.obuilder_volume ()) in + let docker_argv = [ + "--isolation"; List.assoc isolation isolations; + "--mount"; Printf.sprintf "type=volume,src=%s,dst=%s" (Docker.obuilder_volume ()) destination; + "--env"; Printf.sprintf "CYGWIN_ROOT=%s" cygwin_root; + "--env"; Printf.sprintf "DESTINATION=%s" destination; + "--entrypoint"; {|C:\Windows\System32\cmd.exe|}; + ] in + Docker.run ~rm:true docker_argv (`Docker_image (Docker.obuilder_volume ())) ["/S"; "/C"; {|C:\extract.cmd|}] + end else Lwt.return_unit in + let* mount_point = Docker.mount_point (`Docker_volume (Docker.obuilder_volume ())) in + let name = "manifest.bash" in + let write_manifest_bash ch = Lwt_io.fprint ch (Option.get (Static_files.read name)) in + if Sys.win32 then + Lwt_io.(with_file ~perm:0o500 ~mode:Output (mount_point / name) write_manifest_bash) + else + Lwt_io.(with_temp_file ~perm:0o500 @@ fun (temp_name, ch) -> + let* () = write_manifest_bash ch in + Os.sudo ["cp"; "--"; temp_name; mount_point / name]) + +let create ~state_dir (c : config) = + Log.debug (fun f -> f "Docker sandbox: create %s" state_dir); + Os.ensure_dir state_dir; + let* () = clean_docker ~docker_data:c.docker_clean state_dir in + let* volume_exists = Docker.exists (`Docker_volume (Docker.obuilder_volume ())) in + let* () = if Result.is_error volume_exists then create_tar_volume c.docker_isolation else Lwt.return_unit in + Lwt.return { state_dir; docker_cpus = c.docker_cpus; docker_isolation = c.docker_isolation } + +open Cmdliner + +let docker_clean = + Arg.value @@ + Arg.flag @@ + Arg.info + ~doc:"Remove all associated Docker data (images, containers, volumes) at startup." + ["docker-clean"] + +let docker_cpus = + Arg.value @@ + Arg.opt Arg.int 2 @@ + Arg.info + ~doc:"Number of CPUs to be used by Docker" + ["docker-cpus"] + +let docker_isolation = + let isolations = List.rev_map (fun (k, v) -> v, k) isolations in + let doc = Arg.doc_alts_enum isolations |> Printf.sprintf + "Docker isolation, must be %s. Only `default' is available on \ + Linux, only `process' and `hyperv' are available on Windows" in + Arg.value @@ + Arg.opt (Arg.enum isolations) (if Sys.win32 then `HyperV else `Default) @@ + Arg.info ~doc + ["docker-isolation"] + +let cmdliner : config Term.t = + let make docker_cpus docker_isolation docker_clean = + { docker_cpus; docker_isolation; docker_clean } + in + Term.(const make $ docker_cpus $ docker_isolation $ docker_clean) diff --git a/lib/docker_sandbox.mli b/lib/docker_sandbox.mli new file mode 100644 index 00000000..3d818955 --- /dev/null +++ b/lib/docker_sandbox.mli @@ -0,0 +1,25 @@ +(** Sandbox builds using Docker. *) + +include S.SANDBOX + +module Docker_config : sig + val make : Config.t -> ?config_dir:string -> t -> string list * string list + (** [make obuilder_config ~config_dir sandbox_config] returns + [docker_argv, argv] where [docker_argv] is the list of arguments + to give to the Docker command-line client, and [argv] the command + to execute in the container. *) +end +(** Derive Docker command-line client parameters from an OBuilder + configuration. *) + +type config [@@deriving sexp] +(** The type of sandbox configurations *) + +val cmdliner : config Cmdliner.Term.t +(** [cmdliner] is used for command-line interfaces to generate the + necessary flags and parameters to setup a specific sandbox's + configuration. *) + +val create : state_dir:string -> config -> t Lwt.t +(** [create ~state_dir config] is a Docker sandboxing system that + keeps state in [state_dir] and is configured using [config]. *) diff --git a/lib/docker_store.ml b/lib/docker_store.ml new file mode 100644 index 00000000..829082e9 --- /dev/null +++ b/lib/docker_store.ml @@ -0,0 +1,207 @@ +open Lwt.Syntax + +(* Represents a persistent cache. + You must hold a cache's lock when removing or updating its entry in + "cache", and must assume this may happen at any time when not holding it. + The generation counter is used to check whether the cache has been updated + since being cloned. The counter starts from zero when the in-memory cache + value is created (i.e. you cannot compare across restarts). *) +type cache = { + lock : Lwt_mutex.t; + mutable gen : int; +} + +type t = { + root : string; (* The top-level directory (containing `result`, etc). *) + caches : (string, cache) Hashtbl.t; + mutable next : int; (* Used to generate unique temporary IDs. *) +} + +let ( / ) = Filename.concat + +(* The OBuilder persistent cache is implemented using a shared Docker + volume. As there's no snapshotting in volumes, we implement + poor-man's snapshots: take a lock and copy the source. If the build + of the new cache entry succeeds, it replaces the old one. + + For security reasons, each build step should only have access to + its cache, so we need one volume per cache entry. The copy happens + in the host filesystem. *) +module Cache : sig + val empty : t -> string + val cache : string -> [> `Docker_volume of string] + val cache_tmp : int -> string -> [> `Docker_volume of string] + + val name : [< `Docker_volume of string] -> string + + val exists : [< `Docker_volume of string] -> bool Lwt.t + val create : [< `Docker_volume of string] -> unit Lwt.t + val snapshot : src:[< `Docker_volume of string] -> [< `Docker_volume of string] -> unit Lwt.t + val delete : [`Docker_volume of string] -> unit Lwt.t +end = struct + let empty t = t.root / "empty" + let cache name = Docker.docker_volume_cache (Escape.cache name) + let cache_tmp i name = Docker.docker_volume_cache ~tmp:true (Printf.sprintf "%d-%s" i (Escape.cache name)) + + let name (`Docker_volume name) = name + + let exists volume = + let* r = Docker.exists volume in + let b = Result.is_ok r in + Log.debug (fun f -> f "CACHE EXISTS %s %b" (name volume) b); + Lwt.return b + + let create volume = + Log.debug (fun f -> f "CACHE CREATE %s" (name volume)); + let* _ = Docker.volume (`Create volume) in + Lwt.return_unit + + let snapshot ~src dst = + Log.debug (fun f -> f "CACHE SNAPSHOT src: %s dst: %s" (name src) (name dst)); + let* () = create dst in + let* src = Docker.mount_point src in + let* dst = Docker.mount_point dst in + if Sys.win32 then + Os.exec ["robocopy"; src; dst; "/MIR"; "/NFL"; "/NDL"; "/NJH"; "/NJS"; "/NC"; "/NS"; "/NP"] + ~is_success:(fun n -> n = 0 || n = 1) + else + Os.sudo ["cp"; "-a"; "--"; src ^ "/."; dst ] + + let delete volume = + Log.debug (fun f -> f "CACHE DELETE %s" (name volume)); + let* _ = Docker.volume (`Remove [volume]) in + Lwt.return_unit +end + +let create root = + Os.ensure_dir root; + let root = Unix.realpath root in + let prefix = Printf.sprintf "obuilder-%d-" (Hashtbl.hash root) in + Docker.set_prefix prefix; + Log.debug (fun f -> f "Docker store: create root:%s prefix:%s" root prefix); + let t = { root; caches = Hashtbl.create 10; next = 0 } in + Os.ensure_dir (Cache.empty t); + Os.ensure_dir (root / "state"); + Lwt.return t + +let build t ?base ~id (fn:(string -> (unit, 'e) Lwt_result.t)) : (unit, 'e) Lwt_result.t = + Log.debug (fun f -> f "Docker store: build base:%s id:%s" (Option.fold ~none:"None" ~some:(fun base -> base) base) id); + let result = Docker.result t.root id in + assert (not (Sys.file_exists result)); + Os.ensure_dir result; + Log.debug (fun f -> f "Docker store: build t.root:%s id:%s result:%s" t.root id result); + match base with + | None -> + Lwt.try_bind + (fun () -> fn result) + (fun r -> + begin match r with + | Ok (()) -> () + | Error _ -> () + end; Lwt.return r) + (fun exn -> Lwt.fail exn) + | Some base -> + let base = Docker.docker_image base in + let tmp_image = (Docker.docker_image ~tmp:true id) in + let cleanup () = + Docker.image "rm" tmp_image + in + let* () = Docker.tag base tmp_image in + Lwt.try_bind + (fun () -> + Log.debug (fun f -> f "Docker store: running build"); + let* r = fn result in + Log.debug (fun f -> f "Docker store: build finished"); + Lwt.return r) + (fun r -> + Log.debug (fun f -> f "Docker store: build cleanup"); + (* As the cache is cleaned before this, the sandbox must take + care of committing the container and removing it, otherwise + the container still has a reference to the volume. *) + let* () = cleanup () in + Lwt.return r) + (fun exn -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn exn); + let* () = cleanup () in + Lwt.fail exn) + +let delete t id = + Log.debug (fun f -> f "Docker store: delete %s" id); + let path = Docker.result t.root id in + let* () = match Os.check_dir path with + | `Present -> Os.delete_recursively path + | `Missing -> Lwt.return_unit + in + let image = Docker.docker_image id in + let* exists = Docker.exists image in + match exists with + | Ok () -> Docker.image "rm" image + | Error _ -> Lwt.return_unit + +let result t id = + Log.debug (fun f -> f "Docker store: result %s" id); + let dir = Docker.result t.root id in + let* r = Docker.exists (Docker.docker_image id) in + match r, Os.check_dir dir with + | Ok (_), `Present -> Lwt.return_some dir + | _ -> Lwt.return_none + +let state_dir t = + Log.debug (fun f -> f "Docker store: state_dir %s" t.root); + Filename.concat t.root "state" + +let get_cache t name = + match Hashtbl.find_opt t.caches name with + | Some c -> c + | None -> + let c = { lock = Lwt_mutex.create (); gen = 0 } in + Hashtbl.add t.caches name c; + c + +let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t = + ignore user; + let cache = get_cache t name in + Lwt_mutex.with_lock cache.lock @@ fun () -> + let tmp = Cache.cache_tmp t.next name in + t.next <- t.next + 1; + let snapshot = Cache.cache name in + (* Create cache if it doesn't already exist. *) + let* () = + let* exists = Cache.exists snapshot in + if not exists then Cache.create snapshot + else Lwt.return_unit + in + (* Create writeable clone. *) + let gen = cache.gen in + let* () = Cache.snapshot ~src:snapshot tmp in + let release () = + Lwt_mutex.with_lock cache.lock @@ fun () -> + let* () = + if cache.gen = gen then ( + (* The cache hasn't changed since we cloned it. Update it. *) + (* todo: check if it has actually changed. *) + cache.gen <- cache.gen + 1; + let* () = Cache.delete snapshot in + Cache.snapshot ~src:tmp snapshot + ) else Lwt.return_unit + in + Cache.delete tmp + in + Lwt.return (Cache.name tmp, release) + +let delete_cache t name = + let cache = get_cache t name in + Lwt_mutex.with_lock cache.lock @@ fun () -> + cache.gen <- cache.gen + 1; (* Ensures in-progress writes will be discarded *) + let snapshot = Cache.cache name in + let* exists = Cache.exists snapshot in + if exists then + let* () = Cache.delete snapshot in + Lwt_result.return () + else Lwt_result.return () + +let complete_deletes t = + ignore t; + Log.debug (fun f -> f "Docker store: complete_deletes"); + (* XXX: how to implement this? *) + Lwt.return_unit diff --git a/lib/docker_store.mli b/lib/docker_store.mli new file mode 100644 index 00000000..789f52ef --- /dev/null +++ b/lib/docker_store.mli @@ -0,0 +1,7 @@ +(** Store build results as Docker images. *) + +include S.STORE + +val create : string -> t Lwt.t +(** [create root] is a new store using Docker images and [root] to store + ancillary state. *) diff --git a/lib/dune b/lib/dune index c725fd4d..efba3555 100644 --- a/lib/dune +++ b/lib/dune @@ -1,3 +1,10 @@ +(rule + (target Static_files.ml) + (deps + (source_tree ../static)) + (action + (run %{bin:ocaml-crunch} ../static --mode=plain -o %{target}))) + (library (name obuilder) (public_name obuilder) diff --git a/lib/manifest.ml b/lib/manifest.ml index b69f389a..2413dd23 100644 --- a/lib/manifest.ml +++ b/lib/manifest.ml @@ -5,12 +5,15 @@ let ( / ) = Filename.concat type hash = Sha256.t let sexp_of_hash t = Sexplib.Sexp.Atom (Sha256.to_hex t) +let hash_of_sexp = function + | Sexplib.Sexp.Atom hash -> Sha256.of_hex hash + | x -> Fmt.failwith "Invalid data source: %a" Sexplib.Sexp.pp_hum x type t = [ | `File of (string * hash) | `Symlink of (string * string) | `Dir of (string * t list) -] [@@deriving sexp_of] +] [@@deriving sexp] let rec generate ~exclude ~src_dir src : t = let path = src_dir / src in @@ -69,3 +72,13 @@ let generate ~exclude ~src_dir src = |> Result.ok with Failure m -> Error (`Msg m) + +let to_from_files ?(null=false) t = + let sep = if null then '\000' else '\n' in + let buf = Buffer.create 64 in + let rec aux = function + | `File (name, _) | `Symlink (name, _) -> Buffer.add_string buf name; Buffer.add_char buf sep + | `Dir (name, entries) -> Buffer.add_string buf name; Buffer.add_char buf sep; List.iter aux entries + in + aux t; + Buffer.contents buf diff --git a/lib/manifest.mli b/lib/manifest.mli index 36e6af64..18d5c112 100644 --- a/lib/manifest.mli +++ b/lib/manifest.mli @@ -2,10 +2,14 @@ type t = [ | `File of (string * Sha256.t) | `Symlink of (string * string) | `Dir of (string * t list) -] [@@deriving sexp_of] +] [@@deriving sexp] val generate : exclude:string list -> src_dir:string -> string -> (t, [> `Msg of string]) result (** [generate ~exclude ~src_dir src] returns a manifest of the subtree at [src_dir/src]. Note that [src_dir] is a native platform path, but [src] is always Unix-style. Files with basenames in [exclude] are ignored. Returns an error if [src] is not under [src_dir] or does not exist. *) + +val to_from_files : ?null:bool -> t -> string +(** [to_from_files t] returns a buffer containing the list of files, + separated by ASCII LF (the default) or NUL if [null] is true. *) diff --git a/lib/obuilder.ml b/lib/obuilder.ml index 05a75448..40eccac1 100644 --- a/lib/obuilder.ml +++ b/lib/obuilder.ml @@ -11,19 +11,22 @@ module Context = Build.Context module Btrfs_store = Btrfs_store module Zfs_store = Zfs_store module Store_spec = Store_spec +module Docker_store = Docker_store (** {2 Fetchers} *) -module Docker = Docker +module Docker_extract = Docker.Extract (** {2 Sandboxes} *) module Config = Config module Runc_sandbox = Runc_sandbox +module Docker_sandbox = Docker_sandbox (** {2 Builders} *) module type BUILDER = S.BUILDER with type context := Build.Context.t module Builder = Build.Make +module Docker_builder = Build.Docker module Build_log = Build_log (**/**) diff --git a/lib/os.ml b/lib/os.ml index 9260bffb..be3c8b8e 100644 --- a/lib/os.ml +++ b/lib/os.ml @@ -93,6 +93,14 @@ let rec write_all fd buf ofs len = write_all fd buf (ofs + n) (len - n) ) +let rec write_all_string fd buf ofs len = + assert (len >= 0); + if len = 0 then Lwt.return_unit + else ( + Lwt_unix.write_string fd buf ofs len >>= fun n -> + write_all_string fd buf (ofs + n) (len - n) + ) + let write_file ~path contents = Lwt_io.(with_file ~mode:output) path @@ fun ch -> Lwt_io.write ch contents @@ -146,6 +154,35 @@ let pread ?stderr argv = child >>= fun () -> Lwt.return data +let pread_result ?stderr ~pp argv = + with_pipe_from_child @@ fun ~r ~w -> + let child = exec_result ~stdout:(`FD_move_safely w) ?stderr ~pp argv in + let r = Lwt_io.(of_fd ~mode:input) r in + Lwt.finalize + (fun () -> Lwt_io.read r) + (fun () -> Lwt_io.close r) + >>= fun data -> + child >>= fun r -> + Result.map (fun () -> data) r |> Lwt_result.lift + +let pread_all ?stdin ~pp ?(cmd="") argv = + with_pipe_from_child @@ fun ~r:r1 ~w:w1 -> + with_pipe_from_child @@ fun ~r:r2 ~w:w2 -> + let child = + Logs.info (fun f -> f "Exec %a" pp_cmd argv); + !lwt_process_exec ?stdin ~stdout:(`FD_move_safely w1) ~stderr:(`FD_move_safely w2) ~pp + (cmd, Array.of_list argv) + in + let r1 = Lwt_io.(of_fd ~mode:input) r1 in + let r2 = Lwt_io.(of_fd ~mode:input) r2 in + Lwt.finalize + (fun () -> Lwt.both (Lwt_io.read r1) (Lwt_io.read r2)) + (fun () -> Lwt.both (Lwt_io.close r1) (Lwt_io.close r2) >>= fun _ -> Lwt.return_unit) + >>= fun (stdin, stdout) -> + child >>= function + | Ok i -> Lwt.return (i, stdin, stdout) + | Error (`Msg m) -> Lwt.fail (Failure m) + let check_dir x = match Unix.lstat x with | Unix.{ st_kind = S_DIR; _ } -> `Present @@ -156,3 +193,51 @@ let ensure_dir path = match check_dir path with | `Present -> () | `Missing -> Unix.mkdir path 0o777 + +(** delete_recursively code taken from Lwt. *) + +let win32_unlink fn = + Lwt.catch + (fun () -> Lwt_unix.unlink fn) + (function + | Unix.Unix_error (Unix.EACCES, _, _) as exn -> + Lwt_unix.lstat fn >>= fun {st_perm; _} -> + (* Try removing the read-only attribute *) + Lwt_unix.chmod fn 0o666 >>= fun () -> + Lwt.catch + (fun () -> Lwt_unix.unlink fn) + (function _ -> + (* Restore original permissions *) + Lwt_unix.chmod fn st_perm >>= fun () -> + Lwt.fail exn) + | exn -> Lwt.fail exn) + +let unlink = + if Sys.win32 then + win32_unlink + else + Lwt_unix.unlink + +(* This is likely VERY slow for directories with many files. That is probably + best addressed by switching to blocking calls run inside a worker thread, + i.e. with Lwt_preemptive. *) +let rec delete_recursively directory = + Lwt_unix.files_of_directory directory + |> Lwt_stream.iter_s begin fun entry -> + if entry = Filename.current_dir_name || + entry = Filename.parent_dir_name then + Lwt.return () + else + let path = Filename.concat directory entry in + Lwt_unix.lstat path >>= fun {Lwt_unix.st_kind; _} -> + match st_kind with + | S_DIR -> delete_recursively path + | S_LNK when (Sys.win32 || Sys.cygwin) -> + Lwt_unix.stat path >>= fun {Lwt_unix.st_kind; _} -> + begin match st_kind with + | S_DIR -> Lwt_unix.rmdir path + | _ -> unlink path + end + | _ -> unlink path + end >>= fun () -> + Lwt_unix.rmdir directory diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index 6f61238e..09bad1bf 100644 --- a/lib/runc_sandbox.ml +++ b/lib/runc_sandbox.ml @@ -106,7 +106,7 @@ module Json_config = struct let make {Config.cwd; argv; hostname; user; env; mounts; network; mount_secrets; entrypoint} t ~config_dir ~results_dir : Yojson.Safe.t = assert (entrypoint = None); let user = - let { Obuilder_spec.uid; gid } = user in + let { Obuilder_spec.uid; gid } = match user with `Unix user -> user | _ -> assert false in `Assoc [ "uid", `Int uid; "gid", `Int gid; diff --git a/lib/store_spec.ml b/lib/store_spec.ml index 7acfe0a3..7ccd1e0c 100644 --- a/lib/store_spec.ml +++ b/lib/store_spec.ml @@ -11,7 +11,7 @@ let of_string s = match Astring.String.cut s ~sep:":" with | Some ("zfs", pool) -> Ok (`Zfs pool) | Some ("btrfs", path) -> Ok (`Btrfs path) - | _ -> Error (`Msg "Store must start with zfs: or btrfs:") + | _ -> Error (`Msg "Store must start with zfs: or btrfs: or docker:") let pp f = function | `Zfs pool -> Fmt.pf f "zfs:%s" pool diff --git a/lib/tar_transfer.ml b/lib/tar_transfer.ml index 2d4fcd56..3ac6d0b1 100644 --- a/lib/tar_transfer.ml +++ b/lib/tar_transfer.ml @@ -2,6 +2,8 @@ open Lwt.Infix let ( / ) = Filename.concat +let level = Tar.Header.Ustar + module Tar_lwt_unix = struct include Tar_lwt_unix @@ -32,8 +34,8 @@ module Tar_lwt_unix = struct module HW = Tar.HeaderWriter(Lwt)(Writer) - let write_block (header: Tar.Header.t) (body: Lwt_unix.file_descr -> unit Lwt.t) (fd : Lwt_unix.file_descr) = - HW.write ~level:Tar.Header.Ustar header fd + let write_block ?level (header: Tar.Header.t) (body: Lwt_unix.file_descr -> unit Lwt.t) (fd : Lwt_unix.file_descr) = + HW.write ?level header fd >>= fun () -> body fd >>= fun () -> Writer.really_write fd (Tar.Header.zero_padding header) @@ -55,75 +57,67 @@ let copy_to ~dst src = let copy_file ~src ~dst ~to_untar ~user = Lwt_unix.LargeFile.lstat src >>= fun stat -> + let user_id, group_id = match user with `Unix user -> Obuilder_spec.(Some user.uid, Some user.gid) | _ -> None, None in let hdr = Tar.Header.make ~file_mode:(if stat.Lwt_unix.LargeFile.st_perm land 0o111 <> 0 then 0o755 else 0o644) ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) - ~user_id:user.Obuilder_spec.uid - ~group_id:user.Obuilder_spec.gid + ?user_id + ?group_id dst stat.Lwt_unix.LargeFile.st_size in - Tar_lwt_unix.write_block hdr (fun ofd -> + Tar_lwt_unix.write_block ~level hdr (fun ofd -> Lwt_io.(with_file ~mode:input) src (copy_to ~dst:ofd) ) to_untar let copy_symlink ~src ~target ~dst ~to_untar ~user = Lwt_unix.LargeFile.lstat src >>= fun stat -> + let user_id, group_id = match user with `Unix user -> Obuilder_spec.(Some user.uid, Some user.gid) | _ -> None, None in let hdr = Tar.Header.make ~file_mode:0o777 ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) ~link_indicator:Tar.Header.Link.Symbolic ~link_name:target - ~user_id:user.Obuilder_spec.uid - ~group_id:user.Obuilder_spec.gid + ?user_id + ?group_id dst 0L in - Tar_lwt_unix.write_block hdr (fun _ -> Lwt.return_unit) to_untar + Tar_lwt_unix.write_block ~level hdr (fun _ -> Lwt.return_unit) to_untar let rec copy_dir ~src_dir ~src ~dst ~(items:(Manifest.t list)) ~to_untar ~user = Log.debug(fun f -> f "Copy dir %S -> %S@." src dst); Lwt_unix.LargeFile.lstat (src_dir / src) >>= fun stat -> begin + let user_id, group_id = match user with `Unix user -> Obuilder_spec.(Some user.uid, Some user.gid) | _ -> None, None in let hdr = Tar.Header.make ~file_mode:0o755 ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) - ~user_id:user.Obuilder_spec.uid - ~group_id:user.Obuilder_spec.gid + ?user_id + ?group_id (dst ^ "/") 0L in Tar_lwt_unix.write_block hdr (fun _ -> Lwt.return_unit) to_untar - end >>= fun () -> - items |> Lwt_list.iter_s (function - | `File (src, _) -> - let src = src_dir / src in - let dst = dst / Filename.basename src in - copy_file ~src ~dst ~to_untar ~user - | `Symlink (src, target) -> - let src = src_dir / src in - let dst = dst / Filename.basename src in - copy_symlink ~src ~target ~dst ~to_untar ~user - | `Dir (src, items) -> - let dst = dst / Filename.basename src in - copy_dir ~src_dir ~src ~dst ~items ~to_untar ~user + end >>= fun () -> send_dir ~src_dir ~dst ~to_untar ~user items + +and send_dir ~src_dir ~dst ~to_untar ~user items = + items |> Lwt_list.iter_s (function + | `File (src, _) -> + let src = src_dir / src in + let dst = dst / Filename.basename src in + copy_file ~src ~dst ~to_untar ~user + | `Symlink (src, target) -> + let src = src_dir / src in + let dst = dst / Filename.basename src in + copy_symlink ~src ~target ~dst ~to_untar ~user + | `Dir (src, items) -> + let dst = dst / Filename.basename src in + copy_dir ~src_dir ~src ~dst ~items ~to_untar ~user ) let remove_leading_slashes = Astring.String.drop ~sat:((=) '/') let send_files ~src_dir ~src_manifest ~dst_dir ~user ~to_untar = - let dst_dir = remove_leading_slashes dst_dir in - src_manifest |> Lwt_list.iter_s (function - | `File (path, _) -> - let src = src_dir / path in - let dst = dst_dir / (Filename.basename path) in - copy_file ~src ~dst ~to_untar ~user - | `Symlink (src, target) -> - let src = src_dir / src in - let dst = dst_dir / Filename.basename src in - copy_symlink ~src ~target ~dst ~to_untar ~user - | `Dir (src, items) -> - let dst = dst_dir / Filename.basename src in - copy_dir ~src_dir ~src ~dst ~items ~to_untar ~user - ) - >>= fun () -> + let dst = remove_leading_slashes dst_dir in + send_dir ~src_dir ~dst ~to_untar ~user src_manifest >>= fun () -> Tar_lwt_unix.write_end to_untar let send_file ~src_dir ~src_manifest ~dst ~user ~to_untar = @@ -140,3 +134,77 @@ let send_file ~src_dir ~src_manifest ~dst ~user ~to_untar = copy_dir ~src_dir ~src ~dst ~items ~to_untar ~user end >>= fun () -> Tar_lwt_unix.write_end to_untar + +let transform ~user fname hdr = + let hdr = match user with + | `Unix user -> { hdr with Tar.Header.user_id = user.Obuilder_spec.uid; group_id = user.gid } + | _ -> hdr + in + match hdr.Tar.Header.link_indicator with + | Normal -> + { hdr with + file_mode = if hdr.file_mode land 0o111 <> 0 then 0o755 else 0o644; + file_name = fname hdr.file_name; } + | Symbolic -> + { hdr with + file_mode = 0o777; + file_name = fname hdr.file_name; } + | Directory -> + { hdr with + file_mode = 0o755; + file_name = fname hdr.file_name; } + | _ -> invalid_arg "Unsupported file type" + +let rec transform_files ~from_tar ~src_manifest ~dst_dir ~user ~to_untar = + Log.debug (fun f -> f "transform_files@."); + let dst = remove_leading_slashes dst_dir in + let transformations = Hashtbl.create ~random:true 64 in + List.iter (transform_dir ~dst transformations) src_manifest; + let fname = fun file_name -> + let name = match Hashtbl.find_opt transformations file_name with + | None -> failwith (Printf.sprintf "Could not find mapping for %s" file_name) + | Some file_name -> file_name in + Log.debug (fun f -> f "Renaming %s to %s@." file_name name); + name in + Tar_lwt_unix.Archive.transform ~level (transform ~user fname) from_tar to_untar + +and transform_dir ~dst transformations = function + | `File (src, _) -> + let dst = dst / Filename.basename src in + Log.debug (fun f -> f "map %s -> %s@." src dst); + Hashtbl.add transformations src dst + | `Symlink (src, _) -> + let dst = dst / Filename.basename src in + Log.debug (fun f -> f "map %s -> %s@." src dst); + Hashtbl.add transformations src dst + | `Dir (src, items) -> + let dst = dst / Filename.basename src ^ "/" in + Log.debug (fun f -> f "map %s -> %s@." src dst); + Hashtbl.add transformations src dst; + List.iter (transform_dir ~dst transformations) items + +let transform_file ~from_tar ~src_manifest ~dst ~user ~to_untar = + Log.debug (fun f -> f "transform_file@."); + let dst = remove_leading_slashes dst in + let transformations = Hashtbl.create ~random:true 64 in + let aux dst = function + | `File (src, _) -> + Log.debug (fun f -> f "map %s -> %s@." src dst); + Hashtbl.add transformations src dst + | `Symlink (src, _) -> + Log.debug (fun f -> f "map %s -> %s@." src dst); + Hashtbl.add transformations src dst + | `Dir (src, items) -> + let dst = dst / Filename.basename src ^ "/" in + Log.debug (fun f -> f "map %s -> %s@." src dst); + Hashtbl.add transformations src dst; + List.iter (transform_dir ~dst transformations) items + in + aux dst src_manifest; + let fname = fun file_name -> + let name = match Hashtbl.find_opt transformations file_name with + | None -> failwith (Printf.sprintf "Could not find mapping for %s" file_name) + | Some file_name -> file_name in + Log.debug (fun f -> f "Renaming %s to %s" file_name name); + name in + Tar_lwt_unix.Archive.transform ~level (transform ~user fname) from_tar to_untar diff --git a/lib/tar_transfer.mli b/lib/tar_transfer.mli index e71fe084..55e4fe15 100644 --- a/lib/tar_transfer.mli +++ b/lib/tar_transfer.mli @@ -21,3 +21,29 @@ val send_file : to [to_untar] containing the item [src_manifest], which is loaded from [src_dir]. The item will be copied as [dst]. All files are listed as being owned by [user]. *) + +val transform_files : + from_tar:Lwt_unix.file_descr -> + src_manifest:Manifest.t list -> + dst_dir:string -> + user:Obuilder_spec.user -> + to_untar:Lwt_unix.file_descr -> + unit Lwt.t +(** [transform_files ~src_dir ~from_tar ~src_manifest ~dst_dir ~user + ~to_untar] prefixes the files names of all the files found in + [from_tar], a tar archive streamed in input, with [dst_dir], and + writes the resulting tar-format stream to [to_untar]. All files are + listed as being owned by [user]. *) + +val transform_file : + from_tar:Lwt_unix.file_descr -> + src_manifest:Manifest.t -> + dst:string -> + user:Obuilder_spec.user -> + to_untar:Lwt_unix.file_descr -> + unit Lwt.t +(** [transform_files ~src_dir ~from_tar ~src_manifest ~dst ~user + ~to_untar] renames the _unique_ file found in [from_tar], a tar + archive streamed in input, to [dst], and writes the resulting + tar-format stream to [to_untar]. All files are listed as being + owned by [user]. *) diff --git a/lib/zfs_store.ml b/lib/zfs_store.ml index 641e07ba..ac5b4664 100644 --- a/lib/zfs_store.ml +++ b/lib/zfs_store.ml @@ -88,11 +88,11 @@ end = struct else fn () end -let user = { Obuilder_spec.uid = Unix.getuid (); gid = Unix.getgid () } +let user = `Unix { Obuilder_spec.uid = Unix.getuid (); gid = Unix.getgid () } module Zfs = struct let chown ~user t ds = - let { Obuilder_spec.uid; gid } = user in + let { Obuilder_spec.uid; gid } = match user with `Unix user -> user | _ -> assert false in Os.sudo ["chown"; strf "%d:%d" uid gid; Dataset.path t ds] let create t ds = diff --git a/lib_spec/docker.ml b/lib_spec/docker.ml index c6e9e8b4..cf6ec1d9 100644 --- a/lib_spec/docker.ml +++ b/lib_spec/docker.ml @@ -15,21 +15,27 @@ let pp_wrap = Fmt.(list ~sep:(unit " \\@\n ") (using String.trim string)) let pp_cache ~ctx f { Cache.id; target; buildkit_options } = + let buildkit_options = match ctx.user with + | `Unix {uid; gid = _} -> ("uid", string_of_int uid) :: buildkit_options + | `Windows _ -> assert false + in let buildkit_options = ("--mount=type", "cache") :: ("id", id) :: ("target", target) :: - ("uid", string_of_int ctx.user.uid) :: buildkit_options in Fmt.pf f "%a" Fmt.(list ~sep:(unit ",") pp_pair) buildkit_options let pp_mount_secret ~ctx f { Secret.id; target; buildkit_options } = + let buildkit_options = match ctx.user with + | `Unix {uid; gid = _} -> ("uid", string_of_int uid) :: buildkit_options + | `Windows _ -> assert false + in let buildkit_options = ("--mount=type", "secret") :: ("id", id) :: ("target", target) :: - ("uid", string_of_int ctx.user.uid) :: buildkit_options in Fmt.pf f "%a" Fmt.(list ~sep:(unit ",") pp_pair) buildkit_options @@ -48,8 +54,9 @@ let pp_copy ~ctx f { Spec.from; src; dst; exclude = _ } = let chown = if ctx.user = Spec.root then None else ( - let { Spec.uid; gid } = ctx.user in - Some (Printf.sprintf "%d:%d" uid gid) + match ctx.user with + | `Unix { uid; gid } -> Some (Printf.sprintf "%d:%d" uid gid) + | `Windows _ -> None ) in Fmt.pf f "COPY %a%a%a %s" @@ -79,7 +86,8 @@ let pp_op ~buildkit ctx f : Spec.op -> ctx = function | `Run x when buildkit -> pp_run ~ctx f x; ctx | `Run x -> pp_run ~ctx f { x with cache = []; secrets = []}; ctx | `Copy x -> pp_copy ~ctx f x; ctx - | `User ({ uid; gid } as u) -> Fmt.pf f "USER %d:%d" uid gid; { user = u } + | `User (`Unix { uid; gid } as u) -> Fmt.pf f "USER %d:%d" uid gid; { user = u } + | `User (`Windows { name } as u) -> Fmt.pf f "USER %s" name; { user = u } | `Env (k, v) -> Fmt.pf f "ENV %s=\"%s\"" k (quote ~escape:'\\' v); ctx let rec convert ~buildkit f (name, { Spec.child_builds; from; ops }) = diff --git a/lib_spec/spec.ml b/lib_spec/spec.ml index ec004944..698cdc25 100644 --- a/lib_spec/spec.ml +++ b/lib_spec/spec.ml @@ -56,8 +56,34 @@ let copy_inlined = function let copy_of_sexp x = copy_of_sexp (inflate_record copy_inlined x) let sexp_of_copy x = deflate_record copy_inlined (sexp_of_copy x) -type user = { uid : int; gid : int } -[@@deriving sexp] +type unix_user = { + uid : int; + gid : int; +} [@@deriving sexp] + +type windows_user = { + name : string; +} [@@deriving sexp] + +type user = [ + | `Unix of unix_user + | `Windows of windows_user +] [@@deriving sexp] + +let user_of_sexp x = + let open Sexplib.Sexp in + match x with + | List [List [Atom "name"; _]] -> + `Windows (windows_user_of_sexp x) + | List [List [Atom "uid"; _]; List [Atom "gid"; _]] -> + `Unix (unix_user_of_sexp x) + | x -> Fmt.failwith "Invalid op: %a" Sexplib.Sexp.pp_hum x + +let sexp_of_user x : Sexplib.Sexp.t = + let x = sexp_of_user x in + match x with + | List [Atom _os; List args] -> List args + | x -> Fmt.failwith "Invalid op: %a" Sexplib.Sexp.pp_hum x type run = { cache : Cache.t list [@sexp.list]; @@ -149,9 +175,12 @@ let shell xs = `Shell xs let run ?(cache=[]) ?(network=[]) ?(secrets=[]) fmt = fmt |> Printf.ksprintf (fun x -> `Run { shell = x; cache; network; secrets }) let copy ?(from=`Context) ?(exclude=[]) src ~dst = `Copy { from; src; dst; exclude } let env k v = `Env (k, v) -let user ~uid ~gid = `User { uid; gid } +let user_unix ~uid ~gid = `User (`Unix { uid; gid }) +let user_windows ~name = `User (`Windows { name }) -let root = { uid = 0; gid = 0 } +let root = + if Sys.win32 then `Windows { name = "ContainerAdministrator" } + else `Unix { uid = 0; gid = 0 } let rec pp_no_boxes f : Sexplib.Sexp.t -> unit = function | List xs -> Fmt.pf f "(%a)" (Fmt.list ~sep:Fmt.sp pp_no_boxes) xs diff --git a/lib_spec/spec.mli b/lib_spec/spec.mli index 338911f2..454fae2f 100644 --- a/lib_spec/spec.mli +++ b/lib_spec/spec.mli @@ -5,11 +5,20 @@ type copy = { exclude : string list; } [@@deriving sexp] -type user = { +type unix_user = { uid : int; - gid : int + gid : int; } [@@deriving sexp] +type windows_user = { + name : string; +} [@@deriving sexp] + +type user = [ + | `Unix of unix_user + | `Windows of windows_user +] [@@deriving sexp] + type run = { cache : Cache.t list; network : string list; @@ -41,7 +50,8 @@ val shell : string list -> op val run : ?cache:Cache.t list -> ?network:string list -> ?secrets:Secret.t list -> ('a, unit, string, op) format4 -> 'a val copy : ?from:[`Context | `Build of string] -> ?exclude:string list -> string list -> dst:string -> op val env : string -> string -> op -val user : uid:int -> gid:int -> op +val user_unix : uid:int -> gid:int -> op +val user_windows : name:string -> op val root : user diff --git a/main.ml b/main.ml index c49fbfe8..16383138 100644 --- a/main.ml +++ b/main.ml @@ -2,8 +2,7 @@ open Lwt.Infix let ( / ) = Filename.concat -module Sandbox = Obuilder.Runc_sandbox -module Fetcher = Obuilder.Docker +module Runc_sandbox = Obuilder.Runc_sandbox type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder @@ -14,21 +13,39 @@ let log tag msg = | `Output -> output_string stdout msg; flush stdout let create_builder spec conf = - Obuilder.Store_spec.to_store spec >>= fun (Store ((module Store), store)) -> - let module Builder = Obuilder.Builder(Store)(Sandbox)(Fetcher) in - Sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> + let open Obuilder in + Store_spec.to_store spec >>= fun (Store ((module Store), store)) -> + let module Builder = Builder (Store) (Runc_sandbox) (Docker_extract) in + Runc_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> let builder = Builder.v ~store ~sandbox in Builder ((module Builder), builder) +let create_docker_builder path conf = + let open Obuilder in + let module Builder = Docker_builder in + Docker_store.create path >>= fun store -> + Docker_sandbox.create ~state_dir:(Docker_store.state_dir store / "sandbox") conf >|= fun sandbox -> + let builder = Docker_builder.v ~store ~sandbox in + Builder ((module Docker_builder), builder) + let read_whole_file path = let ic = open_in_bin path in Fun.protect ~finally:(fun () -> close_in ic) @@ fun () -> let len = in_channel_length ic in really_input_string ic len -let build () store spec conf src_dir secrets = +let build () store docker_backend spec runc_conf docker_conf src_dir secrets = Lwt_main.run begin - create_builder store conf >>= fun (Builder ((module Builder), builder)) -> + begin match store, docker_backend with + | None, None -> + Fmt.epr "Must select either a store or the Docker backend@."; + exit 1 + | Some _, Some _ -> + Fmt.epr "Cannot select a store and the Docker backend@."; + exit 1 + | Some store, None -> create_builder store runc_conf + | None, Some path -> create_docker_builder path docker_conf + end >>= fun (Builder ((module Builder), builder)) -> let spec = try Obuilder.Spec.t_of_sexp (Sexplib.Sexp.load_sexp spec) with Failure msg -> @@ -103,7 +120,7 @@ let src_dir = let store_t = Arg.conv Obuilder.Store_spec.(of_string, pp) -let store = +let store_required = Arg.required @@ Arg.opt Arg.(some store_t) None @@ Arg.info @@ -111,6 +128,22 @@ let store = ~docv:"STORE" ["store"] +let store = + Arg.value @@ + Arg.opt Arg.(some store_t) None @@ + Arg.info + ~doc:"zfs:pool or btrfs:/path for build cache" + ~docv:"STORE" + ["store"] + +let docker_backend = + Arg.value @@ + Arg.opt Arg.(some string) None @@ + Arg.info + ~doc:"Use the Docker store and sandbox backend. Use $(docv) for temporary files." + ~docv:"path" + ["docker-backend"] + let id = Arg.required @@ Arg.pos 0 Arg.(some string) None @@ @@ -129,12 +162,13 @@ let secrets = let build = let doc = "Build a spec file." in - Term.(const build $ setup_log $ store $ spec_file $ Sandbox.cmdliner $ src_dir $ secrets), + Term.(const build $ setup_log $ store $ docker_backend $ spec_file + $ Obuilder.Runc_sandbox.cmdliner $ Obuilder.Docker_sandbox.cmdliner $ src_dir $ secrets), Term.info "build" ~doc let delete = let doc = "Recursively delete a cached build result." in - Term.(const delete $ setup_log $ store $ Sandbox.cmdliner $ id), + Term.(const delete $ setup_log $ store_required $ Runc_sandbox.cmdliner $ id), Term.info "delete" ~doc let buildkit = @@ -151,7 +185,7 @@ let dockerfile = let healthcheck = let doc = "Perform a self-test" in - Term.(const healthcheck $ setup_log $ store $ Sandbox.cmdliner), + Term.(const healthcheck $ setup_log $ store_required $ Runc_sandbox.cmdliner), Term.info "healthcheck" ~doc let cmds = [build; delete; dockerfile; healthcheck] diff --git a/obuilder.opam b/obuilder.opam index 3a27e179..e9ea6a27 100644 --- a/obuilder.opam +++ b/obuilder.opam @@ -15,15 +15,17 @@ depends: [ "fmt" {>= "0.8.9"} "logs" "cmdliner" - "tar-unix" + "tar" {>= "1.2"} + "tar-unix" {>= "1.2"} "yojson" "sexplib" "ppx_deriving" "ppx_sexp_conv" "sha" "sqlite3" + "crunch" {build} "obuilder-spec" {= version} - "ocaml" {>= "4.10.0"} + "ocaml" {>= "4.13.0"} "alcotest-lwt" {with-test} "odoc" {with-doc} ] @@ -42,3 +44,9 @@ build: [ ] ] dev-repo: "git+https://github.com/ocurrent/obuilder.git" +pin-depends: [ + ["lwt.5.4.3" "git+https://github.com/MisterDA/lwt.git#e703de884a798b0c8c45c6f792691cdaf578d35b"] + ["sha.1.15" "git+https://github.com/djs55/ocaml-sha.git#8b77ab306fc3a5e94219580d6a2c92bc11745d60"] + ["tar.2.0.0" "git+https://github.com/MisterDA/ocaml-tar.git#47d20548d39337009b6d73309eb2aab346494e76"] + ["tar-unix.2.0.0" "git+https://github.com/MisterDA/ocaml-tar.git#47d20548d39337009b6d73309eb2aab346494e76"] +] diff --git a/obuilder.opam.template b/obuilder.opam.template new file mode 100644 index 00000000..0a1d7787 --- /dev/null +++ b/obuilder.opam.template @@ -0,0 +1,6 @@ +pin-depends: [ + ["lwt.5.4.3" "git+https://github.com/MisterDA/lwt.git#e703de884a798b0c8c45c6f792691cdaf578d35b"] + ["sha.1.15" "git+https://github.com/djs55/ocaml-sha.git#8b77ab306fc3a5e94219580d6a2c92bc11745d60"] + ["tar.2.0.0" "git+https://github.com/MisterDA/ocaml-tar.git#47d20548d39337009b6d73309eb2aab346494e76"] + ["tar-unix.2.0.0" "git+https://github.com/MisterDA/ocaml-tar.git#47d20548d39337009b6d73309eb2aab346494e76"] +] diff --git a/static/Dockerfile b/static/Dockerfile new file mode 100644 index 00000000..73d34c5e --- /dev/null +++ b/static/Dockerfile @@ -0,0 +1,15 @@ +# escape=` +FROM mcr.microsoft.com/windows/servercore:20H2 +ARG CYGWIN_ROOT +USER ContainerAdministrator +ENV CYGWIN="winsymlinks:native" +ADD [ "https://www.cygwin.com/setup-x86_64.exe", "C:/cygwin-setup-x86_64.exe" ] +RUN mkdir %CYGWIN_ROOT%\lib\cygsympathy && mkdir %CYGWIN_ROOT%\etc\postinstall +ADD [ "https://raw.githubusercontent.com/metastack/cygsympathy/master/cygsympathy.cmd", "$CYGWIN_ROOT/lib/cygsympathy/" ] +ADD [ "https://raw.githubusercontent.com/metastack/cygsympathy/master/cygsympathy.sh", "$CYGWIN_ROOT/lib/cygsympathy/cygsympathy" ] +RUN mklink %CYGWIN_ROOT%\etc\postinstall\zp_zcygsympathy.sh %CYGWIN_ROOT%\lib\cygsympathy\cygsympathy +RUN C:\cygwin-setup-x86_64.exe --quiet-mode --no-shortcuts --no-startmenu ` + --no-desktop --only-site --local-package-dir %TEMP% --root %CYGWIN_ROOT% ` + --site http://mirrors.kernel.org/sourceware/cygwin/ ` + --packages tar +COPY [ "extract.cmd", "C:/extract.cmd" ] diff --git a/static/extract.cmd b/static/extract.cmd new file mode 100644 index 00000000..6ba81e03 --- /dev/null +++ b/static/extract.cmd @@ -0,0 +1,13 @@ +@echo off + +copy %CYGWIN_ROOT%\bin\basename.exe %DESTINATION% +copy %CYGWIN_ROOT%\bin\bash.exe %DESTINATION% +copy %CYGWIN_ROOT%\bin\cygpath.exe %DESTINATION% +copy %CYGWIN_ROOT%\bin\readlink.exe %DESTINATION% +copy %CYGWIN_ROOT%\bin\tar.exe %DESTINATION% +copy %CYGWIN_ROOT%\bin\sha256sum.exe %DESTINATION% + +for /f "usebackq delims=" %%f in (`%CYGWIN_ROOT%\bin\bash -lc "ldd -- /bin/basename.exe /bin/bash.exe /bin/cygpath.exe /bin/readlink.exe /bin/tar.exe /bin/sha256sum.exe | sed -ne 's|.* => \(/usr/bin/.*\) ([^)]*)$|\1|p' | sort -u | xargs cygpath -w"`) do ( + echo Copying %%f + copy %%f %DESTINATION% +) diff --git a/static/manifest.bash b/static/manifest.bash new file mode 100755 index 00000000..0db61285 --- /dev/null +++ b/static/manifest.bash @@ -0,0 +1,159 @@ +# An implementation of the Manifest module in bash, to run inside +# Docker containers. Outputs a list of S-expressions representing a +# sequence of {Manifest.t}. + +# Depends on bash, basename, readlink, sha256sum. +# If running on Windows, also depends on cygpath. + +shopt -s dotglob nullglob + +# https://stackoverflow.com/a/8574392 +function mem() { + local e match="$1" + shift + for e; do [[ "$e" == "$match" ]] && return 0; done + return 1 +} + +# Filename.concat +function concat() { + local path=$1 + local dir_sep=$2 + local name=$3 + + if [[ -z "$path" ]]; then + printf "%s" "$name" + else + printf '%s%s%s' "$path" "$dir_sep" "$name" + fi +} + +# Cygwin's readlink outputs a Unix path, we prefer mixed paths. +function readlink_wrapper() { + local path + + if [[ "$OS" = "Windows_NT" ]]; then + if ! path="$(readlink -- "$1" | cygpath -m -f-)"; then + return 1 + fi + else + if ! path="$(readlink -- "$1")"; then + return 1 + fi + fi + printf "%s" "$path" +} + +function generate() { + local src=$1 + local path hash target + + path=$(concat "$src_dir" "$dir_sep" "$src") + if [[ -L "$path" ]]; then + if ! target=$(readlink_wrapper "$path"); then return 1; fi + printf '(Symlink ("%s" %s))' "$src" "$target" + elif [[ -d "$path" ]]; then + printf '(Dir ("%s" (' "$src" + for item in "$path"/*; do # Let's hope Bash file iteration is stable. + if ! item=$(basename -- "$item"); then return 1; fi + if ! mem "$item" "${exclude[@]}"; then + if ! generate "$(concat "$src" "$dir_sep" "$item")"; then + return 1 + fi + fi + done + printf ')))' + elif [[ -f "$path" ]]; then + if ! hash=$(sha256sum -- "$path"); then return 1; fi + printf '(File ("%s" %s))' "$src" "${hash:0:64}" + elif [[ ! -e "$path" ]]; then + printf 'File "%s" not found in source directory' "$src" 1>&2 + return 1 + else + printf 'Unsupported file type for "%s"' "$src" 1>&2 + return 1 + fi +} + +function check_path() { + local acc=$1; shift + local base=$1; shift + local segs=( "$@" ) + local x path + local -a xs + + x=${segs[0]} + xs=("${segs[@]:1}") + + if [[ ${#segs[@]} -eq 0 ]]; then + printf '%s' "$acc" + return 0 + elif [[ "$x" = "" || "$x" = "." ]]; then + check_path "$acc" "$base" "${xs[@]}" + elif [[ "$x" == ".." ]]; then + printf "Can't use .. in source paths!" 1>&2 + return 1 + elif [[ "$x" == *"$dir_sep"* ]]; then + printf "Can't use platform directory separator in path component: %s" "$x" 1>&2 + return 1 + else + path=$(concat "$base" "$dir_sep" "$x") + if [[ -z "$acc" ]]; then + acc="$x" + else + acc=$(concat "$acc" "$dir_sep" "$x") + fi + + if [[ ! -e "$path" ]]; then + return 2 + elif [[ -d "$path" && ! -L "$path" ]]; then + check_path "$acc" "$path" "${xs[@]}" + elif [[ (-f "$path" || -L "$path") && ${#xs[@]} -eq 0 ]]; then + printf '%s' "$acc" + return 0 + elif [[ -f "$path" ]]; then + printf 'Not a directory: %s' "$acc" 1>&2 + return 1 + else + printf 'Not a regular file: %s' "$x" 1>&2 + return 1 + fi + fi +} + +function main() { + local src src2 src3 + local -i exclude_length src_length + local -a srcs + + exclude_length=$1; shift + while (( exclude_length-- > 0 )); do + exclude+=( "$1" ); shift + done + src_length=$1; shift + while (( src_length-- > 0 )); do + srcs+=( "$1" ); shift + done + + for src1 in "${srcs[@]}"; do + IFS='/' read -r -a segs <<< "$src1" + src2=$(check_path "" "$src_dir" "${segs[@]}") + ret=$? + if [[ $ret -eq 1 ]]; then + printf ' (in "%s")' "$src1" 1>&2 + return 1 + elif [[ $ret -eq 2 ]]; then + src3="$(printf "$dir_sep%s" "${segs[@]}")" + printf 'Source path "%s" not found' "${src3:1}" 1>&2 + return 1 + elif ! generate "$src2"; then + return 1 + fi + done +} + +src_dir=$1; shift +dir_sep=$1; shift +declare -a exclude + +main "$@" diff --git a/stress/stress.ml b/stress/stress.ml index 9c917a84..d2bae53d 100644 --- a/stress/stress.ml +++ b/stress/stress.ml @@ -16,9 +16,6 @@ let assert_str expected got = exit 1 ) -module Sandbox = Runc_sandbox -module Fetcher = Docker - module Test(Store : S.STORE) = struct let assert_output expected t id = Store.result t id >>= function @@ -59,7 +56,7 @@ module Test(Store : S.STORE) = struct let test_cache t = let uid = Unix.getuid () in let gid = Unix.getgid () in - let user = { Spec.uid = 123; gid = 456 } in + let user = `Unix { Spec.uid = 123; gid = 456 } in let id = "c1" in (* Create a new cache *) Store.delete_cache t id >>= fun x -> @@ -67,7 +64,7 @@ module Test(Store : S.STORE) = struct Store.cache ~user t id >>= fun (c, r) -> assert ((Unix.lstat c).Unix.st_uid = 123); assert ((Unix.lstat c).Unix.st_gid = 456); - let user = { Spec.uid; gid } in + let user = `Unix { Spec.uid; gid } in Os.exec ["sudo"; "chown"; Printf.sprintf "%d:%d" uid gid; "--"; c] >>= fun () -> assert (Sys.readdir c = [| |]); write ~path:(c / "data") "v1" >>= fun () -> @@ -106,7 +103,13 @@ module Test(Store : S.STORE) = struct assert (x = Ok ()); Lwt.return_unit - module Build = Builder(Store)(Sandbox)(Fetcher) + type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder + + let create_builder store conf = + let module Builder = Obuilder.Builder(Store)(Runc_sandbox)(Obuilder.Docker_extract) in + Runc_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> + let builder = Builder.v ~store ~sandbox in + Builder ((module Builder), builder) let n_steps = 4 let n_values = 3 @@ -138,7 +141,7 @@ module Test(Store : S.STORE) = struct in check_log, Spec.stage ~from:"busybox" ops - let do_build builder = + let do_build (Builder ((module Builder), builder)) = let src_dir = "/root" in let buf = Buffer.create 100 in let log t x = @@ -150,7 +153,7 @@ module Test(Store : S.STORE) = struct in let ctx = Context.v ~shell:["/bin/sh"; "-c"] ~log ~src_dir () in let check_log, spec = random_build () in - Build.build builder ctx spec >>= function + Builder.build builder ctx spec >>= function | Ok _ -> check_log (Buffer.contents buf); Lwt.return_unit @@ -158,8 +161,8 @@ module Test(Store : S.STORE) = struct | Error `Cancelled -> assert false let stress_builds store conf = - Sandbox.create ~state_dir:(Store.state_dir store / "runc") conf >>= fun sandbox -> - let builder = Build.v ~store ~sandbox in + create_builder store conf >>= fun builder -> + let (Builder ((module Builder), _)) = builder in let pending = ref n_jobs in let running = ref 0 in let cond = Lwt_condition.create () in @@ -197,13 +200,12 @@ module Test(Store : S.STORE) = struct else Lwt.return_unit let prune store conf = - Sandbox.create ~state_dir:(Store.state_dir store / "runc") conf >>= fun sandbox -> - let builder = Build.v ~store ~sandbox in + create_builder store conf >>= fun (Builder ((module Builder), builder)) -> let log id = Logs.info (fun f -> f "Deleting %S" id) in let end_time = Unix.(gettimeofday () +. 60.0 |> gmtime) in let rec aux () = Fmt.pr "Pruning...@."; - Build.prune ~log builder ~before:end_time 1000 >>= function + Builder.prune ~log builder ~before:end_time 1000 >>= function | 0 -> Lwt.return_unit | _ -> aux () in @@ -231,13 +233,13 @@ let store = Arg.required @@ Arg.pos 0 Arg.(some store_t) None @@ Arg.info - ~doc:"zfs:pool or btrfs:/path for build cache" + ~doc:"zfs:pool or btrfs:/path or docker: for build cache" ~docv:"STORE" [] let cmd = let doc = "Run stress tests." in - Term.(const stress $ store $ Sandbox.cmdliner), + Term.(const stress $ store $ Runc_sandbox.cmdliner), Term.info "stress" ~doc let () = diff --git a/test/dune b/test/dune index 24643bec..c025b816 100644 --- a/test/dune +++ b/test/dune @@ -1,7 +1,9 @@ +(copy_files ../static/manifest.bash) + (test (name test) (package obuilder) - (deps base.tar) + (deps base.tar manifest.bash) (libraries alcotest-lwt obuilder str)) (dirs :standard \ test1) diff --git a/test/mock_exec.ml b/test/mock_exec.ml index 9a4431d0..49885452 100644 --- a/test/mock_exec.ml +++ b/test/mock_exec.ml @@ -54,7 +54,7 @@ let exec_docker ?stdout = function | ["create"; "--"; base] -> docker_create ?stdout base | ["export"; "--"; id] -> docker_export ?stdout id | ["image"; "inspect"; "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|}; "--"; base] -> docker_inspect ?stdout base - | ["rm"; "--"; id] -> Fmt.pr "docker rm %S@." id; Lwt_result.return 0 + | ["rm"; "--force"; "--"; id] -> Fmt.pr "docker rm --force %S@." id; Lwt_result.return 0 | x -> Fmt.failwith "Unknown mock docker command %a" Fmt.(Dump.list string) x let mkdir = function diff --git a/test/test.ml b/test/test.ml index 2fb2a480..f369ac06 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,7 +1,7 @@ open Lwt.Infix open Obuilder -module B = Builder(Mock_store)(Mock_sandbox)(Docker) +module B = Builder(Mock_store)(Mock_sandbox)(Docker_extract) let ( / ) = Filename.concat let ( >>!= ) = Lwt_result.bind @@ -563,46 +563,87 @@ let manifest = (Alcotest.of_pp (fun f (`Msg m) -> Fmt.string f m)) (* Test copy step. *) -let test_copy _switch () = - Lwt_io.with_temp_dir ~prefix:"test-copy-" @@ fun src_dir -> +let test_copy generate = + Lwt_io.with_temp_dir ~prefix:"test-copy-bash-" @@ fun src_dir -> Lwt_io.(with_file ~mode:output) (src_dir / "file") (fun ch -> Lwt_io.write ch "file-data") >>= fun () -> - (* Files *) + let root = if Sys.unix then "/root" else "C:/Windows" in + (* Files *) let f1hash = Sha256.string "file-data" in - Alcotest.(check manifest) "File" (Ok (`File ("file", f1hash))) - @@ Manifest.generate ~exclude:[] ~src_dir "file"; - Alcotest.(check manifest) "File" (Ok (`File ("file", f1hash))) - @@ Manifest.generate ~exclude:[] ~src_dir "./file"; - Alcotest.(check manifest) "File" (Ok (`File ("file", f1hash))) - @@ Manifest.generate ~exclude:[] ~src_dir "/file"; - Alcotest.(check manifest) "Missing" (Error (`Msg {|Source path "file2" not found|})) - @@ Manifest.generate ~exclude:[] ~src_dir "file2"; - Alcotest.(check manifest) "Not dir" (Error (`Msg {|Not a directory: file (in "file/file2")|})) - @@ Manifest.generate ~exclude:[] ~src_dir "file/file2"; - Alcotest.(check manifest) "Parent" (Error (`Msg {|Can't use .. in source paths! (in "../file")|})) - @@ Manifest.generate ~exclude:[] ~src_dir "../file"; + generate ~exclude:[] ~src_dir "file" >>= fun r -> + Alcotest.(check manifest) "File" (Ok (`File ("file", f1hash))) r; + generate ~exclude:[] ~src_dir "./file" >>= fun r -> + Alcotest.(check manifest) "File relative" (Ok (`File ("file", f1hash))) r; + generate ~exclude:[] ~src_dir "/file" >>= fun r -> + Alcotest.(check manifest) "File absolute" (Ok (`File ("file", f1hash))) r; + generate ~exclude:[] ~src_dir "file2" >>= fun r -> + Alcotest.(check manifest) "Missing" (Error (`Msg {|Source path "file2" not found|})) r; + generate ~exclude:[] ~src_dir "file/file2" >>= fun r -> + Alcotest.(check manifest) "Not dir" (Error (`Msg {|Not a directory: file (in "file/file2")|})) r; + generate ~exclude:[] ~src_dir "../file" >>= fun r -> + Alcotest.(check manifest) "Parent" (Error (`Msg {|Can't use .. in source paths! (in "../file")|})) r; (* Symlinks *) - Unix.symlink "/root" (src_dir / "link"); - Alcotest.(check manifest) "Link" (Ok (`Symlink (("link", "/root")))) - @@ Manifest.generate ~exclude:[] ~src_dir "link"; - Alcotest.(check manifest) "Follow link" (Error (`Msg {|Not a regular file: link (in "link/file")|})) - @@ Manifest.generate ~exclude:[] ~src_dir "link/file"; + Unix.symlink ~to_dir:true root (src_dir / "link"); + generate ~exclude:[] ~src_dir "link" >>= fun r -> + Alcotest.(check manifest) "Link" (Ok (`Symlink (("link", root)))) r; + generate ~exclude:[] ~src_dir "link/file" >>= fun r -> + Alcotest.(check manifest) "Follow link" (Error (`Msg {|Not a regular file: link (in "link/file")|})) r; (* Directories *) + generate ~exclude:["file"] ~src_dir "" >>= fun r -> Alcotest.(check manifest) "Tree" - (Ok (`Dir ("", [`Symlink ("link", "/root")]))) - @@ Manifest.generate ~exclude:["file"] ~src_dir ""; + (Ok (`Dir ("", [`Symlink ("link", root)]))) r; + generate ~exclude:[] ~src_dir "." >>= fun r -> Alcotest.(check manifest) "Tree" (Ok (`Dir ("", [`File ("file", f1hash); - `Symlink ("link", "/root")]))) - @@ Manifest.generate ~exclude:[] ~src_dir "."; + `Symlink ("link", root)]))) r; Unix.mkdir (src_dir / "dir1") 0o700; Unix.mkdir (src_dir / "dir1" / "dir2") 0o700; Lwt_io.(with_file ~mode:output) (src_dir / "dir1" / "dir2" / "file2") (fun ch -> Lwt_io.write ch "file2") >>= fun () -> let f2hash = Sha256.string "file2" in - Alcotest.(check manifest) "Nested file" (Ok (`File ("dir1/dir2/file2", f2hash))) - @@ Manifest.generate ~exclude:[] ~src_dir "dir1/dir2/file2"; + generate ~exclude:[] ~src_dir "dir1/dir2/file2" >>= fun r -> + Alcotest.(check manifest) "Nested file" (Ok (`File ("dir1/dir2/file2", f2hash))) r; + generate ~exclude:[] ~src_dir "dir1" >>= fun r -> Alcotest.(check manifest) "Tree" - (Ok (`Dir ("dir1", [`Dir ("dir1/dir2", [`File ("dir1/dir2/file2", f2hash)])]))) - @@ Manifest.generate ~exclude:[] ~src_dir "dir1"; + (Ok (`Dir ("dir1", [`Dir ("dir1/dir2", [`File ("dir1/dir2/file2", f2hash)])]))) r; + Os.lwt_process_exec := Mock_exec.exec; + Lwt.return_unit + +(* Test the Manifest module. *) +let test_copy_ocaml _switch () = + test_copy (fun ~exclude ~src_dir src -> Lwt_result.lift (Manifest.generate ~exclude ~src_dir src)) + +(* Test the manifest.bash script. *) +let test_copy_bash _switch () = + Os.lwt_process_exec := Os.default_exec; + let generate ~exclude ~src_dir src = + begin if Sys.win32 then + Os.pread ["cygpath"; "-m"; "/usr/bin/bash"] >>= fun bash -> + Os.pread ["cygpath"; "-m"; src_dir] >>= fun src_dir -> + Lwt.return (String.trim bash, String.trim src_dir) + else + Lwt.return ("/bin/bash", src_dir) + end >>= fun (bash, src_dir) -> + let manifest_bash = + Printf.sprintf "exec %s %S %S %d %s %d %s" + "./manifest.bash" + src_dir + "/" + (List.length exclude) + (String.concat " " (List.map Filename.quote exclude)) + 1 + (Filename.quote src) + in + let argv = [ "--login"; "-c"; manifest_bash ] in + let pp f = Os.pp_cmd f argv in + Os.pread_all ~pp ~cmd:bash argv >>= fun (n, stdout, stderr) -> + if n = 0 then + Lwt_result.return @@ Manifest.t_of_sexp (Sexplib.Sexp.of_string stdout) + else if n = 1 then + Lwt_result.fail (`Msg stderr) + else + Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n + in + test_copy generate >>= fun () -> + Os.lwt_process_exec := Mock_exec.exec; Lwt.return_unit let test_cache_id () = @@ -648,7 +689,7 @@ let test_cache_id () = log; Lwt.return_unit -let () = +let main_unix () = let open Alcotest_lwt in Lwt_main.run begin run "OBuilder" [ @@ -675,7 +716,20 @@ let () = test_case "No secret provided" `Quick test_secrets_not_provided; ]; "manifest", [ - test_case "Copy" `Quick test_copy; + test_case "Copy using Manifest" `Quick test_copy_ocaml; + test_case "Copy using manifest.bash" `Quick test_copy_bash; ]; ] end + +let main_win32 () = + let open Alcotest_lwt in + Lwt_main.run begin + run "OBuilder" [ + "manifest", [ + test_case "Copy using manifest.bash" `Quick test_copy_bash; + ]; + ] + end + +let () = if Sys.win32 then main_win32 () else main_unix ()