From 59c4b2948aaf850a1309b73229ce8d9c040b631c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Fri, 7 Apr 2023 19:09:27 +0200 Subject: [PATCH] Introduce a Docker backend in OBuilder for Windows and Linux (#127) --- .github/workflows/main.sh | 29 ++- .github/workflows/main.yml | 29 +++ CHANGES.md | 2 + README.md | 36 +-- dune-project | 2 + lib/build.ml | 269 +++++++++++++++++++- lib/build.mli | 6 + lib/config.ml | 5 +- lib/docker.ml | 403 +++++++++++++++++++++++++++--- lib/docker.mli | 75 +++++- lib/docker_sandbox.ml | 499 +++++++++++++++++++++++++++++++++++++ lib/docker_sandbox.mli | 61 +++++ lib/docker_store.ml | 216 ++++++++++++++++ lib/docker_store.mli | 7 + lib/dune | 9 +- lib/manifest.ml | 15 +- lib/manifest.mli | 6 +- lib/obuilder.ml | 8 +- lib/os.ml | 116 ++++++++- lib/s.ml | 132 +++++++++- lib/sandbox.runc.ml | 7 +- lib/store_spec.ml | 17 +- lib/tar_transfer.ml | 78 +++++- lib/tar_transfer.mli | 24 ++ main.ml | 58 +++-- obuilder.opam | 2 + static/extract.cmd | 14 ++ static/manifest.bash | 159 ++++++++++++ stress/stress.ml | 32 ++- test/dune | 4 +- test/mock_exec.ml | 5 +- test/test.ml | 62 ++++- windows.md | 238 ++++++++++++++++++ 33 files changed, 2496 insertions(+), 129 deletions(-) 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 static/extract.cmd create mode 100755 static/manifest.bash create mode 100644 windows.md diff --git a/.github/workflows/main.sh b/.github/workflows/main.sh index f7a21824..3326841b 100755 --- a/.github/workflows/main.sh +++ b/.github/workflows/main.sh @@ -2,8 +2,6 @@ set -eux export OPAMYES=true -sudo chmod a+x /usr/local/bin/runc - sudo sh -c "cat > /usr/local/bin/uname" << EOF #!/bin/sh @@ -19,6 +17,8 @@ opam exec -- make case "$1" in btrfs) + sudo chmod a+x /usr/local/bin/runc + dd if=/dev/zero of=/tmp/btrfs.img bs=100M count=50 BTRFS_LOOP=$(sudo losetup -f) sudo losetup -P "$BTRFS_LOOP" /tmp/btrfs.img @@ -43,6 +43,8 @@ case "$1" in ;; zfs) + sudo chmod a+x /usr/local/bin/runc + dd if=/dev/zero of=/tmp/zfs.img bs=100M count=50 ZFS_LOOP=$(sudo losetup -f) sudo losetup -P "$ZFS_LOOP" /tmp/zfs.img @@ -83,6 +85,8 @@ case "$1" in # ;; rsync_hardlink) + sudo chmod a+x /usr/local/bin/runc + sudo mkdir /rsync sudo chown "$(whoami)" /rsync @@ -99,7 +103,9 @@ case "$1" in sudo rm -rf /rsync ;; - rsync_copy) + rsync_copy) + sudo chmod a+x /usr/local/bin/runc + sudo mkdir /rsync sudo chown "$(whoami)" /rsync @@ -115,6 +121,23 @@ case "$1" in sudo rm -rf /rsync ;; + + docker) + sudo mkdir /var/lib/obuilder + sudo chown "$(whoami)" /var/lib/obuilder + + opam exec -- dune exec -- obuilder healthcheck --store=docker:/var/lib/obuilder + + # Populate the caches from our own GitHub Actions cache + sudo mkdir -p /var/lib/obuilder/cache/c-opam-archives + sudo cp -r ~/.opam/download-cache/* /var/lib/obuilder/cache/c-opam-archives/ + sudo chown -R 1000:1000 /var/lib/obuilder/cache/c-opam-archives + + opam exec -- dune exec -- obuilder build -f example.spec . --store=docker:/var/lib/obuilder --color=always + + sudo rm -rf /var/lib/obuilder + ;; + *) printf "Usage: .run-gha-tests.sh [btrfs|rsync_hardlink|rsync_copy|zfs]" >&2 exit 1 diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 59fee653..493f8352 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -128,3 +128,32 @@ jobs: - run: opam install . --deps-only --with-test - run: opam exec -- dune runtest + + docker: + strategy: + fail-fast: false + matrix: + os: + - ubuntu-latest + ocaml-compiler: + - 4.14.x + + runs-on: ${{ matrix.os }} + + steps: + - name: Checkout + uses: actions/checkout@v3 + + - name: Use OCaml ${{ matrix.ocaml-compiler }} + uses: ocaml/setup-ocaml@v2 + with: + ocaml-compiler: ${{ matrix.ocaml-compiler }} + + - run: opam install . --deps-only --with-test + + # - name: Set up QEMU + # uses: docker/setup-qemu-action@v2 + - name: Set up Docker Buildx + uses: docker/setup-buildx-action@v2 + + - run: $GITHUB_WORKSPACE/.github/workflows/main.sh docker diff --git a/CHANGES.md b/CHANGES.md index 7c6eb95a..6122b84d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,7 @@ ### v0.5.1 +- Add a Docker backend for Windows and Linux jobs. + (@MisterDA #127 #75, reviewed by @talex5, @tmcgilchrist) - Updates to address rsync and sandbox issues. (@mtelvers #139, reviewed by @tmcgilchrist and @MisterDA) - Add an obuilder clean command to clean all build results. diff --git a/README.md b/README.md index d7cc8e06..846863a8 100644 --- a/README.md +++ b/README.md @@ -7,11 +7,14 @@ OBuilder takes a build script (similar to a Dockerfile) and performs the steps in it in a sandboxed environment. -After each step, OBuilder uses the snapshot feature of the filesystem (ZFS or Btrfs) to store the state of the build. There is also an Rsync backend that copies the build state. +After each step, OBuilder uses the snapshot feature of the filesystem (ZFS or +Btrfs) to store the state of the build. There is also an Rsync backend that +copies the build state. 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. @@ -105,8 +108,8 @@ The initial context is supplied by the user (see [build.mli](lib/build.mli) for By default: - The environment is taken from the Docker configuration of `BASE`. - The user is `(uid 0) (gid 0)` on Linux, `(name ContainerAdministrator)` on Windows. -- The workdir is `/`. -- The shell is `/bin/bash -c`. +- The workdir is `/`, `C:/` on Windows. +- The shell is `/bin/bash -c`, `C:\Windows\System32\cmd.exe /S /C` on Windows. ### Multi-stage builds @@ -130,7 +133,6 @@ For example: At the moment, the `(build …)` items must appear before the `(from …)` line. - ### workdir ```sexp @@ -169,7 +171,6 @@ The command run will be this list of arguments followed by the single argument ` (network NETWORK…)? (secrets SECRET…)? (shell COMMAND)) - ``` Examples: @@ -210,9 +211,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 @@ -261,8 +262,14 @@ 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 @@ -312,10 +319,10 @@ The dockerfile should work the same way as the spec file, except for these limit - All `(network …)` fields are ignored, as Docker does not allow per-step control of networking. -## Experimental macOS Support +## Experimental macOS and Windows Support OBuilder abstracts over a fetching mechanism for the Docker base image, the sandboxing for the execution of build steps and the store for the cache. -This makes OBuilder extremely portable and there exists a (very) experimental [macOS][] backend. +This makes OBuilder extremely portable and there exists experimental [macOS][] and [Windows][] backends. The Windows backend currently requires Docker for Windows installed. ## Licensing @@ -326,6 +333,7 @@ See [LICENSE][] for the full license text. [OCluster]: https://github.com/ocurrent/ocluster [LICENSE]: ./LICENSE [macOS]: ./macOS.md +[Windows]: ./windows.md [github-shield]: https://github.com/ocurrent/obuilder/actions/workflows/main.yml/badge.svg [github-ci]: https://github.com/ocurrent/obuilder/actions/workflows/main.yml diff --git a/dune-project b/dune-project index dfda5c90..ac2cf888 100644 --- a/dune-project +++ b/dune-project @@ -37,7 +37,9 @@ ppx_sexp_conv (sha (>= 1.15.4)) sqlite3 + (crunch (and (>= 3.3.1) :build)) (obuilder-spec (= :version)) + fpath (ocaml (>= 4.14.1)) (alcotest-lwt (and (>= 1.7.0) :with-test)))) diff --git a/lib/build.ml b/lib/build.ml index 589943b0..e9103bb0 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -2,15 +2,21 @@ 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 + Docker_sandbox.servercore () >>= fun (`Docker_image servercore) -> + Lwt.return servercore + else Lwt.return "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" ] @@ -80,7 +86,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st 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 } + { Config.Mount.ty = `Bind; src; dst = target; readonly = false } ) >>= fun mounts -> let argv = shell @ [cmd] in @@ -273,12 +279,11 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st 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 result = Docker.Cmd.version ~stderr:(`FD_move_safely w) () 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 () + | Ok _desc -> 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 @@ -286,6 +291,258 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st (* 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 + healthcheck_base () >>= function healthcheck_base -> + 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 } + + let finish t = + Store.unwrap t.store; + Lwt.return_unit +end + +module Make_Docker (Raw_store : S.STORE) = struct + module Store = Db_store.Make(Raw_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 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.ty = `Volume; src; dst = target; readonly = false } + ) + >>= fun mounts -> + let entrypoint, argv = Docker.setup_command ~entp:shell ~cmd:[cmd] in + let config = Config.v ~cwd:workdir ~entrypoint ~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_sandbox.teardown ~log ~commit:true id) + ) + (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 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, _) -> Docker_sandbox.manifest_from_build t.sandbox ~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 + let dst_dir = match op with `Copy_items (_, dst_dir) when Sys.win32 -> Some dst_dir | _ -> None in + (* Fmt.pr "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 _ -> + match src_dir with + | `Context src_dir -> + Docker_sandbox.copy_from_context t.sandbox ~cancelled ~log op ~user ~src_dir ?dst_dir id + | `Build (from_id, _) -> + Docker_sandbox.copy_from_build t.sandbox ~cancelled ~log op ~user ~workdir ?dst_dir ~from_id id + ) + + 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:"/" path then (if Sys.win32 then "C:" ^ path else path) + else 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.(str "%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 -> + (* Unspecified, but consistent with copy stanza *) + let shell = match shell with + | hd :: tl when not Sys.unix && hd.[0] = '/' -> ("C:" ^ hd) :: tl + | _ -> shell + in + k ~base ~context:{context with shell} + + let get_base t ~log base = + log `Heading (Fmt.str "(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:_ _ -> + Log.info (fun f -> f "Base image not present; importing %S…" base); + Docker.Cmd.pull (`Docker_image base) >>= fun () -> + Docker.Cmd.tag (`Docker_image base) (Docker.docker_image id) >>= fun () -> + Lwt_result.return () + ) + >>!= fun id -> + Lwt_result.return (id, []) + + 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.(str "(build %S …)" name); + build ~scope t context child_spec >>!= fun child_result -> + context.Context.log `Note Fmt.(str "--> 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=if Sys.win32 then 300.0 else 30.0) t = + Os.with_pipe_from_child (fun ~r ~w -> + let result = Docker.Cmd.version ~stderr:(`FD_move_safely w) () in + let r = Lwt_io.(of_fd ~mode:input) r ~close:Lwt.return in + Lwt_io.read r >>= fun err -> + result >>= function + | Ok _desc -> 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 src_dir = if Sys.win32 then {|C:\TEMP|} else "/tmp" in + let context = Context.v ~switch ~log ~src_dir () in + healthcheck_base () >>= function healthcheck_base -> get_base t ~log healthcheck_base >>= function | Error (`Msg _) as x -> Lwt.return x | Error `Cancelled -> failwith "Cancelled getting base image (shouldn't happen!)" diff --git a/lib/build.mli b/lib/build.mli index f839c16d..df217ece 100644 --- a/lib/build.mli +++ b/lib/build.mli @@ -27,3 +27,9 @@ module Make (Store : S.STORE) (Sandbox : S.SANDBOX) (_ : S.FETCHER) : sig val v : store:Store.t -> sandbox:Sandbox.t -> t end + +module Make_Docker (Store : S.STORE) : sig + include S.BUILDER with type context := Context.t + + val v : store:Store.t -> sandbox:Docker_sandbox.t -> t +end diff --git a/lib/config.ml b/lib/config.ml index 340365c4..b3cc4efd 100644 --- a/lib/config.ml +++ b/lib/config.ml @@ -6,7 +6,8 @@ open Sexplib.Std type env = (string * string) list [@@deriving sexp] module Mount = struct - type t = { (* TODO: options *) + type t = { + ty : [ `Bind | `Volume ]; src : string; (* In host namespace *) dst : string; (* In container namespace *) readonly : bool; @@ -22,6 +23,7 @@ end type t = { cwd : string; + entrypoint : string option; argv : string list; hostname : string; user : Obuilder_spec.user; @@ -29,7 +31,6 @@ type t = { mounts : Mount.t list; network : string list; mount_secrets : Secret.t list; - entrypoint : string option; } let v ~cwd ~argv ~hostname ~user ~env ~mounts ~network ~mount_secrets ?entrypoint () = diff --git a/lib/docker.ml b/lib/docker.ml index c52f1fd2..b37ba8b0 100644 --- a/lib/docker.ml +++ b/lib/docker.ml @@ -1,37 +1,380 @@ -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_libexec () = !prefix ^ "-libexec" +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 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 ( / ) = Filename.concat +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 obuilder_libexec_volume ?(readonly=true) () = + Config.Mount.{ + ty = `Volume; + src = obuilder_libexec (); + dst = mount_point_inside_native / obuilder_libexec (); + readonly; + } + +let bash_entrypoint obuilder_libexec = + [if Sys.win32 then mount_point_inside_native / obuilder_libexec / "bash.exe" else "bash"; "-c"] + +let default_entrypoint = + if Sys.win32 then [{|C:\Windows\System32\cmd.exe|}; "/S"; "/C"] + else ["/bin/sh"; "-c"] + +let rec setup_command ~entp ~cmd = + match entp with + | hd :: tl -> hd, tl @ cmd + | [] -> setup_command ~entp:default_entrypoint ~cmd + +let extract_name = function `Docker_image name | `Docker_container name | `Docker_volume name -> name + +let pread ?timeout ?stderr argv = + let stderr = Option.value ~default:(`FD_move_safely Os.stderr) stderr in + Os.pread ?timeout ~stderr ("docker" :: argv) + +let pread_result ?stdin ?stderr argv = + let cmd = "docker" :: argv in + let pp f = Os.pp_cmd f ("", cmd) in + let stdin = Option.value ~default:`Dev_null stdin in + let stderr = Option.value ~default:(`FD_move_safely Os.stderr) stderr in + Os.pread_result ~pp ~stdin ~stderr cmd + +let exec' ?stdin ?stdout ?stderr ?is_success argv = + let stdin = Option.value ~default:`Dev_null stdin in + let stdout = Option.value ~default:(`FD_move_safely Os.stdout) stdout in + let stderr = Option.value ~default:(`FD_move_safely Os.stderr) stderr in + Os.exec ~stdin ~stdout ~stderr ?is_success ("docker" :: argv) + +let exec_result' ?stdin ?stdout ?stderr ?is_success argv = + let cmd = "docker" :: argv in + let pp f = Os.pp_cmd f ("", cmd) in + let stdin = Option.value ~default:`Dev_null stdin in + let stdout = Option.value ~default:(`FD_move_safely Os.stdout) stdout in + let stderr = Option.value ~default:(`FD_move_safely Os.stderr) stderr in + Os.exec_result ~stdin ~stdout ~stderr ?is_success ~pp cmd + +module Cmd = struct + type 'a log = ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + 'a + type 'a logerr = ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + 'a + + let version ?stderr () = + pread_result ?stderr (["version"]) + + let create ?stderr (`Docker_image base) = + pread ?stderr ("create" :: ["--"; base]) + + let export ?stdout ?stderr (`Docker_container id) = + exec' ?stdout ?stderr ["export"; "--"; id] + + let image ?stdout ?stderr (`Remove (`Docker_image id)) = + exec' ?stdout ?stderr ["image"; "rm"; id] + + let rm ?stdout ?stderr containers = + exec' ?stdout ?stderr ("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 ?stderr (`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 ?stderr ("commit" :: argv) + + let pull ?stdout ?stderr (`Docker_image base) = + exec' ?stdout ?stderr ["pull"; base] + + let exists ?(stdout=`Dev_null) ?stderr id = + let argv = match id with + | `Docker_container id -> ["inspect"; "--type=container"; "--"; id] + | `Docker_image id -> ["inspect"; "--type=image"; "--"; id] + | `Docker_volume id -> ["volume"; "inspect"; "--"; id] + in + exec_result' ~stdout ?stderr argv + + let build ?stdout ?stderr docker_argv (`Docker_image image) context_path = + exec' ?stdout ?stderr ("build" :: docker_argv @ ["-t"; image; context_path]) + + let run_argv ?stdin ?name ~rm ~docker_argv image argv = + let docker_argv = if rm then "--rm" :: docker_argv else docker_argv in + let docker_argv = match name with + | Some (`Docker_container name) -> "--name" :: name :: docker_argv + | None -> docker_argv in + let docker_argv = match stdin with + | Some (`FD_move_safely _) -> "-i" :: docker_argv + | _ -> docker_argv in + "run" :: docker_argv @ image :: argv + + let run ?stdin ?stdout ?stderr ?is_success ?name ?(rm=false) docker_argv (`Docker_image image) argv = + let argv = run_argv ?stdin ?name ~rm ~docker_argv image argv in + exec' ?stdin ?stdout ?stderr ?is_success argv + + let run_result ?stdin ?stdout ?stderr ?name ?(rm=false) docker_argv (`Docker_image image) argv = + let argv = run_argv ?stdin ?name ~rm ~docker_argv image argv in + exec_result' ?stdin ?stdout ?stderr argv + + let run_pread_result ?stdin ?stderr ?name ?(rm=false) docker_argv (`Docker_image image) argv = + let argv = run_argv ?name ~rm ~docker_argv image argv in + pread_result ?stdin ?stderr argv + + let run' = run + let run_result' = run_result + + let stop ?stdout ?stderr (`Docker_container name) = + exec_result' ?stdout ?stderr ["stop"; name] + + let volume ?stderr ?timeout = function + | `Create (`Docker_volume name) -> + pread ?timeout ("volume" :: "create" :: "--" :: name :: []) + | `Inspect (volumes, `Mountpoint) -> + let volumes = List.rev_map extract_name volumes in + let format = "{{ .Mountpoint }}" in + pread ?stderr ("volume" :: "inspect" :: "--format" :: format :: "--" :: volumes) + | `List (filter) -> + let filter = match filter with None -> [] | Some filter -> ["--filter"; filter] in + pread ?stderr ("volume" :: "ls" :: "--quiet" :: filter) + | `Remove volumes -> + let volumes = List.rev_map extract_name volumes in + pread ("volume" :: "rm" :: "--" :: volumes) + + let volume_containers ?stderr (`Docker_volume name) = + let+ names = pread ?stderr (["ps"; "-a"; "--filter"; "volume=" ^ name; "--format={{ .Names }}"]) in + names |> String.trim |> String.split_on_char '\n' + |> List.map (fun id -> `Docker_container id) + + let mount_point ?stderr name = + let* s = volume ?stderr (`Inspect ([name], `Mountpoint)) in + Lwt.return (String.trim s) + + let rmi ?stdout ?stderr images = + exec' ?stdout ?stderr ("rmi" :: (List.rev_map extract_name images)) + + let manifest ?stdout ?stderr = function + | `Create (`Docker_image name, manifests) -> + exec_result' ?stdout ?stderr ("manifest" :: "create" :: name :: (List.rev_map extract_name manifests)) + | `Inspect (`Docker_image name) -> + exec_result' ?stdout ?stderr ["manifest"; "inspect"; name] + | `Remove manifests -> + exec_result' ?stdout ?stderr ("manifest" :: "rm" :: (List.rev_map extract_name manifests)) + + let obuilder_images ?stderr ?tmp () = + let* images = pread ?stderr ["images"; "--format={{ .Repository }}"; image_name ?tmp "*"] in + String.split_on_char '\n' images + |> List.filter_map (function "" -> None | id -> Some (`Docker_image id)) + |> Lwt.return + + let obuilder_containers ?stderr () = + let* containers = pread ?stderr ["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 ?stderr ?(prefix=(!prefix)) () = + let* volumes = volume ?stderr (`List (Some ("name=^" ^ prefix))) in + String.split_on_char '\n' volumes + |> List.filter_map (function "" -> None | id -> Some (`Docker_volume id)) + |> Lwt.return + + let obuilder_caches_tmp ?stderr () = + obuilder_volumes ?stderr ~prefix:(cache_prefix () ^ "tmp-") () +end + + +module Cmd_log = struct + + type 'a log = log:Build_log.t -> 'a + type 'a logerr = log:Build_log.t -> 'a + + let with_stderr_log ~log fn = + Os.with_pipe_from_child @@ fun ~r:err_r ~w:err_w -> + let stderr = `FD_move_safely err_w in + let copy_log = Build_log.copy ~src:err_r ~dst:log in + let* r = fn ~stderr in + let+ () = copy_log in + r + + let with_log ~log fn = + 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* r = fn ~stdout ~stderr in + let+ () = copy_log in + r + + let version ~log () = + with_stderr_log ~log (fun ~stderr -> Cmd.version ~stderr ()) + + let pull ~log base = + with_log ~log (fun ~stdout ~stderr -> Cmd.pull ~stdout ~stderr base) + + let export ~log container = + with_log ~log (fun ~stdout ~stderr -> Cmd.export ~stdout ~stderr container) + + let image ~log cmd = + with_log ~log (fun ~stdout ~stderr -> Cmd.image ~stdout ~stderr cmd) + + let rm ~log containers = + with_log ~log (fun ~stdout ~stderr -> Cmd.rm ~stdout ~stderr containers) + + let rmi ~log images = + with_log ~log (fun ~stdout ~stderr -> Cmd.rmi ~stdout ~stderr images) + + let tag ~log source target = + with_log ~log (fun ~stdout ~stderr -> Cmd.tag ~stdout ~stderr source target) + + let commit ~log base_image container target_image = + with_log ~log (fun ~stdout ~stderr -> + Cmd.commit ~stdout ~stderr base_image container target_image) + + let volume ~log ?timeout cmd = + with_stderr_log ~log (fun ~stderr -> Cmd.volume ~stderr ?timeout cmd) + + let volume_containers ~log volume = + with_stderr_log ~log (fun ~stderr -> Cmd.volume_containers ~stderr volume) + + let mount_point ~log volume = + with_stderr_log ~log (fun ~stderr -> Cmd.mount_point ~stderr volume) + + let build ~log docker_argv image context_path = + with_log ~log (fun ~stdout ~stderr -> + Cmd.build ~stdout ~stderr docker_argv image context_path) + + let stop ~log name = + with_log ~log (fun ~stdout ~stderr -> Cmd.stop ~stdout ~stderr name) + + let manifest ~log cmd = + with_log ~log (fun ~stdout ~stderr -> Cmd.manifest ~stdout ~stderr cmd) + + let exists ~log cmd = + with_log ~log (fun ~stdout ~stderr -> Cmd.exists ~stdout ~stderr cmd) + + let run ?stdin ~log ?is_success ?name ?rm docker_argv image argv = + with_log ~log (fun ~stdout ~stderr -> + Cmd.run ?stdin ~stdout ~stderr ?is_success ?name ?rm docker_argv image argv) + + let run' ?stdin ?stdout ~log ?is_success ?name ?rm docker_argv image argv = + with_stderr_log ~log (fun ~stderr -> + Cmd.run' ?stdin ?stdout ~stderr ?is_success ?name ?rm docker_argv image argv) + + let run_result ?stdin ~log ?name ?rm docker_argv image argv = + with_log ~log (fun ~stdout ~stderr -> + Cmd.run_result ?stdin ~stdout ~stderr ?name ?rm docker_argv image argv) + + let run_result' ?stdin ?stdout ~log ?name ?rm docker_argv image argv = + with_stderr_log ~log (fun ~stderr -> + Cmd.run_result' ?stdin ?stdout ~stderr ?name ?rm docker_argv image argv) + + let run_pread_result ?stdin ~log ?name ?rm docker_argv image argv = + with_stderr_log ~log (fun ~stderr -> + Cmd.run_pread_result ?stdin ~stderr ?name ?rm docker_argv image argv) + + let obuilder_images ~log ?tmp () = + with_stderr_log ~log (fun ~stderr -> Cmd.obuilder_images ~stderr ?tmp ()) + + let obuilder_containers ~log () = + with_stderr_log ~log (fun ~stderr -> Cmd.obuilder_containers ~stderr ()) + + let obuilder_volumes ~log ?prefix () = + with_stderr_log ~log (fun ~stderr -> Cmd.obuilder_volumes ~stderr ?prefix ()) + + let obuilder_caches_tmp ~log () = + with_stderr_log ~log (fun ~stderr -> Cmd.obuilder_caches_tmp ~stderr ()) +end + +let root = Fpath.v (if Sys.win32 then {|C:\|} else "/") + +let mount_args (mount:Config.Mount.t) = + (* Unspecified, but consistent with copy stanza *) + let dst = if not Sys.unix && mount.Config.Mount.dst.[0] = '/' then "C:" ^ mount.dst else mount.dst in + [ "--mount"; Printf.sprintf "type=%s,src=%s,dst=%s%s" + (match mount.ty with `Bind -> "bind" | `Volume -> "volume") + mount.src dst (if mount.readonly then ",readonly" else "") ] + +let cp_between_volumes ~base ~src ~dst = + let (`Docker_volume src) = src and (`Docker_volume dst) = dst in + let root = Fpath.to_string root in + let mounts_proc = Config.Mount.{ty = `Volume; src = dst; dst = root / "dst"; readonly = false } + and mounts_send = Config.Mount.{ty = `Volume; src = src; dst = root / "src"; readonly = true } in + let mounts_args mount = mount :: (if Sys.win32 then [obuilder_libexec_volume ()] else []) + |> List.concat_map mount_args in + let mounts_send = mounts_args mounts_send and mounts_proc = mounts_args mounts_proc in + let tar = if Sys.win32 then mount_point_inside_native / obuilder_libexec () / "tar.exe" + else "tar" in + let root = if Sys.win32 then {|/cygdrive/c/|} else "/" in + Os.with_pipe_between_children @@ fun ~r ~w -> + let proc = Cmd.run_result' ~stdin:(`FD_move_safely r) ~rm:true mounts_proc base [tar; "-xp"; "-C"; root ^ "dst"; "-f"; "-"] + and send = Cmd.run_result' ~stdout:(`FD_move_safely w) ~rm:true mounts_send base [tar; "-c"; "-C"; root ^ "src"; "-f"; "-"; "."] in + let open Lwt_result.Syntax in + let* () = proc in + let+ () = send in + () 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 = Cmd.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 () -> Cmd.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 = + let* () = with_container ~log base (fun cid -> + Os.with_pipe_between_children @@ fun ~r ~w -> + let exporter = Cmd.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..e15bca78 100644 --- a/lib/docker.mli +++ b/lib/docker.mli @@ -1,3 +1,74 @@ -(** 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_libexec : unit -> string +val obuilder_libexec_volume : ?readonly:bool -> unit -> Config.Mount.t + +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 mount_point_inside_unix : string +(** Mount point of Docker volumes inside Docker containers, Unix path + style. Use with Cygwin tools. *) + +val mount_point_inside_native : string +(** Mount point of Docker volumes inside Docker containers, native + path style. *) + +(** Get the CLI arguments to the Docker client to mount a volume. *) +val mount_args : Config.Mount.t -> string list + +val bash_entrypoint : string -> string list +(** Get a Bash entrypoint in a Docker container to execute Bash + scripts. *) + +val default_entrypoint : string list +(** Get the default entrypoint of Docker container according to the + host (Windows is cmd, everywhere else is sh). *) + +val setup_command : entp:string list -> cmd:string list -> string * string list +(** [setup_command ~entp ~cmd] returns the head of [entp], to be + give to Docker's [--entrypoint], and the concatenation of the tail + of [head] and [cmd] to be given to Docker command, as Docker + [--entrypoint] takes only one argument. *) + +val cp_between_volumes : + base:[< `Docker_image of string ] -> + src:[< `Docker_volume of string] -> dst:[`Docker_volume of string] -> + (unit, [> `Msg of string]) Lwt_result.t + +(** Wrappers for various Docker client commands, exposing file descriptors. *) +module Cmd : S.DOCKER_CMD + with + type 'a log = ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + 'a + and + type 'a logerr = ?stderr:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + 'a + +(** Wrappers for various Docker client commands, logging directly to the + {!Build_log}. *) +module Cmd_log : S.DOCKER_CMD + with + type 'a log = log:Build_log.t -> 'a + and + type 'a logerr = log:Build_log.t -> 'a + +(** Fetch (pull and extract) base images using Docker *) +module Extract : S.FETCHER diff --git a/lib/docker_sandbox.ml b/lib/docker_sandbox.ml new file mode 100644 index 00000000..8cece18c --- /dev/null +++ b/lib/docker_sandbox.ml @@ -0,0 +1,499 @@ +open Lwt.Syntax +let ( >>!= ) = Lwt_result.bind +open Sexplib.Conv + +let ( / ) = Filename.concat +let ( // ) dirname filename = + if Sys.win32 then + let l = String.length dirname in + if l = 0 || dirname.[l-1] = '/' + then dirname ^ filename + else dirname ^ "/" ^ filename + else Filename.concat dirname filename + +let strf = Printf.sprintf + +type isolation = [ `HyperV | `Process | `Default ] [@@deriving sexp] +let isolations : (isolation * string) list = [(`HyperV, "hyperv"); (`Process, "process"); (`Default, "default")] + +type t = { + docker_cpus : float; + docker_isolation : isolation; + docker_memory : string option; + docker_network : string; (* Default network, overridden by network stanza *) +} + +type config = { + cpus : float; + isolation : isolation; + memory : string option; + network : string; +} [@@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; docker_memory; _} : t) = + assert (entrypoint <> None); + let mounts = List.concat_map Docker.mount_args mounts in + let env = env |> List.concat_map (fun (k, v) -> [ "--env"; strf "%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"; strf "%d:%d" uid gid] + | `Windows { name } when Sys.win32 -> ["--user"; name] + | _ -> assert false + in + let mount_secrets = + let id = ref (-1) in + List.concat_map (fun _ -> + incr id; + Config.Mount.{ty = `Bind; src = config_dir / secret_dir !id; dst = secrets_guest_root / secret_dir !id; readonly = true } + |> Docker.mount_args) mount_secrets in + let memory = Option.fold ~none:[] ~some:(fun m -> ["--memory"; m]) docker_memory in + let docker_argv = [ + "--cpus"; strf "%f" docker_cpus; + "--isolation"; (List.assoc docker_isolation isolations); + "--hostname"; hostname; + "--workdir"; cwd; + "--entrypoint"; Option.get entrypoint; + ] @ memory @ user @ env @ mounts @ mount_secrets @ network in + docker_argv, argv +end + +let secrets_layer ~log 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 + + Lwt_result.bind_lwt + (Docker.Cmd_log.run_result ~log ~name:container docker_argv base_image argv) + (fun () -> + let* () = Docker.Cmd_log.commit ~log base_image container base_image in + Docker.Cmd_log.rm ~log [container]) + +let teardown ~log ~commit id = + 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 + let* () = + if commit then Docker.Cmd_log.commit ~log base_image container target_image + else Lwt.return_unit + in + Docker.Cmd_log.rm ~log [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 + let proc = + Lwt_result.bind + (secrets_layer ~log config.Config.mount_secrets base_image container docker_argv) + (fun () -> + let* r = Docker.Cmd.exists container in + let* () = + if Result.is_ok r then begin + let `Docker_container name = container in + Log.warn (fun f -> f "Removing left over container %s." name); + Docker.Cmd.rm [ container ] + end else + Lwt.return_unit + in + let stdin = Option.map (fun x -> `FD_move_safely x) stdin in + Docker.Cmd_log.run_result ~log ?stdin ~name:container docker_argv base_image argv) + in + Lwt.on_termination cancelled (fun () -> + let aux () = + if Lwt.is_sleeping proc then ( + Docker.Cmd_log.rm ~log [container] + ) else Lwt.return_unit (* Process has already finished *) + in + Lwt.async aux + ); + let* r = proc in + let+ () = match r with + | Ok () -> Lwt.return_unit + | _ -> Docker.Cmd_log.rm ~log [container] + in + if Lwt.is_sleeping cancelled then (r :> (unit, [`Msg of string | `Cancelled]) result) + else Error `Cancelled + +(* Duplicate of Build.hostname. *) +let hostname = "builder" + +let manifest_from_build t ~base ~exclude src workdir user = + let argv = + (* FIXME: pipe the list of files to manifest.bash *) + Printf.sprintf "exec %s %S %S %d %s %d %s" + (Docker.mount_point_inside_unix // Docker.obuilder_libexec () // "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 config = + let entrypoint, argv = Docker.setup_command ~entp:Docker.(bash_entrypoint (obuilder_libexec ())) ~cmd:[argv] in + Config.v + ~cwd:workdir + ~argv + ~hostname + ~user + ~env:["PATH", if Sys.win32 then Docker.mount_point_inside_unix // Docker.obuilder_libexec () else "/bin:/usr/bin"] + ~mount_secrets:[] + ~mounts:[Docker.obuilder_libexec_volume ()] + ~network:[] + ~entrypoint + () + in + let docker_args, args = Docker_config.make config t in + Docker.Cmd.run_pread_result ~rm:true docker_args (Docker.docker_image base) args >>!= 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 ~log ~files_from ~tar workdir user id = + let entrypoint = + if Sys.win32 then Docker.mount_point_inside_native / Docker.obuilder_libexec () / "tar.exe" + else "tar" + in + let argv = + [ "-cf-"; "--format=gnu"; + "--directory"; workdir; + (* Beware, the order is meaningful: --files-from should come last. *) + "--verbatim-files-from"; "--null"; "--absolute-names"; "--files-from=-" ] + in + let config = + Config.v + ~cwd:workdir + ~argv + ~hostname + ~user + ~env:[] + ~mount_secrets:[] + ~mounts:[Docker.obuilder_libexec_volume ()] + ~network:[] + ~entrypoint + () + in + let docker_args, args = Docker_config.make config t in + (* FIXME: on Windows, the Docker container producing the tar archive never + stops for an unkwnown reason. However, if in the transform step ocaml-tar + reads the end-of-tar magic sequence, then we can close the output pipe of + the Docker process and ignore the error. *) + let is_success = if Sys.win32 then Some (function 0 | 1 -> true | _ -> false) else None in + Docker.Cmd_log.run' ~log ~stdin:(`FD_move_safely files_from) ~stdout:(`FD_move_safely tar) + ~rm:true ?is_success 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 ?dst_dir id = + let entrypoint, argv = + if Sys.win32 && dst_dir <> None then + "powershell", (* PowerShell 6 *) + ["-Command"; + (* Extracting the tarball changes the permissions of the destination + directory, making it un-writable by ContainerAdministrator, even if + the permissions should be set correctly in the tar header. Backup + and restore these permissions. *) + Printf.sprintf {|$path = "%s"; if (Test-Path -Path $path -PathType Container) { $acl = Get-Acl -Path $path }; & %s/tar.exe -xpf - --verbose; if ($acl -ne $null) { Set-Acl -Path $path $acl }|} + (Option.get dst_dir) (Docker.mount_point_inside_native // Docker.obuilder_libexec ()) ] + else begin + assert (dst_dir = None); + "tar", ["-xpf"; "-"; "--verbose"] + end in + let config = Config.v + ~cwd:(if Sys.unix then "/" else "C:/") + ~argv + ~hostname + ~user:Obuilder_spec.root + ~env:[] + ~mount_secrets:[] + ~mounts:(if Sys.win32 then [Docker.obuilder_libexec_volume ()] else []) + ~network:[] + ~entrypoint + () + in + Lwt_result.bind_lwt + (run ~cancelled ~stdin ~log t config id) + (fun () -> teardown ~log ~commit:true id) + +let copy_from_context t ~cancelled ~log op ~user ~src_dir ?dst_dir id = + (* If the sending thread finishes (or fails), close the writing end + of the pipe immediately so that the untar process finishes too. *) + Os.with_pipe_to_child @@ fun ~r:from_us ~w:to_untar -> + let proc = untar t ~cancelled ~stdin:from_us ~log ?dst_dir id in + let send = + Lwt.finalize + (fun () -> + 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 + ) + (fun () -> Lwt_unix.close to_untar) in + let* result = proc in + let+ () = send in + result + +let copy_from_build t ~cancelled ~log op ~user ~workdir ?dst_dir ~from_id id = + (* If a sending thread finishes (or fails), close the writing end of + the pipes immediately so that the receiving processes may finish + too. *) + Lwt_switch.with_switch @@ fun switch -> + let kill () = Lwt_switch.turn_off switch in + let kill_exn exn = let+ () = kill () in raise exn in + let tarball ~tar () = + Os.with_pipe_to_child @@ fun ~r:files_from ~w:files_from_out -> + let proc = tarball_from_build ~log t ~files_from ~tar workdir user from_id in + let f () = Os.ensure_closed_lwt files_from_out in + let send = Lwt.try_bind (fun () -> + let* () = manifest_files_from op files_from_out in + f ()) + f kill_exn in + let* () = Lwt_switch.add_hook_or_exec (Some switch) f in + let* result = proc in + let+ () = send in + result + in + let transform ~to_untar () = + Os.with_pipe_from_child @@ fun ~r:from_tar ~w:tar -> + let f () = Os.ensure_closed_lwt from_tar in + let proc = + let* () = transform op ~user ~from_tar ~to_untar in + f () + in + let send = Lwt.try_bind (tarball ~tar) f kill_exn in + let* () = Lwt_switch.add_hook_or_exec (Some switch) f in + let* result = proc in + let+ () = send in + result + in + Os.with_pipe_to_child @@ fun ~r:from_us ~w:to_untar -> + let proc = untar t ~cancelled ~stdin:from_us ~log ?dst_dir id in + let f () = Os.ensure_closed_lwt to_untar in + let send = Lwt.try_bind (transform ~to_untar) f kill_exn in + let* () = Lwt_switch.add_hook_or_exec (Some switch) f in + let* result = proc in + let+ () = send in + result + +(* The container must be based on the same version as the host. *) +let servercore = + let img = ref None in + fun () -> + match !img with + | None -> + let keyname = {|HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion|} in + let valuename = "DisplayVersion" in + let* value = Os.pread ["reg"; "query"; keyname; "/v"; valuename] in + let line = String.(value |> trim |> split_on_char '\n') |> Fun.flip List.nth 1 in + Scanf.sscanf line " DisplayVersion REG_SZ %s" @@ fun version -> + let version' = match version with + (* FIXME: is this accurate? *) + | "22H2" | "21H2" | "21H1" -> "ltsc2022" | "2019" -> "ltsc2019" | "2016" -> "ltsc2016" + | v -> v + in + let img' = "mcr.microsoft.com/windows/servercore:" ^ version' in + Log.info (fun f -> f "Windows host is %s, will use %s." version img'); + img := Some (Lwt.return (`Docker_image img')); + Option.get !img + | Some img -> img + +(* 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 (t:t) = + Log.info (fun f -> f "Preparing tar volume…"); + let name = Docker.obuilder_libexec () in + let vol = `Docker_volume name and img = `Docker_image name in + let* _ = Docker.Cmd.volume (`Create vol) in + + let* (`Docker_image base) = if Sys.win32 then servercore () else Lwt.return (`Docker_image "busybox") in + + let* config = + if Sys.win32 then + let destination = Docker.(mount_point_inside_native // obuilder_libexec ()) in + let dockerfile = + "# escape=`\n" ^ (strf "FROM %s\n" base) ^ {| + ENV CYGWIN="winsymlinks:native" + ADD [ "https://www.cygwin.com/setup-x86_64.exe", "C:\\cygwin-setup-x86_64.exe" ] + RUN mkdir C:\cygwin64\lib\cygsympathy && mkdir C:\cygwin64\etc\postinstall + ADD [ "https://raw.githubusercontent.com/metastack/cygsympathy/master/cygsympathy.cmd", "C:\\cygwin64\\lib\\cygsympathy\\" ] + ADD [ "https://raw.githubusercontent.com/metastack/cygsympathy/master/cygsympathy.sh", "C:\\cygwin64\\lib\\cygsympathy\\cygsympathy" ] + RUN mklink C:\cygwin64\etc\postinstall\zp_zcygsympathy.sh C:\cygwin64\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 C:\cygwin64 ` + --site http://mirrors.kernel.org/sourceware/cygwin/ ` + --packages tar + COPY [ "extract.cmd", "C:/extract.cmd" ] + COPY [ "manifest.bash", "C:/manifest.bash" ] + |} in + + let+ () = Lwt_io.with_temp_dir ~perm:0o700 @@ fun temp_dir -> + let write_file dst ?(perm=0o400) contents = + Lwt_io.(with_file ~perm ~mode:Output (temp_dir / dst)) @@ fun ch -> + Lwt_io.fprint ch contents in + let* () = write_file "Dockerfile" dockerfile in + let* () = write_file "extract.cmd" ~perm:0o500 (Option.get (Static_files.read "extract.cmd")) in + let* () = write_file "manifest.bash" ~perm:0o500 (Option.get (Static_files.read "manifest.bash")) in + let docker_argv = [ + "--isolation"; List.assoc t.docker_isolation isolations; + "--network"; t.docker_network; + ] in + Docker.Cmd.build docker_argv img temp_dir + in + + let entrypoint, argv = {|C:\Windows\System32\cmd.exe|}, ["/S"; "/C"; {|C:\extract.cmd|}] in + Config.v ~cwd:{|C:/|} ~argv ~hostname:"" + ~user:Obuilder_spec.((root_windows :> user)) + ~env:["DESTINATION", destination] + ~mount_secrets:[] + ~mounts:[Docker.obuilder_libexec_volume ~readonly:false ()] + ~network:[] + ~entrypoint + () + + else + let destination = Docker.(mount_point_inside_native / obuilder_libexec ()) in + let dockerfile = strf "FROM %s\n" base ^ strf {|COPY [ "manifest.bash", "%s/manifest.bash" ]|} destination in + let+ () = Lwt_io.with_temp_dir ~perm:0o700 @@ fun temp_dir -> + let write_file dst ?(perm=0o400) contents = + Lwt_io.(with_file ~perm ~mode:Output (temp_dir / dst)) @@ fun ch -> + Lwt_io.fprint ch contents in + let* () = write_file "Dockerfile" dockerfile in + let* () = write_file "manifest.bash" ~perm:0o500 (Option.get (Static_files.read "manifest.bash")) in + let docker_argv = [ + "--isolation"; List.assoc t.docker_isolation isolations; + "--network"; t.docker_network; + ] in + Docker.Cmd.build docker_argv img temp_dir + in + + let entrypoint, argv = "/bin/sh", ["-c"; ":"] in + Config.v ~cwd:"/" ~argv ~hostname:"" + ~user:Obuilder_spec.((root_unix :> user)) + ~env:["DESTINATION", destination] + ~mount_secrets:[] + ~mounts:[Docker.obuilder_libexec_volume ~readonly:false ()] + ~network:[] + ~entrypoint + () + in + let docker_args, args = Docker_config.make config t in + let* () = Docker.Cmd.run ~rm:true docker_args img args in + Docker.Cmd.image (`Remove img) + +let create (c : config) = + let t = { docker_cpus = c.cpus; docker_isolation = c.isolation; + docker_memory = c.memory; docker_network = c.network; } in + let* volume_exists = Docker.Cmd.exists (`Docker_volume (Docker.obuilder_libexec ())) in + let+ () = if Result.is_error volume_exists then create_tar_volume t else Lwt.return_unit in + t + +open Cmdliner + +let docs = "DOCKER BACKEND" + +let cpus = + Arg.value @@ + Arg.opt Arg.float 2.0 @@ + Arg.info ~docs + ~doc:"Number of CPUs to be used by Docker." + ~docv:"CPUS" + ["docker-cpus"] + +let isolation = + let isolations = List.rev_map (fun (k, v) -> v, k) isolations in + let doc = Arg.doc_alts_enum isolations |> strf + "Docker isolation, must be %s. Only $(b,default) is available on \ + Linux, only $(b,process) and $(b,hyperv) are available on Windows." in + Arg.value @@ + Arg.opt (Arg.enum isolations) (if Sys.win32 then `HyperV else `Default) @@ + Arg.info ~doc ~docs + ~docv:"ISOLATION" + ["docker-isolation"] + +let memory = + Arg.value @@ + Arg.opt Arg.(some string) None @@ + Arg.info ~docs + ~doc:"The maximum amount of memory the container can use. A positive \ + integer, followed by a suffix of b, k, m, g, to indicate bytes, \ + kilobytes, megabytes, or gigabytes." + ~docv:"MEMORY" + ["docker-memory"] + +let network = + Arg.value @@ + Arg.opt Arg.string (if Sys.unix then "host" else "nat") @@ + Arg.info ~docs + ~doc:"Docker network used for the Docker backend setup." + ~docv:"NETWORK" + ["docker-network"] + +let cmdliner : config Term.t = + let make cpus isolation memory network = + { cpus; isolation; memory; network; } + in + Term.(const make $ cpus $ isolation $ memory $ network) diff --git a/lib/docker_sandbox.mli b/lib/docker_sandbox.mli new file mode 100644 index 00000000..2dc51ce8 --- /dev/null +++ b/lib/docker_sandbox.mli @@ -0,0 +1,61 @@ +(** Sandbox builds using Docker. *) + +include S.SANDBOX + +val teardown : log:Build_log.t -> commit:bool -> S.id -> unit Lwt.t + +val manifest_from_build : + t -> + base:S.id -> + exclude:string list -> string list -> string -> Obuilder_spec.user -> + (Manifest.t list, [> `Msg of string ]) Lwt_result.t + +val copy_from_context : + t -> + cancelled:unit Lwt.t -> + log:Build_log.t -> + [< `Copy_item of Manifest.t * string + | `Copy_items of Manifest.t list * string ] -> + user:Obuilder_spec.user -> + src_dir:string -> + ?dst_dir:string -> + string -> (unit, [ `Cancelled | `Msg of string ]) result Lwt.t + +val copy_from_build : + t -> + cancelled:'a Lwt.t -> + log:Build_log.t -> + [< `Copy_item of Manifest.t * string + | `Copy_items of Manifest.t list * string ] -> + user:Obuilder_spec.user -> + workdir:string -> + ?dst_dir:string -> + from_id:S.id -> + S.id -> + (unit, [ `Cancelled | `Msg of string ]) result Lwt.t + +val servercore : unit -> ([ `Docker_image of string ]) Lwt.t +(** Get the Windows ServerCore image based on the same version as the + host. *) + +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 : config -> t Lwt.t +(** [create config] is a Docker sandboxing system that is configured + using [config]. *) diff --git a/lib/docker_store.ml b/lib/docker_store.ml new file mode 100644 index 00000000..1160320e --- /dev/null +++ b/lib/docker_store.ml @@ -0,0 +1,216 @@ +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 `state`, etc). *) + caches : (string, cache) Hashtbl.t; + mutable next : int; (* Used to generate unique temporary IDs. *) +} + +let ( / ) = Filename.concat +let strf = Printf.sprintf + +module Path = struct + (* A Docker store contains several subdirectories: + + - state: for sqlite DB, etc + - log_file: for logs *) + + let empty t = t.root / "empty" + let state t = t.root / "state" + let log_file t id = t.root / "logs" / (id ^ ".log") +end + +(* 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 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 cache name = Docker.docker_volume_cache (Escape.cache name) + let cache_tmp i name = Docker.docker_volume_cache ~tmp:true (strf "%d-%s" i (Escape.cache name)) + + let name (`Docker_volume name) = name + + let exists volume = + let+ r = Docker.Cmd.exists volume in + Result.is_ok r + + let create volume = + let* id = Docker.Cmd.volume ~timeout:5.0 (`Create volume) in + Log.debug (fun f -> f "Volume id: %s" (String.trim id)); + Lwt.return_unit + + let snapshot ~src dst = + Log.debug (fun f -> f "Snapshotting volume %s to %s" (match src with `Docker_volume src -> src) (match dst with `Docker_volume dst -> dst)); + let* () = create dst in + let* base = if Sys.win32 then Docker_sandbox.servercore () else Lwt.return (`Docker_image "busybox") in + let* r = Docker.cp_between_volumes ~base ~src ~dst in + Log.debug (fun f -> f "Finished snapshotting"); + match r with Ok () -> Lwt.return_unit | Error (`Msg msg) -> failwith msg + + let delete volume = + let* _ = Docker.Cmd.volume (`Remove [volume]) in + Lwt.return_unit +end + +let root t = t.root + +let purge () = + let* containers = Docker.Cmd.obuilder_containers () in + let* () = if containers <> [] then Docker.Cmd.rm containers else Lwt.return_unit in + Log.info (fun f -> f "Removing left-over Docker images"); + let* images = Docker.Cmd.obuilder_images ~tmp:true () in + let* () = if images <> [] then Docker.Cmd.rmi images else Lwt.return_unit in + Log.info (fun f -> f "Removing left-over Docker volumes"); + let* volumes = Docker.Cmd.obuilder_caches_tmp () in + let* _ = if volumes <> [] then Docker.Cmd.volume (`Remove volumes) else Lwt.return "" in + Lwt.return_unit + +let create root = + Os.ensure_dir root; + let hash = Unix.realpath root |> Sha256.string |> Sha256.to_hex in + let hash = String.sub hash 0 7 in + Docker.set_prefix (strf "obuilder-%s" hash); + let t = { root; caches = Hashtbl.create 10; next = 0 } in + Os.ensure_dir ~mode:0o0 (root / "empty"); + Os.ensure_dir (root / "state"); + Os.ensure_dir (root / "logs"); + let* () = purge () in + Lwt.return t + +let build t ?base ~id (fn:(string -> (unit, 'e) Lwt_result.t)) : (unit, 'e) Lwt_result.t = + match base with + | None -> + Lwt.catch + (fun () -> fn (Path.empty t)) + (fun exn -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn exn); + Lwt.fail exn) + | Some base -> + let base = Docker.docker_image base in + let tmp_image = (Docker.docker_image ~tmp:true id) in + let* () = Docker.Cmd.tag base tmp_image in + Lwt.try_bind + (fun () -> fn (Path.empty t)) + (fun r -> + (* 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 cache. *) + let+ () = Docker.Cmd.image (`Remove tmp_image) in + r) + (fun exn -> + Log.warn (fun f -> f "Uncaught exception from %S build function: %a" id Fmt.exn exn); + let* () = Docker.Cmd.image (`Remove tmp_image) in + Lwt.fail exn) + +let delete t id = + let image = Docker.docker_image id in + let* exists = Docker.Cmd.exists image in + let* () = match exists with + | Ok () -> Docker.Cmd.image (`Remove image) + | Error _ -> Lwt.return_unit + in + let log_file = Path.log_file t id in + if Sys.file_exists log_file then + Lwt_unix.unlink log_file + else Lwt.return_unit + +let result t id = + let img = Docker.docker_image id in + let* r = Docker.Cmd.exists img in + match r with + | Ok () -> Lwt.return_some (Path.empty t) + | Error _ -> + Lwt.return_none + +let log_file t id = Lwt.return (Path.log_file t id) + +let state_dir = Path.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 = + 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+ () = match user with + | `Unix { Obuilder_spec.uid; gid } -> + let* tmp = Docker.Cmd.mount_point tmp in + Os.sudo ["chown"; strf "%d:%d" uid gid; tmp] + | `Windows _ -> Lwt.return_unit (* FIXME: does Windows need special treatment? *) + 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 + 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* containers = Docker.Cmd.volume_containers snapshot in + if containers <> [] then + let* () = Cache.delete snapshot in + Lwt_result.ok Lwt.return_unit + else + Lwt_result.fail `Busy + else Lwt_result.ok Lwt.return_unit + +let complete_deletes t = + ignore t; + (* FIXME: 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 cc858f90..a38efaec 100644 --- a/lib/dune +++ b/lib/dune @@ -10,9 +10,16 @@ (enabled_if (<> %{system} macosx)) (action (copy %{deps} %{target}))) +(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) (preprocess (pps ppx_sexp_conv)) (flags (:standard -w -69)) - (libraries lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner)) + (libraries fpath lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner)) 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..02a1a70a 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 778bd076..ed3c9ea1 100644 --- a/lib/obuilder.ml +++ b/lib/obuilder.ml @@ -5,6 +5,7 @@ let log_src = Log.src module S = S module Spec = Obuilder_spec module Context = Build.Context +module Docker = Docker (** {2 Stores} *) @@ -12,20 +13,23 @@ module Btrfs_store = Btrfs_store module Zfs_store = Zfs_store module Rsync_store = Rsync_store module Store_spec = Store_spec +module Docker_store = Docker_store (** {2 Fetchers} *) -module Docker = Docker module User_temp = User_temp +module Docker_extract = Docker.Extract (** {2 Sandboxes} *) module Config = Config -module Sandbox = Sandbox +module Native_sandbox = 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.Make_Docker module Build_log = Build_log (**/**) diff --git a/lib/os.ml b/lib/os.ml index 1758794a..a7ed44ec 100644 --- a/lib/os.ml +++ b/lib/os.ml @@ -5,6 +5,16 @@ let ( >>!= ) = Lwt_result.bind type unix_fd = { raw : Unix.file_descr; mutable needs_close : bool; + } + +let stdout = { + raw = Unix.stdout; + needs_close = false; + } + +let stderr = { + raw = Unix.stderr; + needs_close = false; } let close fd = @@ -13,7 +23,8 @@ let close fd = fd.needs_close <- false let ensure_closed_unix fd = - if fd.needs_close then close fd + if fd.needs_close then + close fd let ensure_closed_lwt fd = if Lwt_unix.state fd = Lwt_unix.Closed then Lwt.return_unit @@ -40,12 +51,12 @@ let close_redirection (x : [`FD_move_safely of unix_fd | `Dev_null]) = (* stdin, stdout and stderr are copied to the child and then closed on the host. They are closed at most once, so duplicates are OK. *) -let default_exec ?cwd ?stdin ?stdout ?stderr ~pp argv = +let default_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp argv = let proc = let stdin = Option.map redirection stdin in let stdout = Option.map redirection stdout in let stderr = Option.map redirection stderr in - try Lwt_result.ok (Lwt_process.exec ?cwd ?stdin ?stdout ?stderr argv) + try Lwt_result.ok (Lwt_process.exec ?timeout ?cwd ?stdin ?stdout ?stderr argv) with e -> Lwt_result.fail e in Option.iter close_redirection stdin; @@ -95,10 +106,10 @@ let exec_result ?cwd ?stdin ?stdout ?stderr ~pp ?(is_success=((=) 0)) ?(cmd="") | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string]) -let exec ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") argv = +let exec ?timeout ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") argv = Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv)); let pp f = pp_cmd f (cmd, argv) in - !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function + !lwt_process_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function | Ok n when is_success n -> Lwt.return_unit | Ok n -> Lwt.fail_with (Fmt.str "%t failed with exit status %d" pp n) | Error (`Msg m) -> Lwt.fail (Failure m) @@ -121,6 +132,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 = let flags = [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK; Unix.O_CLOEXEC] in Lwt_io.(with_file ~mode:output ~flags) path @@ fun ch -> @@ -158,16 +177,41 @@ let with_pipe_between_children fn = Lwt.return_unit ) -let pread ?stderr argv = +let pread ?timeout ?stderr argv = + with_pipe_from_child @@ fun ~r ~w -> + let child = exec ?timeout ~stdout:(`FD_move_safely w) ?stderr 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 () -> data + +let pread_result ?cwd ?stdin ?stderr ~pp ?is_success ?cmd argv = with_pipe_from_child @@ fun ~r ~w -> - let child = exec ~stdout:(`FD_move_safely w) ?stderr argv in + let child = exec_result ?cwd ?stdin ~stdout:(`FD_move_safely w) ?stderr ~pp ?is_success ?cmd 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 () -> - Lwt.return data + >>= fun data -> child >|= fun r -> Result.map (fun () -> data) r + +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 (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 @@ -175,10 +219,10 @@ let check_dir x = | _ -> Fmt.failwith "Exists, but is not a directory: %S" x | exception Unix.Unix_error(Unix.ENOENT, _, _) -> `Missing -let ensure_dir path = +let ensure_dir ?(mode=0o777) path = match check_dir path with | `Present -> () - | `Missing -> Unix.mkdir path 0o777 + | `Missing -> Unix.mkdir path mode let rm ~directory = let pp _ ppf = Fmt.pf ppf "[ RM ]" in @@ -188,3 +232,51 @@ let rm ~directory = | Error (`Msg m) -> Log.warn (fun f -> f "Failed to remove %s because %s" directory m); Lwt.return_unit + +(** 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/s.ml b/lib/s.ml index 7dbc3213..a1f53daf 100644 --- a/lib/s.ml +++ b/lib/s.ml @@ -80,7 +80,7 @@ module type SANDBOX = sig string -> (unit, [`Cancelled | `Msg of string]) Lwt_result.t (** [run ~cancelled t config dir] runs the operation [config] in a sandbox with root - filesystem [rootfs]. + filesystem [dir]. @param cancelled Resolving this kills the process (and returns [`Cancelled]). @param stdin Passed to child as its standard input. @param log Used for child's stdout and stderr. @@ -128,3 +128,133 @@ module type FETCHER = sig @param log Used for outputting the progress of the fetch @param rootfs The directory in which to extract the base image *) end + +(** Wrappers for various Docker client commands. *) +module type DOCKER_CMD = sig + type 'a log + (** Log standard output and standard error of the sub-process. *) + + type 'a logerr + (** Log only standard error of the sub-process. *) + + val version : (unit -> (string, [> `Msg of string ]) result Lwt.t) logerr + + val pull : + ([< `Docker_image of string ] -> unit Lwt.t) log + (** Pulls a Docker image. *) + val export : + ([< `Docker_container of string ] -> unit Lwt.t) log + (** Exports a Docker container. *) + val image : + ([< `Remove of [< `Docker_image of string ] ] -> unit Lwt.t) log + (** Operates on a Docker image. *) + val rm : + ([ `Docker_container of string ] list -> unit Lwt.t) log + (** Removes a Docker container. *) + val rmi : + ([ `Docker_image of string ] list -> unit Lwt.t) log + (** Removes a list of Docker images. *) + val tag : + ([< `Docker_image of string ] -> + [< `Docker_image of string ] -> unit Lwt.t) log + (** [tag source_image target_image] creates a new tag for a Docker iamge. *) + val commit : + ([< `Docker_image of string ] -> + [< `Docker_container of string ] -> + [< `Docker_image of string ] -> unit Lwt.t) log + (** [commit base_image container target_image] commits the + [container] to the [target_image] using [base_image] (typically + the container's base image) entrypoint and cmd. *) + val volume : + (?timeout:float -> + [< `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) logerr + (** Operates on Docker volumes. *) + val volume_containers : + ([< `Docker_volume of string ] -> [> `Docker_container of string ] list Lwt.t) logerr + (** [volume_containers vol] returns the list of containers using [vol]. *) + val mount_point : + ([< `Docker_volume of string ] -> string Lwt.t) logerr + (** [mount_point vol] returns the mount point in the host filesystem of [vol]. *) + val build : + (string list -> [< `Docker_image of string ] -> string -> unit Lwt.t) log + (** [build docker_args image context_path] builds the Docker [image] + using the context located in [context_path]. *) + + val run : + ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + (?is_success:(int -> bool) -> + ?name:[< `Docker_container of string ] -> + ?rm:bool -> + string list -> [< `Docker_image of string ] -> string list -> unit Lwt.t) log + (** [run ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) + val run' : + ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?stdout:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + (?is_success:(int -> bool) -> + ?name:[< `Docker_container of string ] -> + ?rm:bool -> + string list -> [< `Docker_image of string ] -> string list -> unit Lwt.t) logerr + (** [run' ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) + val run_result : + ?stdin:[ `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, [> `Msg of string ]) result Lwt.t) log + (** [run_result ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) + val run_result' : + ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + ?stdout:[ `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, [> `Msg of string ]) result Lwt.t) logerr + (** [run_result ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) + val run_pread_result : + ?stdin:[ `Dev_null | `FD_move_safely of Os.unix_fd ] -> + (?name:[< `Docker_container of string ] -> + ?rm:bool -> + string list -> + [< `Docker_image of string ] -> + string list -> (string, [> `Msg of string ]) result Lwt.t) logerr + (** [run_pread_result ?stdin ?stdout ?stderr ?is_success ?name ?rm docker_argv image argv] *) + + val stop : + ([< `Docker_container of string ] -> + (unit, [> `Msg of string ]) result Lwt.t) log + (** Stop a Docker container. *) + + val manifest : + ([< `Create of + [< `Docker_image of string ] * [< `Docker_image of string ] list + | `Inspect of [< `Docker_image of string ] + | `Remove of [< `Docker_image of string ] list ] -> + (unit, [> `Msg of string ]) result Lwt.t) log + (** Operates on a Docker manifest. *) + + val exists : + ([< `Docker_container of string + | `Docker_image of string + | `Docker_volume of string ] -> + (unit, [> `Msg of string ]) result Lwt.t) log + (** Tests if an object exists. *) + + val obuilder_images : + (?tmp:bool -> unit -> [ `Docker_image of string ] list Lwt.t) logerr + (** Returns the list of this OBuilder instance images. *) + val obuilder_containers : + (unit -> [ `Docker_container of string ] list Lwt.t) logerr + (** Returns the list of this OBuilder instance containers. *) + val obuilder_volumes : + (?prefix:string -> unit -> [ `Docker_volume of string ] list Lwt.t) logerr + (** Returns the list of this OBuilder instance volumes. *) + val obuilder_caches_tmp : + (unit -> [ `Docker_volume of string ] list Lwt.t) logerr + (** Returns the list of this OBuilder instance temporary caches. *) +end diff --git a/lib/sandbox.runc.ml b/lib/sandbox.runc.ml index 00b1623f..f8743531 100644 --- a/lib/sandbox.runc.ml +++ b/lib/sandbox.runc.ml @@ -42,7 +42,8 @@ module Json_config = struct ] let user_mounts = - List.map @@ fun { Config.Mount.src; dst; readonly } -> + List.map @@ fun { Config.Mount.ty; src; dst; readonly } -> + assert (ty = `Bind); let options = [ "bind"; "nosuid"; "nodev"; ] in mount ~ty:"bind" ~src dst ~options:(if readonly then "ro" :: options else options) @@ -334,10 +335,12 @@ let create ~state_dir (c : config) = open Cmdliner +let docs = "RUNC SANDBOX" + let fast_sync = Arg.value @@ Arg.flag @@ - Arg.info + Arg.info ~docs ~doc:"Ignore sync syscalls (requires runc >= 1.0.0-rc92)." ["fast-sync"] diff --git a/lib/store_spec.ml b/lib/store_spec.ml index fa06da86..7d251f7d 100644 --- a/lib/store_spec.ml +++ b/lib/store_spec.ml @@ -6,6 +6,7 @@ type t = [ | `Btrfs of string (* Path *) | `Zfs of string (* Path with pool at end *) | `Rsync of (string * Rsync_store.mode) (* Path for the root of the store *) + | `Docker of string (* Path *) ] let is_absolute path = not (Filename.is_relative path) @@ -15,25 +16,30 @@ let of_string s = | Some ("zfs", pool) -> Ok (`Zfs pool) | Some ("btrfs", path) when is_absolute path -> Ok (`Btrfs path) | Some ("rsync", path) when is_absolute path -> Ok (`Rsync path) + | Some ("docker", path) -> Ok (`Docker path) | _ -> Error (`Msg "Store must start with zfs: or btrfs:/ or rsync:/") let pp f = function | `Zfs path -> Fmt.pf f "zfs:%s" path | `Btrfs path -> Fmt.pf f "btrfs:%s" path | `Rsync path -> Fmt.pf f "rsync:%s" path + | `Docker path -> Fmt.pf f "docker:%s" path type store = Store : (module S.STORE with type t = 'a) * 'a -> store let to_store = function | `Btrfs path -> - Btrfs_store.create path >|= fun store -> + `Native, Btrfs_store.create path >|= fun store -> Store ((module Btrfs_store), store) | `Zfs path -> - Zfs_store.create ~path >|= fun store -> + `Native, Zfs_store.create ~path >|= fun store -> Store ((module Zfs_store), store) | `Rsync (path, rsync_mode) -> - Rsync_store.create ~path ~mode:rsync_mode () >|= fun store -> + `Native, Rsync_store.create ~path ~mode:rsync_mode () >|= fun store -> Store ((module Rsync_store), store) + | `Docker path -> + `Docker, Docker_store.create path >|= fun store -> + Store ((module Docker_store), store) open Cmdliner @@ -42,7 +48,7 @@ let store_t = Arg.conv (of_string, pp) let store ?docs names = Arg.opt Arg.(some store_t) None @@ Arg.info - ~doc:"$(docv) must be one of $(b,btrfs:/path), $(b,rsync:/path) or $(b,zfs:pool) for the OBuilder cache." + ~doc:"$(docv) must be one of $(b,btrfs:/path), $(b,rsync:/path), $(b,zfs:pool) or $(b,docker:path) for the OBuilder cache." ~docv:"STORE" ?docs names @@ -74,7 +80,8 @@ let of_t store rsync_mode = | Some (`Rsync _path), None -> failwith "Store rsync:/ must supply an rsync-mode" | Some (`Btrfs path), None -> (`Btrfs path) | Some (`Zfs path), None -> (`Zfs path) - | _, _ -> failwith "Store type required must be one of $(b,btrfs:/path), $(b,rsync:/path) or $(b,zfs:pool) for the OBuilder cache." + | Some (`Docker path), None -> (`Docker path) + | _, _ -> failwith "Store type required must be one of btrfs:/path, rsync:/path, zfs:pool or docker:path for the OBuilder cache." (** Parse cli arguments for t *) let v = diff --git a/lib/tar_transfer.ml b/lib/tar_transfer.ml index 1fb27556..c16cbeb3 100644 --- a/lib/tar_transfer.ml +++ b/lib/tar_transfer.ml @@ -91,7 +91,7 @@ let copy_symlink ~src ~target ~dst ~to_untar ~user = 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); + 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, uname, gname = get_ids user in @@ -140,3 +140,79 @@ 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 = + (* Make a copy to erase unneeded data from the tar headers. *) + let hdr' = Tar.Header.(make ~file_mode:hdr.file_mode ~mod_time:hdr.mod_time hdr.file_name hdr.file_size) in + let hdr' = match user with + | `Unix user -> + { hdr' with Tar.Header.user_id = user.Obuilder_spec.uid; group_id = user.gid; } + | `Windows user when user.Obuilder_spec.name = "ContainerAdministrator" -> + (* https://cygwin.com/cygwin-ug-net/ntsec.html#ntsec-mapping *) + let id = let x = 93 and rid = 1 in 0x1000 * x + rid in + { hdr' with user_id = id; group_id = id; uname = user.name; gname = user.name; } + | `Windows _ -> 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; + link_indicator = hdr.link_indicator; + link_name = hdr.link_name; } + | Directory -> + { hdr' with + file_mode = 0o755; + file_name = fname hdr.file_name ^ "/"; } + | _ -> Fmt.invalid_arg "Unsupported file type" + +let rec map_transform ~dst transformations = function + | `File (src, _) -> + let dst = dst / Filename.basename src in + Hashtbl.add transformations src dst + | `Symlink (src, _) -> + let dst = dst / Filename.basename src in + Hashtbl.add transformations src dst + | `Dir (src, items) -> + let dst = dst / Filename.basename src in + Hashtbl.add transformations src dst; + Log.debug(fun f -> f "Copy dir %S -> %S" src dst); + List.iter (map_transform ~dst transformations) items + +and transform_files ~from_tar ~src_manifest ~dst_dir ~user ~to_untar = + let dst = remove_leading_slashes dst_dir in + let transformations = Hashtbl.create ~random:true 64 in + List.iter (map_transform ~dst transformations) src_manifest; + let fname file_name = + match Hashtbl.find transformations file_name with + | exception Not_found -> Fmt.failwith "Could not find mapping for %s" file_name + | file_name -> file_name + in + Tar_lwt_unix.Archive.transform ~level (transform ~user fname) from_tar to_untar + +let transform_file ~from_tar ~src_manifest ~dst ~user ~to_untar = + let dst = remove_leading_slashes dst in + let transformations = Hashtbl.create ~random:true 1 in + let map_transform = function + | `File (src, _) -> Hashtbl.add transformations src dst + | `Symlink (src, _) -> Hashtbl.add transformations src dst + | `Dir (src, items) -> + Hashtbl.add transformations src dst; + Log.debug(fun f -> f "Copy dir %S -> %S" src dst); + List.iter (map_transform ~dst transformations) items + in + map_transform src_manifest; + let fname file_name = + match Hashtbl.find transformations file_name with + | exception Not_found -> Fmt.failwith "Could not find mapping for %s" file_name + | file_name -> file_name + in + Tar_lwt_unix.Archive.transform ~level (fun hdr -> + let hdr' = transform ~user fname hdr in + Log.debug (fun f -> f "Copying %s -> %s" hdr.Tar.Header.file_name hdr'.Tar.Header.file_name); + hdr') + from_tar to_untar diff --git a/lib/tar_transfer.mli b/lib/tar_transfer.mli index e71fe084..1cf59697 100644 --- a/lib/tar_transfer.mli +++ b/lib/tar_transfer.mli @@ -21,3 +21,27 @@ 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/main.ml b/main.ml index c615bb6b..183dc023 100644 --- a/main.ml +++ b/main.ml @@ -2,8 +2,10 @@ open Lwt.Infix let ( / ) = Filename.concat -module Sandbox = Obuilder.Sandbox -module Fetcher = Obuilder.Docker +module Native_sandbox = Obuilder.Native_sandbox +module Docker_sandbox = Obuilder.Docker_sandbox +module Docker_store = Obuilder.Docker_store +module Docker_extract = Obuilder.Docker_extract module Store_spec = Obuilder.Store_spec type builder = Builder : (module Obuilder.BUILDER with type t = 'a) * 'a -> builder @@ -14,10 +16,17 @@ let log tag msg = | `Note -> Fmt.pr "%a@." Fmt.(styled (`Fg `Yellow) string) msg | `Output -> output_string stdout msg; flush stdout -let create_builder spec conf = - spec >>= fun (Store_spec.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 create_builder store_spec conf = + store_spec >>= fun (Store_spec.Store ((module Store), store)) -> + let module Builder = Obuilder.Builder (Store) (Native_sandbox) (Docker_extract) in + Native_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 store_spec conf = + store_spec >>= fun (Store_spec.Store ((module Store), store)) -> + let module Builder = Obuilder.Docker_builder (Store) in + Docker_sandbox.create conf >|= fun sandbox -> let builder = Builder.v ~store ~sandbox in Builder ((module Builder), builder) @@ -27,9 +36,15 @@ let read_whole_file path = let len = in_channel_length ic in really_input_string ic len -let build () store spec conf src_dir secrets = +let select_backend (sandbox, store_spec) native_conf docker_conf = + match sandbox with + | `Native -> create_builder store_spec native_conf + | `Docker -> create_docker_builder store_spec docker_conf + +let build () store spec native_conf docker_conf src_dir secrets = Lwt_main.run begin - create_builder store conf >>= fun (Builder ((module Builder), builder)) -> + select_backend store native_conf docker_conf + >>= fun (Builder ((module Builder), builder)) -> Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> let spec = try Obuilder.Spec.t_of_sexp (Sexplib.Sexp.load_sexp spec) @@ -51,9 +66,10 @@ let build () store spec conf src_dir secrets = exit 1 end -let healthcheck () store conf = +let healthcheck () store native_conf docker_conf = Lwt_main.run begin - create_builder store conf >>= fun (Builder ((module Builder), builder)) -> + select_backend store native_conf docker_conf + >>= fun (Builder ((module Builder), builder)) -> Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> Builder.healthcheck builder >|= function | Error (`Msg m) -> @@ -63,16 +79,18 @@ let healthcheck () store conf = Fmt.pr "Healthcheck passed@." end -let delete () store conf id = +let delete () store native_conf docker_conf id = Lwt_main.run begin - create_builder store conf >>= fun (Builder ((module Builder), builder)) -> + select_backend store native_conf docker_conf + >>= fun (Builder ((module Builder), builder)) -> Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> Builder.delete builder id ~log:(fun id -> Fmt.pr "Removing %s@." id) end -let clean () store conf = +let clean () store native_conf docker_conf = Lwt_main.run begin - create_builder store conf >>= fun (Builder ((module Builder), builder)) -> + select_backend store native_conf docker_conf + >>= fun (Builder ((module Builder), builder)) -> Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ begin fun () -> let now = Unix.(gmtime (gettimeofday ())) in Builder.prune builder ~before:now max_int ~log:(fun id -> Fmt.pr "Removing %s@." id) @@ -137,19 +155,22 @@ let build = let doc = "Build a spec file." in let info = Cmd.info "build" ~doc in Cmd.v info - Term.(const build $ setup_log $ store $ spec_file $ Obuilder.Sandbox.cmdliner $ src_dir $ secrets) + Term.(const build $ setup_log $ store $ spec_file $ Native_sandbox.cmdliner + $ Docker_sandbox.cmdliner $ src_dir $ secrets) let delete = let doc = "Recursively delete a cached build result." in let info = Cmd.info "delete" ~doc in Cmd.v info - Term.(const delete $ setup_log $ store $ Obuilder.Sandbox.cmdliner $ id) + Term.(const delete $ setup_log $ store $ Native_sandbox.cmdliner + $ Docker_sandbox.cmdliner $ id) let clean = let doc = "Clean all cached build results." in let info = Cmd.info "clean" ~doc in Cmd.v info - Term.(const clean $ setup_log $ store $ Obuilder.Sandbox.cmdliner) + Term.(const clean $ setup_log $ store $ Native_sandbox.cmdliner + $ Docker_sandbox.cmdliner) let buildkit = Arg.value @@ @@ -177,7 +198,8 @@ let healthcheck = let doc = "Perform a self-test" in let info = Cmd.info "healthcheck" ~doc in Cmd.v info - Term.(const healthcheck $ setup_log $ store $ Obuilder.Sandbox.cmdliner) + Term.(const healthcheck $ setup_log $ store $ Native_sandbox.cmdliner + $ Docker_sandbox.cmdliner) let cmds = [build; delete; clean; dockerfile; healthcheck] diff --git a/obuilder.opam b/obuilder.opam index 4045c4b2..7a6d8a8a 100644 --- a/obuilder.opam +++ b/obuilder.opam @@ -34,7 +34,9 @@ depends: [ "ppx_sexp_conv" "sha" {>= "1.15.4"} "sqlite3" + "crunch" {>= "3.3.1" & build} "obuilder-spec" {= version} + "fpath" "ocaml" {>= "4.14.1"} "alcotest-lwt" {>= "1.7.0" & with-test} "odoc" {with-doc} diff --git a/static/extract.cmd b/static/extract.cmd new file mode 100644 index 00000000..e270cfdf --- /dev/null +++ b/static/extract.cmd @@ -0,0 +1,14 @@ +@echo off + +echo Copying to "%DESTINATION%" +copy /v /b C:\manifest.bash "%DESTINATION%" +copy /v /b C:\cygwin64\bin\basename.exe "%DESTINATION%" +copy /v /b C:\cygwin64\bin\bash.exe "%DESTINATION%" +copy /v /b C:\cygwin64\bin\cygpath.exe "%DESTINATION%" +copy /v /b C:\cygwin64\bin\readlink.exe "%DESTINATION%" +copy /v /b C:\cygwin64\bin\tar.exe "%DESTINATION%" +copy /v /b C:\cygwin64\bin\sha256sum.exe "%DESTINATION%" + +for /f "usebackq delims=" %%f in (`C:\cygwin64\bin\bash.exe -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 ( + copy /v /b "%%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 47a52602..95df2ff4 100644 --- a/stress/stress.ml +++ b/stress/stress.ml @@ -16,8 +16,6 @@ let assert_str expected got = exit 1 ) -module Fetcher = Docker - module Test(Store : S.STORE) = struct let assert_output expected t id = Store.result t id >>= function @@ -105,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)(Native_sandbox)(Obuilder.Docker_extract) in + Native_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 @@ -137,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 = @@ -149,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 @@ -157,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 @@ -196,20 +200,23 @@ 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 aux () end -let stress spec conf = +let stress (sandbox, spec) conf = + if sandbox = `Docker then begin + prerr_endline "Cannot stress-test the Docker backend"; + exit 1 + end; Lwt_main.run begin spec >>= fun (Store_spec.Store ((module Store), store)) -> let module T = Test(Store) in @@ -225,8 +232,7 @@ let cmd = let doc = "Run stress tests." in let info = Cmd.info ~doc "stress" in Cmd.v info - Term.(const stress $ Store_spec.cmdliner $ Sandbox.cmdliner) - + Term.(const stress $ Store_spec.cmdliner $ Native_sandbox.cmdliner) let () = (* Logs.(set_level (Some Info)); *) diff --git a/test/dune b/test/dune index 621f5f8f..c56d7242 100644 --- a/test/dune +++ b/test/dune @@ -1,3 +1,5 @@ +(copy_files ../static/manifest.bash) + (executable (name dummy) (public_name dummy) @@ -7,7 +9,7 @@ (test (name test) (package obuilder) - (deps base.tar %{bin:dummy}) + (deps base.tar manifest.bash %{bin:dummy}) (libraries alcotest-lwt obuilder str logs.fmt) (modules log mock_exec mock_sandbox mock_store test)) diff --git a/test/mock_exec.ml b/test/mock_exec.ml index c4bf17d3..4f2828a2 100644 --- a/test/mock_exec.ml +++ b/test/mock_exec.ml @@ -63,7 +63,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 @@ -80,7 +80,8 @@ let closing redir fn = Lwt.return_unit ) -let exec ?cwd ?stdin ?stdout ?stderr ~pp cmd = +let exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp cmd = + ignore timeout; closing stdin @@ fun () -> closing stdout @@ fun () -> closing stderr @@ fun () -> diff --git a/test/test.ml b/test/test.ml index 7ee635c8..443dc75a 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 @@ -703,8 +703,42 @@ let test_copy generate = (* Test the Manifest module. *) let test_copy_ocaml _switch () = + if Sys.win32 then + Alcotest.skip (); 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 () = + 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 (bash, 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 + with_default_exec (fun () -> test_copy generate) + let test_cache_id () = let check expected id = Alcotest.(check string) ("ID-" ^ id) expected (Escape.cache id) @@ -775,7 +809,16 @@ let () = in test_case name speed wrap in - let needs_docker = [ + let is_win32_gha = + match Sys.getenv "CI", Sys.getenv "GITHUB_ACTIONS", Sys.win32 with + | "true", "true", true -> true + | _ | exception _ -> false in + let needs_docker = + let test_case name speed f = + if is_win32_gha then test_case name speed (fun _ -> Alcotest.skip) + else test_case name speed f + in + [ "build", [ test_case "Simple" `Quick test_simple; test_case "Prune" `Quick test_prune; @@ -794,15 +837,7 @@ let () = test_case "No secret provided" `Quick test_secrets_not_provided; ]; ] in - let is_win32_gha = - match Sys.getenv "CI", Sys.getenv "GITHUB_ACTIONS", Sys.win32 with - | "true", "true", true -> true - | _ | exception _ -> false in Lwt_main.run begin - let manifest = - if not Sys.win32 then [test_case "Copy using Manifest" `Quick test_copy_ocaml] - else [] - in run "OBuilder" ([ "spec", [ test_case_sync "Sexp" `Quick test_sexp; @@ -813,10 +848,13 @@ let () = "tar_transfer", [ test_case "Long filename" `Quick test_tar_long_filename; ]; - "manifest", manifest; + "manifest", [ + test_case "Copy using manifest.bash" `Quick test_copy_bash; + test_case "Copy using Manifest" `Quick test_copy_ocaml + ]; "process", [ test_case "Execute a process" `Quick test_exec_nul; test_case "Read stdout of a process" `Quick test_pread_nul; ]; - ] @ (if not is_win32_gha then needs_docker else [])) + ] @ needs_docker) end diff --git a/windows.md b/windows.md new file mode 100644 index 00000000..56890428 --- /dev/null +++ b/windows.md @@ -0,0 +1,238 @@ +# OBuilder's Docker backend + +> OBuilder takes a build script (similar to a Dockerfile) and performs +> the steps in it in a sandboxed environment. + +> After each step, OBuilder uses the snapshot feature of the +> filesystem to store the state of the build. […] Repeating a build +> will reuse the cached results where possible. + +## Motivation + +Windows offers [native containers][windowscontainers] for sandboxing. +Finding a snapshotting filesystem might be more involved, there's +[Volume Shadow Copy Service (VSS)][VSS] and [WinBtrfs][]. There's +however no direct API for these services, they're not stable yet and +have few users, and composing them seems a temerary endeavour. + +The choice was made to use Docker as a sandboxing and storage solution +for OBuilder. Docker has considerably more users, and hides some of the +complexity of interfacing with the operating system. + +Docker being a portable system (with some caveats), the OBuilder +Docker backend can itself be run in theory over any system Docker +supports. Using native components, wherever available, should be +preferred. On Windows, Docker can run sunboxed applications using +either containerization or virtual machines (VM) with Hyper-V. On +macOS Docker currently works using virtual machines. +The virtualization layer makes it more costly to run code, compared to +containerization under Linux. Virtual machines provide more effective +isolation and stability under Windows, prompting OBuilder to default +to VMs. + +[windowscontainers]: https://learn.microsoft.com/en-us/virtualization/windowscontainers/about/ +[VSS]: https://learn.microsoft.com/en-us/windows-server/storage/file-server/volume-shadow-copy-service +[WinBtrfs]: https://github.com/maharmstone/btrfs + +## Comparing Docker and native backends + +The distinction between the sandboxing engine and the storage layer in +OBuilder doesn't exactly map to the Docker backend, as both sandbox +and store are provided by Docker and can't be swapped out for another +implementation. As such, OBuilder will now differentiate between a +_native_ sandboxing solution, such as [runc][] under Linux, coupled +with a storage engine, and the Docker backend, providing all-in-one +sandbox and storage. + +The underlying `Store` and `Sandbox` modules can't be as decoupled +either with the Docker backend, they need to share more information. +This distinction is however useful enough for modularity that it is +retained. + +The main difference resides in the fact that with the usual native +sandbox and storage solution, OBuilder is totally in charge: it +creates its own build identifiers, manages the filesystem, and spawns +containers. With the Docker backend however, Docker's the second +player of the game. Docker has its own view of the global state, +assigns its own identifiers to images and containers. Extra care must +be taken to ensure that OBuilder and Docker have a consistent view of +objects they're tracking. + +Objects residing in the file system are "namespaced" using OBuilder's +state directory; with the Docker backend a small unique identifer for +each running OBuilder process is computed based on the instance +working directory, and makes up a prefix for all Docker objects +managed by this instance. This allows to track objects more easily, +and a clean table sweep of any left-overs. + +[runc]: https://github.com/opencontainers/runc + +Another notable difference is that with runc and traditional +filesystems, OBuilder can use tools from the host filesystem, for +instance to copy or compress files, as well as tools from inside the +guest filesystem, chosing or not to run them in the sandbox. With the +Docker backend, guest data isn't accessible from the host, thus tools +must be present in the guest image, or mounted in volumes in running +containers to operate on data in guest images. + +## OBuilder operation + +Using volumes is oftentimes problematic as standard users of the host +don't have read/write permissions on them by default, which involves +some system administration to set up. It's difficult to retain the +settings, and difficult to port, which is why OBuilder's Docker +backend tries to refrain from using Docker volumes as much as +possible, or only interact with them whilst mounted in containers. + +## Copying files in & out of guests + +There's two mode of operation for copying files in OBuilder: from the +context (the host filesystem), or from a previous build stage. As +Docker images are not directly writable from the host filesystem, this +involves communicating the data to a running container. The data could +either be given through a mounted volume, with [`docker cp`][docker +cp], or with a container executing `tar`. Volumes management is hard, +`docker cp` fails on some files in Windows. For stability, we prefer +using a container and tar files (preserving permissions, file +attributes, and allowing easy rewrite of paths). In some cases, it is +necessary to backup the permissions of the destination directory to +restore them after the tarball's extraction. + +[docker cp]: https://docs.docker.com/engine/reference/commandline/cp/ + +Creating a tar file in OBuilder involves creating a _manifest_. It's +a tree data structure describing the file hierachy, with node types +(file, directory, symlink), names, and checksum for file content. The +manifest is generated in a fully-reproducible way, so that its +checksum can uniquely identify the data being copyied, in order to +cache the copy step. + +Copying files from a previous build step is a bit more involved, as +once again the host doesn't have direct read access to the content of +Docker images. A solution could have been to run the manifest creation +code of OBuilder itself in a container, by mounting a volume +containing an simple OCaml executable with this code. It would sadly +be difficult to accomplish[^1] in the general case, as the OCaml +executable would need to correspond to the Docker image (arch, glibc). +The choice was made instead of porting the manifest creation code, +originally in OCaml, to bash. It produces the same output and errors. +It is assumed that Linux distributions ship a bash interpretor, and +tar. For Windows, OBuilder starts by creating a volume, nicknamed +_obuilder-libexec_, in which it copies the shell script, and necessary +tools from Cygwin to execute it (the shell executable, some coreutils, +tar). OBuilder can then run a container based on the source image, +with the _libexec_ volume mounted read-only, to create and output the +manifest. After the manifest is created, OBuilder calls `tar` in the +same fashion to extract data from the previous image, rewrites the tar +headers with the correct destination on-the-fly, and pipes the result +to the destination container, running tar in extraction mode, reading +from stdin. + +Windows 10 ships [BSD tar][], but it doesn't understand symlinks. + +[BSD tar]: https://ss64.com/nt/tar.html + +[^1]: maybe not so much with [Esperanto][]? + +[Esperanto]: https://github.com/dinosaure/esperanto + +## OBuilder's snapshots and caches + +When OBuilder executes a build step _B_ for the first time with a +snapshotting filesystem, it'll first look up or fetch the base image +_A_ of _B_. OBuilder then creates a snapshot _B'_ of _A_, and execute +the build using _B'_. If the build step succeeds, _B'_ is promoted as +_B_; if not, _B'_ is discarded. + +Using the Docker backend, this resolves to checking whether a Docker +image _B_ associated with an OBuilder build exists. If not, tag _A_ as +_tmp-B_, and run the build _B_ in a Docker container with the tag +_tmp-B_. If it succeeds, _tmp-B_ can be commited as the Docker image +_B_, then _tmp-B_ is condemned to _damnatio memoriae_. Special care +must be taken as committing the container replaces the _entrypoint_ +and _cmd_ fields of the Docker image by the commands given to run the +container. This is usually not intended, so these fields are retrieved +and restored from the base image. + +Below is a sample build script and OBuilder logs, run on Windows. + +```text +((from mcr.microsoft.com/windows/servercore:ltsc2022) ; A + (run (shell "echo hello > world")) ; B + (run (shell "type world"))) ; C +``` + +```sh +$ obuilder build -f simple.spec --store=docker:./var --docker-cpus=8 --docker-memory=4g -v . +``` + +```tex +obuilder.exe: [INFO] Exec "docker" "container" "ls" "--all" "--filter" "name=^obuilder-3b98949" "-q" +obuilder.exe: [INFO] Removing left-over Docker images +obuilder.exe: [INFO] Exec "docker" "images" "--format={{ .Repository }}" "obuilder-3b98949-image-tmp-*" +obuilder.exe: [INFO] Removing left-over Docker volumes +obuilder.exe: [INFO] Exec "docker" "volume" "ls" "--quiet" "--filter" "name=^obuilder-3b98949-cache-tmp-" +obuilder.exe: [INFO] Exec "docker" "volume" "inspect" "--" "obuilder-3b98949-libexec" +(from mcr.microsoft.com/windows/servercore:ltsc2022) +obuilder.exe: [INFO] Exec "docker" "inspect" "--type=image" "--" "obuilder-3b98949-image-bc3bc8408e84c12c2b5f24aa91b444894b55e26069b66e8034890634b08aef1d" +Error: No such image: obuilder-3b98949-image-bc3bc8408e84c12c2b5f24aa91b444894b55e26069b66e8034890634b08aef1d +obuilder.exe: [INFO] Base image not present; importing "mcr.microsoft.com/windows/servercore:ltsc2022"… +obuilder.exe: [INFO] Exec "docker" "pull" "mcr.microsoft.com/windows/servercore:ltsc2022" +ltsc2022: Pulling from windows/servercore +Digest: sha256:3949614905ddf2c4451b18894563c36f0c0aa93ab0e17ea6f8ca3791313e4e4f +Status: Image is up to date for mcr.microsoft.com/windows/servercore:ltsc2022 +mcr.microsoft.com/windows/servercore:ltsc2022 +obuilder.exe: [INFO] Exec "docker" "tag" "mcr.microsoft.com/windows/servercore:ltsc2022" "obuilder-3b98949-image-bc3bc8408e84c12c2b5f24aa91b444894b55e26069b66e8034890634b08aef1d" +---> saved as "bc3bc8408e84c12c2b5f24aa91b444894b55e26069b66e8034890634b08aef1d" +C:/: (run (shell "echo hello > world")) +obuilder.exe: [INFO] Exec "docker" "inspect" "--type=image" "--" "obuilder-3b98949-image-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" +Error: No such image: obuilder-3b98949-image-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd +obuilder.exe: [INFO] Exec "docker" "tag" "obuilder-3b98949-image-bc3bc8408e84c12c2b5f24aa91b444894b55e26069b66e8034890634b08aef1d" "obuilder-3b98949-image-tmp-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" +obuilder.exe: [INFO] Exec "docker" "inspect" "--type=container" "--" "obuilder-3b98949-container-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" +Error: No such container: obuilder-3b98949-container-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd +obuilder.exe: [INFO] Exec "docker" "run" "-i" "--name" "obuilder-3b98949-container-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" "--cpus" "8.000000" "--isolation" "hyperv" "--hostname" "builder" "--workdir" "C:/" "--entrypoint" "cmd" "--memory" "4g" "--user" "ContainerAdministrator" "obuilder-3b98949-image-tmp-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" "/S" "/C" "echo hello > world" +obuilder.exe: [INFO] Exec "docker" "inspect" "--type=image" "--format={{json .Config.Entrypoint }}" "--" "obuilder-3b98949-image-tmp-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" +obuilder.exe: [INFO] Exec "docker" "inspect" "--type=image" "--format={{json .Config.Cmd }}" "--" "obuilder-3b98949-image-tmp-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" +obuilder.exe: [INFO] Exec "docker" "commit" "--change=CMD ["c:\\windows\\system32\\cmd.exe"]" "--" "obuilder-3b98949-container-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" "obuilder-3b98949-image-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" +obuilder.exe: [INFO] Exec "docker" "rm" "--force" "--" "obuilder-3b98949-container-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" +sha256:31d1fcc968e21a34fca97a73b56500b0e0208df9c8be60f5eed8369f107878ab +obuilder.exe: [INFO] Exec "docker" "image" "rm" "obuilder-3b98949-image-tmp-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" +obuilder-3b98949-container-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd +Untagged: obuilder-3b98949-image-tmp-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd:latest +---> saved as "ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" +C:/: (run (shell "type world")) +obuilder.exe: [INFO] Exec "docker" "inspect" "--type=image" "--" "obuilder-3b98949-image-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +Error: No such image: obuilder-3b98949-image-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153 +obuilder.exe: [INFO] Exec "docker" "tag" "obuilder-3b98949-image-ac4488b2ca69de829c9a8bbcd9efa2ddff493a3b5888a53ec20a1343ea34b2bd" "obuilder-3b98949-image-tmp-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +obuilder.exe: [INFO] Exec "docker" "inspect" "--type=container" "--" "obuilder-3b98949-container-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +Error: No such container: obuilder-3b98949-container-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153 +obuilder.exe: [INFO] Exec "docker" "run" "-i" "--name" "obuilder-3b98949-container-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" "--cpus" "8.000000" "--isolation" "hyperv" "--hostname" "builder" "--workdir" "C:/" "--entrypoint" "cmd" "--memory" "4g" "--user" "ContainerAdministrator" "obuilder-3b98949-image-tmp-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" "/S" "/C" "type world" +hello +obuilder.exe: [INFO] Exec "docker" "inspect" "--type=image" "--format={{json .Config.Entrypoint }}" "--" "obuilder-3b98949-image-tmp-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +obuilder.exe: [INFO] Exec "docker" "inspect" "--type=image" "--format={{json .Config.Cmd }}" "--" "obuilder-3b98949-image-tmp-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +obuilder.exe: [INFO] Exec "docker" "commit" "--change=CMD ["c:\\windows\\system32\\cmd.exe"]" "--change=ENTRYPOINT ["cmd"]" "--" "obuilder-3b98949-container-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" "obuilder-3b98949-image-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +obuilder.exe: [INFO] Exec "docker" "rm" "--force" "--" "obuilder-3b98949-container-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +sha256:fa67558f979026a08c63c56215253bec59da6d7dff67bf083fb580f96fe1a820 +obuilder-3b98949-container-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153 +obuilder.exe: [INFO] Exec "docker" "image" "rm" "obuilder-3b98949-image-tmp-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +Untagged: obuilder-3b98949-image-tmp-7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153:latest +---> saved as "7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +Got: "7332a0565a4047bdd2c0b778bf3a9175518218879547eb8ddde6832d57861153" +``` + +There's also the shared build cache which can be used to mount one or +more persistent caches for the command. It is also usually implemented +with the snapshotting filesystem. With Docker, this feature is +implemented by [mounting volumes][] in Docker containers. They have +the major disadvantage that there's no copy-on-write or snapshotting +available for volumes. They first have to be copied, and testing has +proved that copying on the host is unreliable because of permissions, +so the source volume is tar'ed in a container, and the tar is streamed +into a second container extracting it to the destination volume. + +[mounting volumes]: https://docs.docker.com/storage/volumes/ + +A piece of advice: if you try to implement any feature with Docker on +Windows, make sure it works first in a shell script, if possible. + +_Mettez Docker à l'ouvrage!_