diff --git a/.gitattributes b/.gitattributes index 635ba65c..6882ca95 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,3 +1,4 @@ *.cmd text eol=crlf *.bash text eol=lf *.sh text eol=lf +test/test.ml text eol=lf diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 8f142847..9d46c943 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -93,3 +93,27 @@ jobs: sudo wget https://github.com/opencontainers/runc/releases/download/$RUNC_VERSION/runc.amd64 -O /usr/local/bin/runc - run: ./.run-gha-tests.sh rsync + + windows: + strategy: + fail-fast: false + matrix: + os: + - windows-latest + ocaml-compiler: + - 4.14.x + + runs-on: ${{ matrix.os }} + + steps: + - name: Checkout code + 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 + + - run: opam exec -- dune build diff --git a/README.md b/README.md index 4a03e6f7..85ad0aaa 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, OBuild 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. @@ -73,9 +76,14 @@ pass the `--fast-sync` option, which installs a seccomp filter that skips all sync syscalls. However, if you attempt to use this with an earlier version of runc then sync operations will instead fail with `EPERM`. +### Windows + +The user running OBuilder must have access to `%PROGRAMDATA%\Docker\volumes`, +because copying caches and maintaining internal tools is done directly on the host. + ## The build specification language -The spec files are loosly based on the [Dockerfile][] format. +The spec files are loosely based on the [Dockerfile][] format. The main difference is that the format uses S-expressions rather than a custom format, which should make it easier to generate and consume it automatically. @@ -104,9 +112,9 @@ The initial filesystem snapshot is `BASE`. `run` and `copy` operations create ne The initial context is supplied by the user (see [build.mli](lib/build.mli) for details). By default: - The environment is taken from the Docker configuration of `BASE`. -- The user is `(uid 0) (gid 0)`. -- The workdir is `/`. -- The shell is `/bin/bash -c`. +- The user is `(uid 0) (gid 0)` on Linux, `(name ContainerAdministrator)` on Windows. +- The workdir is `/`, `C:/` on Windows. +- The shell is `/bin/bash -c`, `C:\Windows\System32\cmd.exe /S /C` on Windows. ### Multi-stage builds @@ -130,7 +138,6 @@ For example: At the moment, the `(build ...)` items must appear before the `(from ...)` line. - ### workdir ```sexp @@ -169,7 +176,6 @@ The command run will be this list of arguments followed by the single argument ` (network NETWORK...)? (secrets SECRET...)? (shell COMMAND)) - ``` Examples: @@ -210,9 +216,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,13 +267,20 @@ Notes: - Both `SRC` and `DST` use `/` as the directory separator on all platforms. -- The copy is currently done by running `tar` inside the container to receive the files. - Therefore, the filesystem must have a working `tar` binary. +- The copy is currently done by running `tar` inside the container to receive + the files. Therefore, the filesystem must have a working `tar` binary. On + Windows when using the Docker backend, OBuilder provides a `tar` binary. + +- On Windows, copying from a build step image based on [Nano Server][nanoserver] + isn't supported. + +[nanoserver]: https://hub.docker.com/_/microsoft-windows-nanoserver ### user ```sexp (user (uid UID) (gid GID)) +(user (name NAME)) ; on Windows ``` Example: diff --git a/dune-project b/dune-project index 5fd93afe..29b8584f 100644 --- a/dune-project +++ b/dune-project @@ -23,13 +23,12 @@ sexplib ppx_deriving ppx_sexp_conv - sha + (sha (>= 1.15.1)) sqlite3 + (crunch (and (>= 3.3.1) :build)) (obuilder-spec (= :version)) - (ocaml (>= 4.10.0)) - (alcotest-lwt :with-test)) - (conflicts - (result (< "1.5")))) + (ocaml (>= 4.14.0)) + (alcotest-lwt :with-test))) (package (name obuilder-spec) (synopsis "Build specification format") diff --git a/example.spec b/example.spec index ba795122..fb1270c2 100644 --- a/example.spec +++ b/example.spec @@ -7,11 +7,11 @@ ; The result can then be found in /tank/HASH/rootfs/ (where HASH is displayed at the end of the build). ((build dev - ((from ocaml/opam@sha256:5b9de826b22c77a0654519d0959536f93a6ffd7020712a8b1c3437445e031e04) + ((from ocaml/opam@sha256:00f4d3f38bbde3a7a28b1b4b8994eded60fb5ee78822082f425662b7f9463178) (workdir /src) (user (uid 1000) (gid 1000)) ; Build as the "opam" user (run (shell "sudo chown opam /src")) - (env OPAM_HASH "97da9a1b68b824a65a09e5f7d071fcf2da35bd1b") ; Fix the version of opam-repository we want + (env OPAM_HASH "9adfaed58b31bc1be6e6086f4dda37e891793a7b") ; Fix the version of opam-repository we want (run (network host) (shell "sudo apt-get --allow-releaseinfo-change update")) diff --git a/example.windows.spec b/example.windows.spec new file mode 100644 index 00000000..d1afc4b8 --- /dev/null +++ b/example.windows.spec @@ -0,0 +1,64 @@ +; This script builds OBuilder itself using a snapshot of the +; ocaml/opam:windows-mingw-ocaml-4.14 base image. +; +; Run it from the top-level of the OBuilder source tree, e.g. +; +; root=../var +; dune exec -- obuilder build --docker-backend="$root" -f example.windows.spec . +; +; The result can then be found in the Docker image "obuilder-ROOTID-image-HASH" +; (where HASH is displayed at the end of the build). +; The logs can be found in "$root/logs/HASH.log". +; ROOTID is computed as follows: $(realpath "$(root)" | sha256sum | cut -b -7) + +((build dev + ((from ocaml/opam@sha256:63f5f8207ea61195988d9d49afcc4044bee3183645c58de6959f0864fabd9383) + (workdir /src) + (env OPAM_HASH "74176d75a60a6ec4d90d4178733b1e09f8becc6f") ; Fix the version of opam-repository-mingw we want + (shell /cygwin64/bin/bash.exe --login -c) + (run + (network "nat") + (shell + "cd /home/opam/opam-repository \ + && (git cat-file -e $OPAM_HASH || git fetch origin opam2) \ + && git reset -q --hard $OPAM_HASH \ + && git --no-pager log --no-decorate -n1 --oneline \ + && rsync -ar --update --exclude='.git' ./ /cygdrive/c/opam/.opam/repo/default \ + && ocaml-env exec --64 -- opam update -u")) + ; opam update -u fails because of patch, so I'm overriding the repo with rsync + (shell cmd /S /C) + ; Copy just the opam file first (helps caching) + (copy (src obuilder-spec.opam obuilder.opam) (dst ./)) + (run + (network "nat") + (cache (opam-archives (target /opam/.opam/download-cache))) + (shell "ocaml-env exec --64 -- opam pin add -yn .")) + ; Install OS package dependencies + (run + (network "nat") + (cache (opam-archives (target /opam/.opam/download-cache))) + (shell "ocaml-env exec --64 -- opam depext -yu obuilder")) + ; Install OCaml dependencies + (run + (network "nat") + (cache (opam-archives (target /opam/.opam/download-cache))) + (shell "ocaml-env exec --64 -- opam install --deps-only -t obuilder-spec")) + (run + (network "nat") + (cache (opam-archives (target /opam/.opam/download-cache))) + (shell "ocaml-env exec --64 -- opam install --deps-only -t obuilder")) + (copy ; Copy the rest of the source code + (src .) + (dst /src/) + (exclude .git _build _opam duniverse)) + (run (shell "ocaml-env exec --64 -- dune build @install")))) ; Build + ; Now generate a small runtime image with just the resulting binary: + (from mcr.microsoft.com/windows/servercore:ltsc2022) + (run (shell "mkdir C:\obuilder")) + (copy (from (build dev)) + (src /cygwin64/usr/x86_64-w64-mingw32/sys-root/mingw/bin/libsqlite3-0.dll) + (dst /obuilder/libsqlite3-0.dll)) + (copy (from (build dev)) + (src /src/_build/default/main.exe) + (dst /obuilder/obuilder.exe)) + (run (shell "/obuilder/obuilder.exe --help"))) diff --git a/lib/btrfs_store.ml b/lib/btrfs_store.ml index a0c3f421..604a942a 100644 --- a/lib/btrfs_store.ml +++ b/lib/btrfs_store.ml @@ -101,6 +101,8 @@ let check_kernel_version () = | _ -> Fmt.failwith "Could not parse output of 'uname -r' (%S)" kver +let root t = t.root + let create root = check_kernel_version () >>= fun () -> Os.ensure_dir (root / "result"); @@ -140,8 +142,13 @@ let build t ?base ~id fn = let result t id = let dir = Path.result t id in match Os.check_dir dir with - | `Present -> Some dir - | `Missing -> None + | `Present -> Lwt.return_some dir + | `Missing -> Lwt.return_none + +let log_file t id = + result t id >|= function + | Some dir -> dir / "log" + | None -> (Path.result_tmp t id) / "log" let get_cache t name = match Hashtbl.find_opt t.caches name with @@ -165,8 +172,11 @@ let cache ~user t name : (string * (unit -> unit Lwt.t)) Lwt.t = (* Create writeable clone. *) let gen = cache.gen in Btrfs.subvolume_snapshot `RW ~src:snapshot tmp >>= fun () -> - let { Obuilder_spec.uid; gid } = user in - Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; tmp] >>= fun () -> + begin match user with + | `Unix { Obuilder_spec.uid; gid } -> + Os.sudo ["chown"; Printf.sprintf "%d:%d" uid gid; tmp] + | `Windows _ -> assert false (* btrfs not supported on Windows*) + end >>= fun () -> let release () = Lwt_mutex.with_lock cache.lock @@ fun () -> begin diff --git a/lib/build.ml b/lib/build.ml index a7afd63a..e9faa27d 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -2,15 +2,20 @@ 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 () + 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" ] @@ -29,7 +34,9 @@ module Context = struct secrets : (string * string) list; } - let v ?switch ?(env=[]) ?(user=Obuilder_spec.root) ?(workdir="/") ?(shell=["/bin/bash"; "-c"]) ?(secrets=[]) ~log ~src_dir () = + let v ?switch ?(env=[]) ?(user=Obuilder_spec.root) ?workdir ?shell ?(secrets=[]) ~log ~src_dir () = + let workdir = Option.value ~default:(if Sys.win32 then {|C:/|} else "/") workdir in + let shell = Option.value ~default:(if Sys.win32 then ["cmd"; "/S"; "/C"] else ["/bin/bash"; "-c"]) shell in { switch; env; src_dir; user; workdir; shell; log; scope = Scope.empty; secrets } let with_binding name value t = @@ -78,11 +85,11 @@ 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 } + { Config.Mount.src; dst = target; readonly = false } ) >>= fun mounts -> let argv = shell @ [cmd] in - let config = Config.v ~cwd:workdir ~argv ~hostname ~user ~env ~mounts ~mount_secrets ~network in + let config = Config.v ~cwd:workdir ~argv ~hostname ~user ~env ~mounts ~mount_secrets ~network () in Os.with_pipe_to_child @@ fun ~r:stdin ~w:close_me -> Lwt_unix.close close_me >>= fun () -> Sandbox.run ~cancelled ~stdin ~log t.sandbox config result_tmp @@ -122,7 +129,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st match Scope.find_opt name scope with | None -> Fmt.failwith "Unknown build %S" name (* (shouldn't happen; gets caught earlier) *) | Some id -> - match Store.result t.store id with + Store.result t.store id >>= function | None -> Lwt_result.fail (`Msg (Fmt.str "Build result %S not found" id)) | Some dir -> @@ -150,6 +157,7 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st ~mount_secrets:[] ~mounts:[] ~network:[] + () in Os.with_pipe_to_child @@ fun ~r:from_us ~w:to_untar -> let proc = Sandbox.run ~cancelled ~stdin:from_us ~log t.sandbox config result_tmp in @@ -233,8 +241,8 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st (Sexplib.Sexp.to_string_hum Saved_context.(sexp_of_t {env})) >>= fun () -> Lwt_result.return () ) - >>!= fun id -> - let path = Option.get (Store.result t.store id) in + >>!= fun id -> Store.result t.store id + >|= Option.get >>= fun path -> let { Saved_context.env } = Saved_context.t_of_sexp (Sexplib.Sexp.load_sexp (path / "env")) in Lwt_result.return (id, env) @@ -270,12 +278,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 @@ -283,6 +290,7 @@ 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!)" @@ -304,4 +312,259 @@ module Make (Raw_store : S.STORE) (Sandbox : S.SANDBOX) (Fetch : S.FETCHER) = st 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.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 120.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!)" + | 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 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/build_log.ml b/lib/build_log.ml index 629ab4db..02b23951 100644 --- a/lib/build_log.ml +++ b/lib/build_log.ml @@ -26,45 +26,47 @@ let catch_cancel fn = ) let tail ?switch t dst = + let rec readonly_tail ch buf = + Lwt_io.read_into ch buf 0 max_chunk_size >>= function + | 0 -> Lwt_result.return () + | n -> dst (Bytes.sub_string buf 0 n); readonly_tail ch buf + in + + let rec open_tail fd cond buf i = + match switch with + | Some sw when not (Lwt_switch.is_on sw) -> Lwt_result.fail `Cancelled + | Some _ | None -> + let avail = min (t.len - i) max_chunk_size in + if avail > 0 then ( + Lwt_unix.pread fd ~file_offset:i buf 0 avail >>= fun n -> + dst (Bytes.sub_string buf 0 n); + open_tail fd cond buf (i + avail) + ) else ( + match t.state with + | `Open _ -> Lwt_condition.wait cond >>= fun () -> open_tail fd cond buf i + | `Readonly _ | `Empty | `Finished -> Lwt_result.return () + ) + in + + let interrupt th = + catch_cancel @@ fun () -> + Lwt_switch.add_hook_or_exec switch (fun () -> Lwt.cancel th; Lwt.return_unit) >>= fun () -> + th + in + match t.state with | `Finished -> invalid_arg "tail: log is finished!" | `Readonly path -> let flags = [Unix.O_RDONLY; Unix.O_NONBLOCK; Unix.O_CLOEXEC] in Lwt_io.(with_file ~mode:input ~flags) path @@ fun ch -> let buf = Bytes.create max_chunk_size in - let rec aux () = - Lwt_io.read_into ch buf 0 max_chunk_size >>= function - | 0 -> Lwt_result.return () - | n -> dst (Bytes.sub_string buf 0 n); aux () - in - catch_cancel @@ fun () -> - let th = aux () in - Lwt_switch.add_hook_or_exec switch (fun () -> Lwt.cancel th; Lwt.return_unit) >>= fun () -> - th + interrupt (readonly_tail ch buf) | `Empty -> Lwt_result.return () | `Open (fd, cond) -> (* Dup [fd], which can still work after [fd] is closed. *) with_dup fd @@ fun fd -> let buf = Bytes.create max_chunk_size in - let rec aux i = - match switch with - | Some sw when not (Lwt_switch.is_on sw) -> Lwt_result.fail `Cancelled - | _ -> - let avail = min (t.len - i) max_chunk_size in - if avail > 0 then ( - Lwt_unix.pread fd ~file_offset:i buf 0 avail >>= fun n -> - dst (Bytes.sub_string buf 0 n); - aux (i + avail) - ) else ( - match t.state with - | `Open _ -> Lwt_condition.wait cond >>= fun () -> aux i - | _ -> Lwt_result.return () - ) - in - catch_cancel @@ fun () -> - let th = aux 0 in - Lwt_switch.add_hook_or_exec switch (fun () -> Lwt.cancel th; Lwt.return_unit) >>= fun () -> - th + interrupt (open_tail fd cond buf 0) let create path = Lwt_unix.openfile path Lwt_unix.[O_CREAT; O_TRUNC; O_RDWR; O_CLOEXEC] 0o666 >|= fun fd -> @@ -114,7 +116,7 @@ let empty = { } let copy ~src ~dst = - let buf = Bytes.create 4096 in + let buf = Bytes.create max_chunk_size in let rec aux () = Lwt_unix.read src buf 0 (Bytes.length buf) >>= function | 0 -> Lwt.return_unit diff --git a/lib/config.ml b/lib/config.ml index 306b7d62..e77df1ed 100644 --- a/lib/config.ml +++ b/lib/config.ml @@ -9,6 +9,7 @@ module Mount = struct type t = { (* TODO: options *) src : string; (* In host namespace *) dst : string; (* In container namespace *) + readonly : bool; } end @@ -21,6 +22,7 @@ end type t = { cwd : string; + entrypoint : string option; argv : string list; hostname : string; user : Obuilder_spec.user; @@ -30,5 +32,5 @@ type t = { mount_secrets : Secret.t list; } -let v ~cwd ~argv ~hostname ~user ~env ~mounts ~network ~mount_secrets = - { cwd; argv; hostname; user; env; mounts; network; mount_secrets } +let v ~cwd ~argv ~hostname ~user ~env ~mounts ~network ~mount_secrets ?entrypoint () = + { cwd; argv; hostname; user; env; mounts; network; mount_secrets; entrypoint; } diff --git a/lib/dao.ml b/lib/dao.ml index 41e914f0..e7342554 100644 --- a/lib/dao.ml +++ b/lib/dao.ml @@ -25,9 +25,9 @@ let create db = rc INTEGER NOT NULL, parent TEXT, FOREIGN KEY (parent) REFERENCES builds (id) ON DELETE RESTRICT - ) |} |> Db.or_fail ~cmd:"create builds"; + ) |} |> Db.or_fail db ~cmd:"create builds"; Sqlite3.exec db {| CREATE INDEX IF NOT EXISTS lru - ON builds (rc, used) |} |> Db.or_fail ~cmd:"create lru index"; + ON builds (rc, used) |} |> Db.or_fail db ~cmd:"create lru index"; let begin_transaction = Sqlite3.prepare db "BEGIN TRANSACTION" in let commit = Sqlite3.prepare db "COMMIT" in let rollback = Sqlite3.prepare db {| ROLLBACK |} in @@ -44,30 +44,30 @@ let create db = { db; begin_transaction; commit; rollback; add; set_used; update_rc; exists; children; delete; lru; parent } let with_transaction t fn = - Db.exec t.begin_transaction []; + Db.exec t.db t.begin_transaction []; match fn () with - | x -> Db.exec t.commit []; x - | exception ex -> Db.exec t.rollback []; raise ex + | x -> Db.exec t.db t.commit []; x + | exception ex -> Db.exec t.db t.rollback []; raise ex let add ?parent ~id ~now t = let now = format_timestamp now in match parent with - | None -> Db.exec t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; NULL ]; + | None -> Db.exec t.db t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; NULL ]; | Some parent -> with_transaction t (fun () -> - Db.exec t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; TEXT parent ]; - Db.exec t.update_rc Sqlite3.Data.[ INT 1L; TEXT parent ]; + Db.exec t.db t.add Sqlite3.Data.[ TEXT id; TEXT now; TEXT now; TEXT parent ]; + Db.exec t.db t.update_rc Sqlite3.Data.[ INT 1L; TEXT parent ]; ) let set_used ~id ~now t = let now = format_timestamp now in - Db.exec t.set_used Sqlite3.Data.[ TEXT now; TEXT id ] + Db.exec t.db t.set_used Sqlite3.Data.[ TEXT now; TEXT id ] let children t id = - match Db.query_one t.exists Sqlite3.Data.[ TEXT id ] with + match Db.query_one t.db t.exists Sqlite3.Data.[ TEXT id ] with | [ INT 0L ] -> Error `No_such_id | [ INT 1L ] -> - Db.query t.children Sqlite3.Data.[ TEXT id ] |> List.map (function + Db.query t.db t.children Sqlite3.Data.[ TEXT id ] |> List.map (function | Sqlite3.Data.[ TEXT dep ] -> dep | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x ) @@ -76,17 +76,31 @@ let children t id = let delete t id = with_transaction t (fun () -> - match Db.query_one t.parent Sqlite3.Data.[ TEXT id ] with + match Db.query_one t.db t.parent Sqlite3.Data.[ TEXT id ] with | [ TEXT parent ] -> - Db.exec t.delete Sqlite3.Data.[ TEXT id ]; - Db.exec t.update_rc Sqlite3.Data.[ INT (-1L); TEXT parent ] + Db.exec t.db t.delete Sqlite3.Data.[ TEXT id ]; + Db.exec t.db t.update_rc Sqlite3.Data.[ INT (-1L); TEXT parent ] | [ NULL ] -> - Db.exec t.delete Sqlite3.Data.[ TEXT id ] + Db.exec t.db t.delete Sqlite3.Data.[ TEXT id ] | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x ) let lru t ~before n = - Db.query t.lru Sqlite3.Data.[ TEXT (format_timestamp before); INT (Int64.of_int n) ] + Db.query t.db t.lru Sqlite3.Data.[ TEXT (format_timestamp before); INT (Int64.of_int n) ] |> List.map @@ function | Sqlite3.Data.[ TEXT id ] -> id | x -> Fmt.failwith "Invalid row: %a" Db.dump_row x + +let close t = + Sqlite3.finalize t.begin_transaction |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.commit |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.rollback |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.add |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.set_used |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.update_rc |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.exists |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.children |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.delete |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.lru |> Db.or_fail t.db ~cmd:"finalize"; + Sqlite3.finalize t.parent |> Db.or_fail t.db ~cmd:"finalize"; + Db.close t.db diff --git a/lib/db.ml b/lib/db.ml index 0e43be1e..bcd2e3b3 100644 --- a/lib/db.ml +++ b/lib/db.ml @@ -1,13 +1,13 @@ type t = Sqlite3.db -let or_fail ~cmd x = +let or_fail db ~cmd x = match x with | Sqlite3.Rc.OK -> () - | err -> Fmt.failwith "Sqlite3: %s (executing %S)" (Sqlite3.Rc.to_string err) cmd + | err -> Fmt.failwith "Sqlite3: [%s] %s (executing %S)" (Sqlite3.Rc.to_string err) (Sqlite3.errmsg db) cmd let no_callback _ = failwith "[exec] used with a query!" -let exec_stmt ?(cb=no_callback) stmt = +let exec_stmt db ?(cb=no_callback) stmt = let rec loop () = match Sqlite3.step stmt with | Sqlite3.Rc.DONE -> () @@ -15,38 +15,38 @@ let exec_stmt ?(cb=no_callback) stmt = let cols = Sqlite3.data_count stmt in cb @@ List.init cols (fun i -> Sqlite3.column stmt i); loop () - | x -> Fmt.failwith "Sqlite3 exec error: %s" (Sqlite3.Rc.to_string x) + | x -> Fmt.failwith "Sqlite3 exec error: [%s] %s" (Sqlite3.Rc.to_string x) (Sqlite3.errmsg db) in loop () let exec_literal db sql = - Sqlite3.exec db sql |> or_fail ~cmd:sql + Sqlite3.exec db sql |> or_fail db ~cmd:sql -let bind stmt values = - Sqlite3.reset stmt |> or_fail ~cmd:"reset"; - List.iteri (fun i v -> Sqlite3.bind stmt (i + 1) v |> or_fail ~cmd:"bind") values +let bind db stmt values = + Sqlite3.reset stmt |> or_fail db ~cmd:"reset"; + List.iteri (fun i v -> Sqlite3.bind stmt (i + 1) v |> or_fail db ~cmd:"bind") values -let exec stmt values = - bind stmt values; - exec_stmt stmt +let exec db stmt values = + bind db stmt values; + exec_stmt db stmt -let query stmt values = - bind stmt values; +let query db stmt values = + bind db stmt values; let results = ref [] in let cb row = results := row :: !results in - exec_stmt ~cb stmt; + exec_stmt db ~cb stmt; List.rev !results -let query_one stmt values = - match query stmt values with +let query_one db stmt values = + match query db stmt values with | [row] -> row | [] -> failwith "No results from SQL query!" | _ -> failwith "Multiple results from SQL query!" -let query_some stmt values = - match query stmt values with +let query_some db stmt values = + match query db stmt values with | [] -> None | [row] -> Some row | _ -> failwith "Multiple results from SQL query!" @@ -60,3 +60,7 @@ let of_dir path = let dump_item = Fmt.of_to_string Sqlite3.Data.to_string_debug let dump_row = Fmt.(Dump.list dump_item) + +let close db = + if not (Sqlite3.db_close db) then + Fmt.failwith "Could not close database! It is busy." diff --git a/lib/db_store.ml b/lib/db_store.ml index 472ab90c..17978e33 100644 --- a/lib/db_store.ml +++ b/lib/db_store.ml @@ -45,11 +45,11 @@ module Make (Raw : S.STORE) = struct or by doing a new build using [fn]. We only run one instance of this at a time for a single [id]. *) let get_build t ~base ~id ~cancelled ~set_log fn = - match Raw.result t.raw id with - | Some dir -> + Raw.result t.raw id >>= function + | Some _ -> let now = Unix.(gmtime (gettimeofday ())) in Dao.set_used t.dao ~id ~now; - let log_file = dir / "log" in + Raw.log_file t.raw id >>= fun log_file -> begin if Sys.file_exists log_file then Build_log.of_saved log_file else Lwt.return Build_log.empty @@ -58,7 +58,7 @@ module Make (Raw : S.STORE) = struct Lwt_result.return (`Loaded, id) | None -> Raw.build t.raw ?base ~id (fun dir -> - let log_file = dir / "log" in + Raw.log_file t.raw id >>= fun log_file -> if Sys.file_exists log_file then Unix.unlink log_file; Build_log.create log_file >>= fun log -> Lwt.wakeup set_log log; @@ -173,4 +173,7 @@ module Make (Raw : S.STORE) = struct let db = Db.of_dir (db_dir / "db.sqlite") in let dao = Dao.create db in { raw; dao; in_progress = Builds.empty } + + let unwrap t = + Dao.close t.dao end diff --git a/lib/db_store.mli b/lib/db_store.mli index c230ee46..5aae49af 100644 --- a/lib/db_store.mli +++ b/lib/db_store.mli @@ -18,7 +18,7 @@ module Make (Raw : S.STORE) : sig val prune : ?log:(S.id -> unit) -> t -> before:Unix.tm -> int -> int Lwt.t - val result : t -> S.id -> string option + val result : t -> S.id -> string option Lwt.t val cache : user : Obuilder_spec.user -> @@ -27,4 +27,6 @@ module Make (Raw : S.STORE) : sig (string * (unit -> unit Lwt.t)) Lwt.t val wrap : Raw.t -> t + + val unwrap : t -> unit end diff --git a/lib/docker.ml b/lib/docker.ml index c52f1fd2..56c97889 100644 --- a/lib/docker.ml +++ b/lib/docker.ml @@ -1,37 +1,344 @@ -open Lwt.Infix - -let export_env base : Config.env Lwt.t = - Os.pread ["docker"; "image"; "inspect"; - "--format"; {|{{range .Config.Env}}{{print . "\x00"}}{{end}}|}; - "--"; base] >|= fun env -> - String.split_on_char '\x00' env - |> List.filter_map (function - | "\n" -> None - | kv -> - match Astring.String.cut ~sep:"=" kv with - | None -> Fmt.failwith "Invalid environment in Docker image %S (should be 'K=V')" kv - | Some _ as pair -> pair - ) +open Lwt.Syntax + +type ids = [ + | `Docker_image of string | `Docker_container of string + | `Docker_volume of string | `Obuilder_id of string +] + +let prefix = ref "obuilder" +let set_prefix prefix' = prefix := prefix' + +let image_prefix () = !prefix ^ "-image-" +let container_prefix () = !prefix ^ "-container-" +let cache_prefix () = !prefix ^ "-cache-" +let volume_prefix () = !prefix ^ "-copy-" + +let obuilder_volume () = !prefix ^ "-volume" +let image_name ?(tmp=false) name = image_prefix () ^ (if tmp then "tmp-" else "") ^ name +let container_name name = container_prefix () ^ name +let volume_cache_name ?(tmp=false) name = cache_prefix () ^ (if tmp then "tmp-" else "") ^ name +let volume_copy_name ?(tmp=false) name = volume_prefix () ^ (if tmp then "tmp-" else "") ^ name + +let 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 bash_entrypoint obuilder_volume = + [if Sys.win32 then mount_point_inside_native / obuilder_volume / "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 ?stderr argv = + let stderr = Option.value ~default:(`FD_move_safely Os.stderr) stderr in + Os.pread ~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 = function + | `Create (`Docker_volume name) -> pread ("volume" :: "create" :: "--" :: name :: []) + | `Inspect (volumes, `Mountpoint) -> + let volumes = List.rev_map extract_name volumes in + let format = "{{ .Mountpoint }}" in + pread ?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 vol -> `Docker_volume vol) + + 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 cmd = + with_stderr_log ~log (fun ~stderr -> Cmd.volume ~stderr 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 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..e24ea6f1 100644 --- a/lib/docker.mli +++ b/lib/docker.mli @@ -1,3 +1,64 @@ -(** Fetching of base images using Docker *) +(** Docker interface over the CLI tool *) -include S.FETCHER +type ids = [ + | `Docker_container of string | `Docker_image of string + | `Docker_volume of string + | `Obuilder_id of string +] + +val set_prefix : string -> unit +(** Set the prefix for Docker images, containers, and volumes managed + by the current OBuilder instance. *) + +val obuilder_volume : unit -> string +val image_name : ?tmp:bool -> S.id -> string +val container_name : S.id -> string +val volume_copy_name : ?tmp:bool -> S.id -> string + +val docker_image : ?tmp:bool -> S.id -> [> `Docker_image of string ] +val docker_container : S.id -> [> `Docker_container of string ] +val docker_volume_cache : ?tmp:bool -> S.id -> [> `Docker_volume of string ] +val docker_volume_copy : ?tmp:bool -> S.id -> [> `Docker_volume of string ] + +val 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. *) + +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. *) + +(** Wrappers for various Docker client commands, exposing file descritors. *) +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..8b4f68c3 --- /dev/null +++ b/lib/docker_sandbox.ml @@ -0,0 +1,484 @@ +open Lwt.Syntax +let ( >>!= ) = Lwt_result.bind +open Sexplib.Conv + +let ( / ) = Filename.concat +let ( // ) p1 p2 = if Sys.win32 then p1 ^ "/" ^ p2 else Filename.concat p1 p2 +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 = mounts |> List.concat_map (fun mount -> + (* 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"; strf "type=volume,src=%s,dst=%s%s" + mount.src dst (if mount.readonly then ",readonly" else "") ]) 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) = + List.fold_left (fun (id, mount_secrets) _ -> + let host, guest = config_dir / secret_dir id, secrets_guest_root / secret_dir id in + let argv = "--mount" :: (strf "type=bind,src=%s,dst=%s,readonly" host guest) :: mount_secrets in + id + 1, argv) + (0, []) 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 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 obuilder_volume = Docker.obuilder_volume () in + 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 // obuilder_volume // "manifest.bash") + workdir + "/" + (List.length exclude) + (String.concat " " (List.map Filename.quote exclude)) + (List.length src) + (String.concat " " (List.map Filename.quote src)) + in + let config = + let entrypoint, argv = Docker.setup_command ~entp:(Docker.bash_entrypoint obuilder_volume) ~cmd:[argv] in + Config.v + ~cwd:workdir + ~argv + ~hostname + ~user + ~env:["PATH", if Sys.win32 then Docker.mount_point_inside_unix // obuilder_volume else "/bin:/usr/bin"] + ~mount_secrets:[] + ~mounts:Config.Mount.[ + {src = obuilder_volume; dst = Docker.mount_point_inside_native / obuilder_volume; readonly = true}] + ~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 obuilder_volume = Docker.obuilder_volume () in + let entrypoint = + if Sys.win32 then Docker.mount_point_inside_native // obuilder_volume // "tar.exe" + else "tar" + in + let argv = + [ "-cf-"; "--format=gnu"; + "--directory"; workdir; + (* Beware, the order is meaningfull: --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:Config.Mount.[ + {src = obuilder_volume; dst = Docker.mount_point_inside_native / obuilder_volume; readonly = true}] + ~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 obuilder_volume = Docker.obuilder_volume () in + let mounts = + if Sys.win32 then [Config.Mount.{ + src = obuilder_volume; + dst = Docker.mount_point_inside_native / obuilder_volume; + readonly = true; }] + else [] + in + 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 -xf - --verbose; if ($acl -ne $null) { Set-Acl -Path $path $acl }|} + (Option.get dst_dir) (Docker.mount_point_inside_native // obuilder_volume) ] + else begin + assert (dst_dir = None); + "tar", ["-xf"; "-"; "--verbose"] + end in + let config = Config.v + ~cwd:(if Sys.unix then "/" else "C:/") + ~argv + ~hostname + ~user:Obuilder_spec.root + ~env:[] + ~mount_secrets:[] + ~mounts + ~network:[] + ~entrypoint + () + in + Lwt_result.bind_lwt + (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 + if !img <> None then Option.get !img + else begin + 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? *) + | "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 img'); + Option.get !img + end + +(* 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_volume () in + let vol = `Docker_volume name and img = `Docker_image name in + let* _ = Docker.Cmd.volume (`Create vol) in + let* mount_point = Docker.Cmd.mount_point vol in + + let copy_static_file ?(perm=0o400) file = + let contents = Option.get (Static_files.read file) in + if Sys.win32 then + Lwt_io.(with_file ~perm ~mode:Output (mount_point / file) + (fun ch -> Lwt_io.fprint ch contents)) + else + Lwt_io.(with_temp_file ~perm @@ fun (temp_name, ch) -> + let* () = Lwt_io.fprint ch contents in + Os.copy ~superuser:true ~src:temp_name (mount_point / file)) + in + let* () = copy_static_file ~perm:0o500 "manifest.bash" in + + if Sys.win32 then + let* base = servercore () in + let dockerfile = + "# escape=`\n" ^ (Printf.sprintf "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" ] + |} 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 docker_argv = [ + "--isolation"; List.assoc t.docker_isolation isolations; + "--network"; t.docker_network; + ] in + Docker.Cmd.build docker_argv img temp_dir + in + + let config = + let entrypoint, argv = {|C:\Windows\System32\cmd.exe|}, ["/S"; "/C"; {|C:\extract.cmd|}] in + let destination = strf {|C:\%s|} name in + Config.v ~cwd:{|C:/|} ~argv ~hostname:"" + ~user:(Obuilder_spec.(`Windows {name = "ContainerAdministrator"})) + ~env:["DESTINATION", destination] + ~mount_secrets:[] + ~mounts:Config.Mount.[ + {src = name; dst = destination; 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) + else Lwt.return_unit + +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_volume ())) 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..29adebed --- /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 -> 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..74d27c3f --- /dev/null +++ b/lib/docker_store.ml @@ -0,0 +1,213 @@ +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* _ = Docker.Cmd.volume (`Create volume) in + Lwt.return_unit + + let snapshot ~src dst = + let* () = create dst in + let* src = Docker.Cmd.mount_point src in + let* dst = Docker.Cmd.mount_point dst in + Os.copy ~superuser:true ~src dst + + 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 volume. *) + 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 c725fd4d..efba3555 100644 --- a/lib/dune +++ b/lib/dune @@ -1,3 +1,10 @@ +(rule + (target Static_files.ml) + (deps + (source_tree ../static)) + (action + (run %{bin:ocaml-crunch} ../static --mode=plain -o %{target}))) + (library (name obuilder) (public_name obuilder) diff --git a/lib/manifest.ml b/lib/manifest.ml index b69f389a..2413dd23 100644 --- a/lib/manifest.ml +++ b/lib/manifest.ml @@ -5,12 +5,15 @@ let ( / ) = Filename.concat type hash = Sha256.t let sexp_of_hash t = Sexplib.Sexp.Atom (Sha256.to_hex t) +let hash_of_sexp = function + | Sexplib.Sexp.Atom hash -> Sha256.of_hex hash + | x -> Fmt.failwith "Invalid data source: %a" Sexplib.Sexp.pp_hum x type t = [ | `File of (string * hash) | `Symlink of (string * string) | `Dir of (string * t list) -] [@@deriving sexp_of] +] [@@deriving sexp] let rec generate ~exclude ~src_dir src : t = let path = src_dir / src in @@ -69,3 +72,13 @@ let generate ~exclude ~src_dir src = |> Result.ok with Failure m -> Error (`Msg m) + +let to_from_files ?(null=false) t = + let sep = if null then '\000' else '\n' in + let buf = Buffer.create 64 in + let rec aux = function + | `File (name, _) | `Symlink (name, _) -> Buffer.add_string buf name; Buffer.add_char buf sep + | `Dir (name, entries) -> Buffer.add_string buf name; Buffer.add_char buf sep; List.iter aux entries + in + aux t; + Buffer.contents buf diff --git a/lib/manifest.mli b/lib/manifest.mli index 36e6af64..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 141a0a78..2f37cccd 100644 --- a/lib/obuilder.ml +++ b/lib/obuilder.ml @@ -12,19 +12,22 @@ 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 Docker_extract = Docker.Extract (** {2 Sandboxes} *) module Config = Config module Runc_sandbox = Runc_sandbox +module Docker_sandbox = Docker_sandbox (** {2 Builders} *) module type BUILDER = S.BUILDER with type context := Build.Context.t module Builder = Build.Make +module Docker_builder = Build.Make_Docker module Build_log = Build_log (**/**) diff --git a/lib/os.ml b/lib/os.ml index d09b2538..c674d66e 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 @@ -25,7 +36,9 @@ let pp_signal f x = else if x = sigterm then Fmt.string f "term" else Fmt.int f x -let pp_cmd = Fmt.box Fmt.(list ~sep:sp (quote string)) +let pp_cmd f (cmd, argv) = + let argv = if cmd = "" then argv else cmd :: argv in + Fmt.hbox Fmt.(list ~sep:sp (quote string)) f argv let redirection = function | `FD_move_safely x -> `FD_copy x.raw @@ -43,42 +56,46 @@ let default_exec ?cwd ?stdin ?stdout ?stderr ~pp argv = let stdin = Option.map redirection stdin in let stdout = Option.map redirection stdout in let stderr = Option.map redirection stderr in - Lwt_process.exec ?cwd ?stdin ?stdout ?stderr argv + try Lwt_result.ok (Lwt_process.exec ?cwd ?stdin ?stdout ?stderr argv) + with e -> Lwt_result.fail e in Option.iter close_redirection stdin; Option.iter close_redirection stdout; Option.iter close_redirection stderr; - proc >|= function - | Unix.WEXITED n -> Ok n - | Unix.WSIGNALED x -> Fmt.error_msg "%t failed with signal %d" pp x - | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp pp_signal x + proc >|= fun proc -> + Result.fold ~ok:(function + | Unix.WEXITED n -> Ok n + | Unix.WSIGNALED x -> Fmt.error_msg "%t failed with signal %d" pp x + | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp pp_signal x) + ~error:(fun e -> + Fmt.error_msg "%t raised %s\n%s" pp (Printexc.to_string e) (Printexc.get_backtrace ())) proc (* Overridden in unit-tests *) let lwt_process_exec = ref default_exec -let exec_result ?cwd ?stdin ?stdout ?stderr ~pp argv = - Logs.info (fun f -> f "Exec %a" pp_cmd argv); - !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp ("", Array.of_list argv) >>= function - | Ok 0 -> Lwt_result.return () +let exec_result ?cwd ?stdin ?stdout ?stderr ~pp ?(is_success=((=) 0)) ?(cmd="") argv = + Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv)); + !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function + | Ok n when is_success n -> Lwt_result.ok Lwt.return_unit | 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 argv = - Logs.info (fun f -> f "Exec %a" pp_cmd argv); - let pp f = pp_cmd f argv in - !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp ("", Array.of_list argv) >>= function - | Ok 0 -> Lwt.return_unit +let exec ?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 + | 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) let running_as_root = not (Sys.unix) || Unix.getuid () = 0 let sudo ?stdin args = - let args = if running_as_root then args else "sudo" :: args in + let args = if running_as_root then args else "sudo" :: "--" :: args in exec ?stdin args let sudo_result ?cwd ?stdin ?stdout ?stderr ~pp args = - let args = if running_as_root then args else "sudo" :: args in + let args = if running_as_root then args else "sudo" :: "--" :: args in exec_result ?cwd ?stdin ?stdout ?stderr ~pp args let rec write_all fd buf ofs len = @@ -89,6 +106,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 -> @@ -133,9 +158,34 @@ let pread ?stderr argv = Lwt.finalize (fun () -> Lwt_io.read r) (fun () -> Lwt_io.close r) - >>= fun data -> - child >>= fun () -> - Lwt.return data + >>= 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_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 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 @@ -143,7 +193,64 @@ 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 copy ?(superuser=false) ~src dst = + if Sys.win32 then + exec ["robocopy"; src; dst; "/MIR"; "/NFL"; "/NDL"; "/NJH"; "/NJS"; "/NC"; "/NS"; "/NP"] + ~is_success:(fun n -> n = 0 || n = 1) + else if superuser then + sudo ["cp"; "-a"; "--"; src; dst ] + else + exec ["cp"; "-a"; "--"; src; dst ] + +(** 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/rsync_store.ml b/lib/rsync_store.ml index d0907c4c..4b50f565 100644 --- a/lib/rsync_store.ml +++ b/lib/rsync_store.ml @@ -3,7 +3,7 @@ efficient. *) open Lwt.Infix -(* The caching approach (and much of the code) is copied from the btrfs +(* The caching approach (and much of the code) is copied from the btrfs implementation *) type cache = { lock : Lwt_mutex.t; @@ -79,6 +79,8 @@ module Path = struct let result_tmp t id = t.path / result_tmp_dirname / id end +let root t = t.path + let create ~path ?(mode = Copy) () = Rsync.create path >>= fun () -> Lwt_list.iter_s Rsync.create (Path.dirs path) >|= fun () -> @@ -118,8 +120,13 @@ let delete t id = let result t id = let dir = Path.result t id in match Os.check_dir dir with - | `Present -> Some dir - | `Missing -> None + | `Present -> Lwt.return_some dir + | `Missing -> Lwt.return_none + +let log_file t id = + result t id >|= function + | Some dir -> dir / "log" + | None -> (Path.result_tmp t id) / "log" let state_dir t = t.path / Path.state_dirname @@ -144,7 +151,9 @@ let cache ~user t name = end >>= fun () -> (* Create writeable clone. *) let gen = cache.gen in - let { Obuilder_spec.uid; gid } = user in + let { Obuilder_spec.uid; gid } = match user with + | `Unix user -> user + | `Windows _ -> assert false (* rsync not supported on Windows *) in Rsync.copy_children ~chown:(Printf.sprintf "%d:%d" uid gid) ~src:snapshot ~dst:tmp () >>= fun () -> let release () = Lwt_mutex.with_lock cache.lock @@ fun () -> diff --git a/lib/runc_sandbox.ml b/lib/runc_sandbox.ml index 1b54aca9..0b8398ff 100644 --- a/lib/runc_sandbox.ml +++ b/lib/runc_sandbox.ml @@ -42,13 +42,10 @@ module Json_config = struct ] let user_mounts = - List.map @@ fun { Config.Mount.src; dst } -> + List.map @@ fun { Config.Mount.src; dst; readonly } -> + let options = [ "bind"; "nosuid"; "nodev"; ] in mount ~ty:"bind" ~src dst - ~options:[ - "bind"; - "nosuid"; - "nodev"; - ] + ~options:(if readonly then "ro" :: options else options) let strings xs = `List ( List.map (fun x -> `String x) xs) @@ -106,9 +103,12 @@ module Json_config = struct in `Assoc fields - let make {Config.cwd; argv; hostname; user; env; mounts; network; mount_secrets} t ~config_dir ~results_dir : Yojson.Safe.t = + let make {Config.cwd; argv; hostname; user; env; mounts; network; mount_secrets; entrypoint} t ~config_dir ~results_dir : Yojson.Safe.t = + assert (entrypoint = None); let user = - let { Obuilder_spec.uid; gid } = user in + let { Obuilder_spec.uid; gid } = match user with + | `Unix user -> user + | `Windows _ -> assert false (* runc not supported on Windows *) in `Assoc [ "uid", `Int uid; "gid", `Int gid; @@ -295,7 +295,7 @@ let run ~cancelled ?stdin:stdin ~log t config results_dir = let copy_log = Build_log.copy ~src:out_r ~dst:log in let proc = let stdin = Option.map (fun x -> `FD_move_safely x) stdin in - let pp f = Os.pp_cmd f config.argv in + let pp f = Os.pp_cmd f ("", config.argv) in Os.sudo_result ~cwd:tmp ?stdin ~stdout ~stderr ~pp cmd in Lwt.on_termination cancelled (fun () -> @@ -334,10 +334,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/s.ml b/lib/s.ml index 1cafba89..416c79d7 100644 --- a/lib/s.ml +++ b/lib/s.ml @@ -13,6 +13,9 @@ type logger = tag -> string -> unit module type STORE = sig type t + val root : t -> string + (** [root t] returns the root of the store. *) + val build : t -> ?base:id -> id:id -> @@ -31,9 +34,13 @@ module type STORE = sig val delete : t -> id -> unit Lwt.t (** [delete t id] removes [id] from the store, if present. *) - val result : t -> id -> string option + val result : t -> id -> string option Lwt.t (** [result t id] is the path of the build result for [id], if present. *) + val log_file : t -> id -> string Lwt.t + (** [log_file t id] is the path of the build logs for [id]. The file may + not exist if the build has never been run, or failed. *) + val state_dir : t -> string (** [state_dir] is the path of a directory which can be used to store mutable state related to this store (e.g. an sqlite3 database). *) @@ -73,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. @@ -90,6 +97,10 @@ module type BUILDER = sig Obuilder_spec.t -> (id, [> `Cancelled | `Msg of string]) Lwt_result.t + val finish : t -> unit Lwt.t + (** [finish builder] close allocated resources and store state (e.g., sqlite3 + databases). *) + val delete : ?log:(id -> unit) -> t -> id -> unit Lwt.t (** [delete ?log t id] removes [id] from the store, along with all of its dependencies. This is for testing. Note that is not safe to perform builds while deleting: @@ -117,3 +128,106 @@ 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 + val export : + ([< `Docker_container of string ] -> unit Lwt.t) log + val image : + ([< `Remove of [< `Docker_image of string ] ] -> unit Lwt.t) log + val rm : + ([ `Docker_container of string ] list -> unit Lwt.t) log + val rmi : + ([ `Docker_image of string ] list -> unit Lwt.t) log + val tag : + ([< `Docker_image of string ] -> + [< `Docker_image of string ] -> unit Lwt.t) log + val commit : + ([< `Docker_image of string ] -> + [< `Docker_container of string ] -> + [< `Docker_image of string ] -> unit Lwt.t) log + val volume : + ([< `Create of [< `Docker_volume of string ] + | `Inspect of [< `Docker_volume of string ] list * [< `Mountpoint ] + | `List of string option + | `Remove of [< `Docker_volume of string ] list ] -> + string Lwt.t) logerr + val volume_containers : + ([< `Docker_volume of string ] -> [> `Docker_volume of string ] list Lwt.t) logerr + val mount_point : + ([< `Docker_volume of string ] -> string Lwt.t) logerr + val build : + (string list -> [< `Docker_image of string ] -> string -> unit Lwt.t) log + + 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 + 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 + 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 + 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 + 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 + + val stop : + ([< `Docker_container of string ] -> + (unit, [> `Msg of string ]) result Lwt.t) log + + 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 + + val exists : + ([< `Docker_container of string + | `Docker_image of string + | `Docker_volume of string ] -> + (unit, [> `Msg of string ]) result Lwt.t) log + + val obuilder_images : + (?tmp:bool -> unit -> [ `Docker_image of string ] list Lwt.t) logerr + val obuilder_containers : + (unit -> [ `Docker_container of string ] list Lwt.t) logerr + val obuilder_volumes : + (?prefix:string -> unit -> [ `Docker_volume of string ] list Lwt.t) logerr + val obuilder_caches_tmp : + (unit -> [ `Docker_volume of string ] list Lwt.t) logerr +end diff --git a/lib/store_spec.ml b/lib/store_spec.ml index 8947469c..1e2e0bb1 100644 --- a/lib/store_spec.ml +++ b/lib/store_spec.ml @@ -6,6 +6,7 @@ type t = [ | `Btrfs of string (* Path *) | `Zfs of string (* Pool *) | `Rsync of string (* Path for the root of the store *) + | `Docker of string (* Path *) ] let is_absolute path = not (Filename.is_relative path) @@ -15,48 +16,64 @@ 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 pool -> Fmt.pf f "zfs:%s" pool | `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 mode = function +let to_store rsync_mode = function | `Btrfs path -> - Btrfs_store.create path >|= fun store -> + `Runc, Btrfs_store.create path >|= fun store -> Store ((module Btrfs_store), store) | `Zfs pool -> - Zfs_store.create ~pool >|= fun store -> + `Runc, Zfs_store.create ~pool >|= fun store -> Store ((module Zfs_store), store) | `Rsync path -> - Rsync_store.create ~path ~mode () >|= fun store -> + `Runc, 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) -let cmdliner = - let open Cmdliner in - let store_t = Arg.conv (of_string, pp) in - let store = - Arg.required @@ - Arg.opt Arg.(some store_t) None @@ - Arg.info - ~doc:"$(b,btrfs:/path) or $(b,rsync:/path) or $(b,zfs:pool) for build cache." - ~docv:"STORE" - ["store"] +open Cmdliner + +let store_t = Arg.conv (of_string, pp) + +let store names = + Arg.opt Arg.(some store_t) None @@ + Arg.info + ~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" + names + +let rsync_mode = + let options = + [("copy", Rsync_store.Copy); + ("hardlink", Rsync_store.Hardlink); + ("hardlink_unsafe", Rsync_store.Hardlink_unsafe)] in - let rsync_mode = - let options = - [("copy", Rsync_store.Copy); - ("hardlink", Rsync_store.Hardlink); - ("hardlink_unsafe", Rsync_store.Hardlink_unsafe)] - in - Arg.value @@ - Arg.opt (Arg.enum options) Rsync_store.Copy @@ - Arg.info - ~doc:"$(b,copy) or $(b,hardlink), to optimize for speed or low disk usage." - ~docv:"RSYNC_MODE" - ["rsync-mode"] + Arg.value @@ + Arg.opt (Arg.enum options) Rsync_store.Copy @@ + Arg.info + ~doc:(Printf.sprintf "Optimize for speed or low disk usage. $(docv) must be one of %s." + (Arg.doc_alts_enum options)) + ~docv:"RSYNC_MODE" + ["rsync-mode"] + +(** A Cmdliner term where the store is required. *) +let cmdliner = + Term.(const to_store $ rsync_mode $ (Arg.required @@ (store ["store"]))) + +(** A Cmdliner term where the store is optional. *) +let cmdliner_opt = + let make rsync_mode = function + | None -> None + | Some store -> Some (to_store rsync_mode store) in - Term.(const to_store $ rsync_mode $ store) + Term.(const make $ rsync_mode $ (Arg.value @@ (store ["obuilder-store"]))) diff --git a/lib/tar_transfer.ml b/lib/tar_transfer.ml index 77a7aa7a..630a36a5 100644 --- a/lib/tar_transfer.ml +++ b/lib/tar_transfer.ml @@ -55,13 +55,21 @@ let copy_to ~dst src = in aux () +let get_ids = function + | `Unix user -> Some user.Obuilder_spec.uid, Some user.gid, None, None + | `Windows user when user.Obuilder_spec.name = "ContainerAdministrator" -> + (* https://cygwin.com/cygwin-ug-net/ntsec.html#ntsec-mapping *) + let x = 93 and rid = 1 in + Some (0x1000 * x + rid), Some (0x1000 * x + rid), Some user.name, Some user.name + | `Windows _ -> None, None, None, None + let copy_file ~src ~dst ~to_untar ~user = Lwt_unix.LargeFile.lstat src >>= fun stat -> + let user_id, group_id, uname, gname = get_ids user in let hdr = Tar.Header.make ~file_mode:(if stat.Lwt_unix.LargeFile.st_perm land 0o111 <> 0 then 0o755 else 0o644) ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) - ~user_id:user.Obuilder_spec.uid - ~group_id:user.Obuilder_spec.gid + ?user_id ?group_id ?uname ?gname dst stat.Lwt_unix.LargeFile.st_size in Tar_lwt_unix.write_block ~level hdr (fun ofd -> @@ -71,13 +79,13 @@ let copy_file ~src ~dst ~to_untar ~user = let copy_symlink ~src ~target ~dst ~to_untar ~user = Lwt_unix.LargeFile.lstat src >>= fun stat -> + let user_id, group_id, uname, gname = get_ids user in let hdr = Tar.Header.make ~file_mode:0o777 ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) ~link_indicator:Tar.Header.Link.Symbolic ~link_name:target - ~user_id:user.Obuilder_spec.uid - ~group_id:user.Obuilder_spec.gid + ?user_id ?group_id ?uname ?gname dst 0L in Tar_lwt_unix.write_block ~level hdr (fun _ -> Lwt.return_unit) to_untar @@ -86,11 +94,11 @@ let rec copy_dir ~src_dir ~src ~dst ~(items:(Manifest.t list)) ~to_untar ~user = Log.debug(fun f -> f "Copy dir %S -> %S@." src dst); Lwt_unix.LargeFile.lstat (src_dir / src) >>= fun stat -> begin + let user_id, group_id, uname, gname = get_ids user in let hdr = Tar.Header.make ~file_mode:0o755 ~mod_time:(Int64.of_float stat.Lwt_unix.LargeFile.st_mtime) - ~user_id:user.Obuilder_spec.uid - ~group_id:user.Obuilder_spec.gid + ?user_id ?group_id ?uname ?gname (dst ^ "/") 0L in Tar_lwt_unix.write_block ~level hdr (fun _ -> Lwt.return_unit) to_untar @@ -132,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/lib/zfs_store.ml b/lib/zfs_store.ml index 2a603aab..cee3df6e 100644 --- a/lib/zfs_store.ml +++ b/lib/zfs_store.ml @@ -88,11 +88,11 @@ end = struct else fn () end -let user = { Obuilder_spec.uid = Unix.getuid (); gid = Unix.getgid () } +let user = `Unix { Obuilder_spec.uid = Unix.getuid (); gid = Unix.getgid () } module Zfs = struct let chown ~user t ds = - let { Obuilder_spec.uid; gid } = user in + let { Obuilder_spec.uid; gid } = match user with `Unix user -> user | `Windows _ -> assert false in Os.sudo ["chown"; strf "%d:%d" uid gid; Dataset.path t ds] let create t ds = @@ -140,6 +140,8 @@ let delete_if_exists t ds mode = let state_dir t = Dataset.path t Dataset.state +let root t = t.pool + let create ~pool = let t = { pool; caches = Hashtbl.create 10; next = 0 } in (* Ensure any left-over temporary datasets are removed before we start. *) @@ -202,8 +204,16 @@ let build t ?base ~id fn = let result t id = let ds = Dataset.result id in let path = Dataset.path t ds ~snapshot:default_snapshot in - if Sys.file_exists path then Some path - else None + if Sys.file_exists path then Lwt.return_some path + else Lwt.return_none + +let log_file t id = + result t id >|= function + | Some dir -> Filename.concat dir "log" + | None -> + let ds = Dataset.result id in + let clone = Dataset.path t ds in + Filename.concat clone "log" let get_cache t name = match Hashtbl.find_opt t.caches name with diff --git a/lib_spec/docker.ml b/lib_spec/docker.ml index f58ee570..d78e8824 100644 --- a/lib_spec/docker.ml +++ b/lib_spec/docker.ml @@ -2,43 +2,54 @@ type ctx = { user : Spec.user; } -let default_ctx = { - user = Spec.root; -} - (* Note: could do with some escaping here, but the rules are not clear. *) let pp_pair f (k, v) = Fmt.pf f "%s=%s" k v -let pp_wrap = +let pp_escape ~escape = + match escape with + | '\\' -> Fmt.any " \\@\n " + | '`' -> Fmt.any " `@\n " + | _ -> assert false + +let pp_wrap ~escape = Fmt.using (String.split_on_char '\n') - Fmt.(list ~sep:(any " \\@\n ") (using String.trim string)) + Fmt.(list ~sep:(pp_escape ~escape) (using String.trim string)) let pp_cache ~ctx f { Cache.id; target; buildkit_options } = + let buildkit_options = match ctx.user with + | `Unix {uid; gid = _} -> ("uid", string_of_int uid) :: buildkit_options + | `Windows _ -> assert false + in let buildkit_options = ("--mount=type", "cache") :: ("id", id) :: ("target", target) :: - ("uid", string_of_int ctx.user.uid) :: buildkit_options in Fmt.pf f "%a" Fmt.(list ~sep:(any ",") pp_pair) buildkit_options let pp_mount_secret ~ctx f { Secret.id; target; buildkit_options } = + let buildkit_options = match ctx.user with + | `Unix {uid; gid = _} -> ("uid", string_of_int uid) :: buildkit_options + | `Windows _ -> assert false + in let buildkit_options = ("--mount=type", "secret") :: ("id", id) :: ("target", target) :: - ("uid", string_of_int ctx.user.uid) :: buildkit_options in Fmt.pf f "%a" Fmt.(list ~sep:(any ",") pp_pair) buildkit_options -let pp_run ~ctx f { Spec.cache; shell; secrets; network = _ } = +let pp_run ~escape ~ctx f { Spec.cache; shell; secrets; network = _ } = Fmt.pf f "RUN %a%a%a" Fmt.(list (pp_mount_secret ~ctx ++ const string " ")) secrets Fmt.(list (pp_cache ~ctx ++ const string " ")) cache - pp_wrap shell + (pp_wrap ~escape) shell + +let is_root user = + user = (Spec.root_windows :> Spec.user) || user = (Spec.root_unix :> Spec.user) let pp_copy ~ctx f { Spec.from; src; dst; exclude = _ } = let from = match from with @@ -46,10 +57,11 @@ let pp_copy ~ctx f { Spec.from; src; dst; exclude = _ } = | `Context -> None in let chown = - if ctx.user = Spec.root then None + if is_root ctx.user then None else ( - let { Spec.uid; gid } = ctx.user in - Some (Printf.sprintf "%d:%d" uid gid) + match ctx.user with + | `Unix { uid; gid } -> Some (Printf.sprintf "%d:%d" uid gid) + | `Windows _ -> None ) in Fmt.pf f "COPY %a%a%a %s" @@ -72,30 +84,39 @@ let quote ~escape v = Buffer.add_substring buf v !j (len - !j); Buffer.contents buf -let pp_op ~buildkit ctx f : Spec.op -> ctx = function +let pp_op ~buildkit ~escape ctx f : Spec.op -> ctx = function | `Comment x -> Fmt.pf f "# %s" x; ctx | `Workdir x -> Fmt.pf f "WORKDIR %s" x; ctx | `Shell xs -> Fmt.pf f "SHELL [ %a ]" Fmt.(list ~sep:comma (quote string)) xs; ctx - | `Run x when buildkit -> pp_run ~ctx f x; ctx - | `Run x -> pp_run ~ctx f { x with cache = []; secrets = []}; ctx + | `Run x when buildkit -> pp_run ~escape ~ctx f x; ctx + | `Run x -> pp_run ~escape ~ctx f { x with cache = []; secrets = []}; ctx | `Copy x -> pp_copy ~ctx f x; ctx - | `User ({ uid; gid } as u) -> Fmt.pf f "USER %d:%d" uid gid; { user = u } - | `Env (k, v) -> Fmt.pf f "ENV %s=\"%s\"" k (quote ~escape:'\\' v); ctx + | `User (`Unix { uid; gid } as u) -> Fmt.pf f "USER %d:%d" uid gid; { user = u } + | `User (`Windows { name } as u) -> Fmt.pf f "USER %s" name; { user = u } + | `Env (k, v) -> Fmt.pf f "ENV %s=\"%s\"" k (quote ~escape v); ctx -let rec convert ~buildkit f (name, { Spec.child_builds; from; ops }) = +let rec convert ~buildkit ~escape ~ctx f (name, { Spec.child_builds; from; ops }) = child_builds |> List.iter (fun (name, spec) -> - convert ~buildkit f (Some name, spec); + convert ~buildkit ~escape ~ctx f (Some name, spec); Format.pp_print_newline f (); ); Fmt.pf f "@[FROM %s%a@]@." from Fmt.(option (const string " as " ++ string)) name; let (_ : ctx) = List.fold_left (fun ctx op -> Format.pp_open_hbox f (); - let ctx = pp_op ~buildkit ctx f op in + let ctx = pp_op ~buildkit ~escape ctx f op in Format.pp_close_box f (); Format.pp_print_newline f (); ctx - ) default_ctx ops + ) ctx ops in () -let dockerfile_of_spec ~buildkit t = - Fmt.str "%a" (convert ~buildkit) (None, t) +let dockerfile_of_spec ~buildkit ~os t = + Fmt.str "%a" (fun f -> + match os with + | `Windows -> + let ctx = { user = (Spec.root_windows :> Spec.user) } in + (Fmt.pf f "@[#escape=`@]@."; + convert ~buildkit ~escape:'`' ~ctx f) + | `Unix -> + let ctx = { user = (Spec.root_unix :> Spec.user) } in + convert ~buildkit ~escape:'\\' ~ctx f) (None, t) diff --git a/lib_spec/docker.mli b/lib_spec/docker.mli index 83fe91e4..c9dbf908 100644 --- a/lib_spec/docker.mli +++ b/lib_spec/docker.mli @@ -1,5 +1,6 @@ -val dockerfile_of_spec : buildkit:bool -> Spec.t -> string -(** [dockerfile_of_spec x] produces a Dockerfile that aims to be equivalent to [x]. +val dockerfile_of_spec : buildkit:bool -> os:[`Unix | `Windows] -> Spec.t -> string +(** [dockerfile_of_spec ~buildkit ~os x] produces a Dockerfile + that aims to be equivalent to [x]. However, note that: @@ -7,5 +8,7 @@ val dockerfile_of_spec : buildkit:bool -> Spec.t -> string you have a suitable ".dockerignore" file. - The conversion is not robust against malicious input, as the escaping rules are unclear. - @param buildkit If true, the extended BuildKit syntax is used to support caches. - If false, caches are ignored. *) + @param buildkit If true, the extended BuildKit syntax is used to + support caches. If false, caches are ignored. BuildKit syntax + isn't supported on Windows. + @param os Use UNIX or Windows syntax and idiosyncrasies. *) diff --git a/lib_spec/spec.ml b/lib_spec/spec.ml index ec004944..d79e1e21 100644 --- a/lib_spec/spec.ml +++ b/lib_spec/spec.ml @@ -56,8 +56,34 @@ let copy_inlined = function let copy_of_sexp x = copy_of_sexp (inflate_record copy_inlined x) let sexp_of_copy x = deflate_record copy_inlined (sexp_of_copy x) -type user = { uid : int; gid : int } -[@@deriving sexp] +type unix_user = { + uid : int; + gid : int; +} [@@deriving sexp] + +type windows_user = { + name : string; +} [@@deriving sexp] + +type user = [ + | `Unix of unix_user + | `Windows of windows_user +] [@@deriving sexp] + +let user_of_sexp x = + let open Sexplib.Sexp in + match x with + | List [List [Atom "name"; _]] -> + `Windows (windows_user_of_sexp x) + | List [List [Atom "uid"; _]; List [Atom "gid"; _]] -> + `Unix (unix_user_of_sexp x) + | x -> Fmt.failwith "Invalid op: %a" Sexplib.Sexp.pp_hum x + +let sexp_of_user x : Sexplib.Sexp.t = + let x = sexp_of_user x in + match x with + | List [Atom _os; List args] -> List args + | x -> Fmt.failwith "Invalid op: %a" Sexplib.Sexp.pp_hum x type run = { cache : Cache.t list [@sexp.list]; @@ -149,9 +175,12 @@ let shell xs = `Shell xs let run ?(cache=[]) ?(network=[]) ?(secrets=[]) fmt = fmt |> Printf.ksprintf (fun x -> `Run { shell = x; cache; network; secrets }) let copy ?(from=`Context) ?(exclude=[]) src ~dst = `Copy { from; src; dst; exclude } let env k v = `Env (k, v) -let user ~uid ~gid = `User { uid; gid } +let user_unix ~uid ~gid = `User (`Unix { uid; gid }) +let user_windows ~name = `User (`Windows { name }) -let root = { uid = 0; gid = 0 } +let root_unix = `Unix { uid = 0; gid = 0 } +let root_windows = `Windows { name = "ContainerAdministrator" } +let root = if Sys.win32 then root_windows else root_unix let rec pp_no_boxes f : Sexplib.Sexp.t -> unit = function | List xs -> Fmt.pf f "(%a)" (Fmt.list ~sep:Fmt.sp pp_no_boxes) xs diff --git a/lib_spec/spec.mli b/lib_spec/spec.mli index 338911f2..245f45a3 100644 --- a/lib_spec/spec.mli +++ b/lib_spec/spec.mli @@ -5,11 +5,20 @@ type copy = { exclude : string list; } [@@deriving sexp] -type user = { +type unix_user = { uid : int; - gid : int + gid : int; } [@@deriving sexp] +type windows_user = { + name : string; +} [@@deriving sexp] + +type user = [ + | `Unix of unix_user + | `Windows of windows_user +] [@@deriving sexp] + type run = { cache : Cache.t list; network : string list; @@ -41,8 +50,11 @@ val shell : string list -> op val run : ?cache:Cache.t list -> ?network:string list -> ?secrets:Secret.t list -> ('a, unit, string, op) format4 -> 'a val copy : ?from:[`Context | `Build of string] -> ?exclude:string list -> string list -> dst:string -> op val env : string -> string -> op -val user : uid:int -> gid:int -> op +val user_unix : uid:int -> gid:int -> op +val user_windows : name:string -> op +val root_unix : [`Unix of unix_user] +val root_windows : [`Windows of windows_user] val root : user val pp : t Fmt.t diff --git a/main.ml b/main.ml index dd1621d5..4193801d 100644 --- a/main.ml +++ b/main.ml @@ -2,8 +2,10 @@ open Lwt.Infix let ( / ) = Filename.concat -module Sandbox = Obuilder.Runc_sandbox -module Fetcher = Obuilder.Docker +module Runc_sandbox = Obuilder.Runc_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) (Runc_sandbox) (Docker_extract) in + Runc_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> + let builder = Builder.v ~store ~sandbox in + Builder ((module Builder), builder) + +let create_docker_builder 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,16 @@ 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) runc_conf docker_conf = + match sandbox with + | `Runc -> create_builder store_spec runc_conf + | `Docker -> create_docker_builder store_spec docker_conf + +let build () store spec runc_conf docker_conf src_dir secrets = Lwt_main.run begin - create_builder store conf >>= fun (Builder ((module Builder), builder)) -> + select_backend store runc_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) with Failure msg -> @@ -50,9 +66,11 @@ let build () store spec conf src_dir secrets = exit 1 end -let healthcheck () store conf = +let healthcheck () store runc_conf docker_conf = Lwt_main.run begin - create_builder store conf >>= fun (Builder ((module Builder), builder)) -> + select_backend store runc_conf docker_conf + >>= fun (Builder ((module Builder), builder)) -> + Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () -> Builder.healthcheck builder >|= function | Error (`Msg m) -> Fmt.epr "Healthcheck failed: %s@." m; @@ -61,16 +79,18 @@ let healthcheck () store conf = Fmt.pr "Healthcheck passed@." end -let delete () store conf id = +let delete () store runc_conf docker_conf id = Lwt_main.run begin - create_builder store conf >>= fun (Builder ((module Builder), builder)) -> + select_backend store runc_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 dockerfile () buildkit spec = +let dockerfile () buildkit escape spec = Sexplib.Sexp.load_sexp spec |> Obuilder_spec.t_of_sexp - |> Obuilder_spec.Docker.dockerfile_of_spec ~buildkit + |> Obuilder_spec.Docker.dockerfile_of_spec ~buildkit ~os:escape |> print_endline open Cmdliner @@ -124,13 +144,15 @@ let build = let doc = "Build a spec file." in let info = Cmd.info ~doc "build" in Cmd.v info - Term.(const build $ setup_log $ store $ spec_file $ Sandbox.cmdliner $ src_dir $ secrets) + Term.(const build $ setup_log $ store $ spec_file $ Runc_sandbox.cmdliner + $ Docker_sandbox.cmdliner $ src_dir $ secrets) let delete = let doc = "Recursively delete a cached build result." in let info = Cmd.info ~doc "delete" in Cmd.v info - Term.(const delete $ setup_log $ store $ Sandbox.cmdliner $ id) + Term.(const delete $ setup_log $ store $ Runc_sandbox.cmdliner + $ Docker_sandbox.cmdliner $ id) let buildkit = Arg.value @@ @@ -139,17 +161,27 @@ let buildkit = ~doc:"Output extended BuildKit syntax." ["buildkit"] +let escape = + let styles = [("unix", `Unix); ("windows", `Windows)] in + let doc = Arg.doc_alts_enum styles |> Printf.sprintf "Dockerfile escape style, must be %s." in + Arg.value @@ + Arg.opt Arg.(enum styles) (if Sys.unix then `Unix else `Windows) @@ + Arg.info ~doc + ~docv:"STYLE" + ["escape"] + let dockerfile = let doc = "Convert a spec to Dockerfile format." in let info = Cmd.info ~doc "dockerfile" in Cmd.v info - Term.(const dockerfile $ setup_log $ buildkit $ spec_file) + Term.(const dockerfile $ setup_log $ buildkit $ escape $ spec_file) let healthcheck = let doc = "Perform a self-test." in let info = Cmd.info ~doc "healthcheck" in Cmd.v info - Term.(const healthcheck $ setup_log $ store $ Sandbox.cmdliner) + Term.(const healthcheck $ setup_log $ store $ Runc_sandbox.cmdliner + $ Docker_sandbox.cmdliner) let cmds = [build; delete; dockerfile; healthcheck] diff --git a/obuilder.opam b/obuilder.opam index c3b31f58..8c39582f 100644 --- a/obuilder.opam +++ b/obuilder.opam @@ -21,16 +21,14 @@ depends: [ "sexplib" "ppx_deriving" "ppx_sexp_conv" - "sha" + "sha" {>= "1.15.1"} "sqlite3" + "crunch" {>= "3.3.1" & build} "obuilder-spec" {= version} - "ocaml" {>= "4.10.0"} + "ocaml" {>= "4.14.0"} "alcotest-lwt" {with-test} "odoc" {with-doc} ] -conflicts: [ - "result" {< "1.5"} -] build: [ ["dune" "subst"] {dev} [ diff --git a/static/extract.cmd b/static/extract.cmd new file mode 100644 index 00000000..c76450a8 --- /dev/null +++ b/static/extract.cmd @@ -0,0 +1,13 @@ +@echo off + +copy C:\cygwin64\bin\basename.exe %DESTINATION% +copy C:\cygwin64\bin\bash.exe %DESTINATION% +copy C:\cygwin64\bin\cygpath.exe %DESTINATION% +copy C:\cygwin64\bin\readlink.exe %DESTINATION% +copy C:\cygwin64\bin\tar.exe %DESTINATION% +copy 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 ( + echo Copying %%f + copy %%f %DESTINATION% +) diff --git a/static/manifest.bash b/static/manifest.bash new file mode 100755 index 00000000..0db61285 --- /dev/null +++ b/static/manifest.bash @@ -0,0 +1,159 @@ +# An implementation of the Manifest module in bash, to run inside +# Docker containers. Outputs a list of S-expressions representing a +# sequence of {Manifest.t}. + +# Depends on bash, basename, readlink, sha256sum. +# If running on Windows, also depends on cygpath. + +shopt -s dotglob nullglob + +# https://stackoverflow.com/a/8574392 +function mem() { + local e match="$1" + shift + for e; do [[ "$e" == "$match" ]] && return 0; done + return 1 +} + +# Filename.concat +function concat() { + local path=$1 + local dir_sep=$2 + local name=$3 + + if [[ -z "$path" ]]; then + printf "%s" "$name" + else + printf '%s%s%s' "$path" "$dir_sep" "$name" + fi +} + +# Cygwin's readlink outputs a Unix path, we prefer mixed paths. +function readlink_wrapper() { + local path + + if [[ "$OS" = "Windows_NT" ]]; then + if ! path="$(readlink -- "$1" | cygpath -m -f-)"; then + return 1 + fi + else + if ! path="$(readlink -- "$1")"; then + return 1 + fi + fi + printf "%s" "$path" +} + +function generate() { + local src=$1 + local path hash target + + path=$(concat "$src_dir" "$dir_sep" "$src") + if [[ -L "$path" ]]; then + if ! target=$(readlink_wrapper "$path"); then return 1; fi + printf '(Symlink ("%s" %s))' "$src" "$target" + elif [[ -d "$path" ]]; then + printf '(Dir ("%s" (' "$src" + for item in "$path"/*; do # Let's hope Bash file iteration is stable. + if ! item=$(basename -- "$item"); then return 1; fi + if ! mem "$item" "${exclude[@]}"; then + if ! generate "$(concat "$src" "$dir_sep" "$item")"; then + return 1 + fi + fi + done + printf ')))' + elif [[ -f "$path" ]]; then + if ! hash=$(sha256sum -- "$path"); then return 1; fi + printf '(File ("%s" %s))' "$src" "${hash:0:64}" + elif [[ ! -e "$path" ]]; then + printf 'File "%s" not found in source directory' "$src" 1>&2 + return 1 + else + printf 'Unsupported file type for "%s"' "$src" 1>&2 + return 1 + fi +} + +function check_path() { + local acc=$1; shift + local base=$1; shift + local segs=( "$@" ) + local x path + local -a xs + + x=${segs[0]} + xs=("${segs[@]:1}") + + if [[ ${#segs[@]} -eq 0 ]]; then + printf '%s' "$acc" + return 0 + elif [[ "$x" = "" || "$x" = "." ]]; then + check_path "$acc" "$base" "${xs[@]}" + elif [[ "$x" == ".." ]]; then + printf "Can't use .. in source paths!" 1>&2 + return 1 + elif [[ "$x" == *"$dir_sep"* ]]; then + printf "Can't use platform directory separator in path component: %s" "$x" 1>&2 + return 1 + else + path=$(concat "$base" "$dir_sep" "$x") + if [[ -z "$acc" ]]; then + acc="$x" + else + acc=$(concat "$acc" "$dir_sep" "$x") + fi + + if [[ ! -e "$path" ]]; then + return 2 + elif [[ -d "$path" && ! -L "$path" ]]; then + check_path "$acc" "$path" "${xs[@]}" + elif [[ (-f "$path" || -L "$path") && ${#xs[@]} -eq 0 ]]; then + printf '%s' "$acc" + return 0 + elif [[ -f "$path" ]]; then + printf 'Not a directory: %s' "$acc" 1>&2 + return 1 + else + printf 'Not a regular file: %s' "$x" 1>&2 + return 1 + fi + fi +} + +function main() { + local src src2 src3 + local -i exclude_length src_length + local -a srcs + + exclude_length=$1; shift + while (( exclude_length-- > 0 )); do + exclude+=( "$1" ); shift + done + src_length=$1; shift + while (( src_length-- > 0 )); do + srcs+=( "$1" ); shift + done + + for src1 in "${srcs[@]}"; do + IFS='/' read -r -a segs <<< "$src1" + src2=$(check_path "" "$src_dir" "${segs[@]}") + ret=$? + if [[ $ret -eq 1 ]]; then + printf ' (in "%s")' "$src1" 1>&2 + return 1 + elif [[ $ret -eq 2 ]]; then + src3="$(printf "$dir_sep%s" "${segs[@]}")" + printf 'Source path "%s" not found' "${src3:1}" 1>&2 + return 1 + elif ! generate "$src2"; then + return 1 + fi + done +} + +src_dir=$1; shift +dir_sep=$1; shift +declare -a exclude + +main "$@" diff --git a/stress/stress.ml b/stress/stress.ml index 9168f5cf..23ce63a8 100644 --- a/stress/stress.ml +++ b/stress/stress.ml @@ -16,26 +16,24 @@ let assert_str expected got = exit 1 ) -module Sandbox = Runc_sandbox -module Fetcher = Docker - module Test(Store : S.STORE) = struct let assert_output expected t id = - match Store.result t id with + Store.result t id >>= function | None -> Fmt.failwith "%S not in store!" id | Some path -> let ch = open_in (path / "output") in let data = really_input_string ch (in_channel_length ch) in close_in ch; - assert_str expected data + assert_str expected data; + Lwt.return_unit let test_store t = - assert (Store.result t "unknown" = None); + Store.result t "unknown" >>= fun r -> assert (r = None); (* Build without a base *) Store.delete t "base" >>= fun () -> Store.build t ~id:"base" (fun tmpdir -> write ~path:(tmpdir / "output") "ok" >|= Result.ok) >>= fun r -> assert (r = Ok ()); - assert_output "ok" t "base"; + assert_output "ok" t "base" >>= fun () -> (* Build with a base *) Store.delete t "sub" >>= fun () -> Store.build t ~base:"base" ~id:"sub" (fun tmpdir -> @@ -43,22 +41,22 @@ module Test(Store : S.STORE) = struct write ~path:(tmpdir / "output") (orig ^ "+") >|= Result.ok ) >>= fun r -> assert (r = Ok ()); - assert_output "ok+" t "sub"; + assert_output "ok+" t "sub" >>= fun () -> (* Test deletion *) - assert (Store.result t "sub" <> None); + Store.result t "sub" >>= fun r -> assert (r <> None); Store.delete t "sub" >>= fun () -> - assert (Store.result t "sub" = None); + Store.result t "sub" >>= fun r -> assert (r = None); (* A failing build isn't saved *) Store.delete t "fail" >>= fun () -> Store.build t ~id:"fail" (fun _tmpdir -> Lwt_result.fail `Failed) >>= fun r -> assert (r = Error `Failed); - assert (Store.result t "fail" = None); + Store.result t "fail" >>= fun r -> assert (r = None); Lwt.return_unit let test_cache t = let uid = Unix.getuid () in let gid = Unix.getgid () in - let user = { Spec.uid = 123; gid = 456 } in + let user = `Unix { Spec.uid = 123; gid = 456 } in let id = "c1" in (* Create a new cache *) Store.delete_cache t id >>= fun x -> @@ -66,7 +64,7 @@ module Test(Store : S.STORE) = struct Store.cache ~user t id >>= fun (c, r) -> assert ((Unix.lstat c).Unix.st_uid = 123); assert ((Unix.lstat c).Unix.st_gid = 456); - let user = { Spec.uid; gid } in + let user = `Unix { Spec.uid; gid } in Os.exec ["sudo"; "chown"; Printf.sprintf "%d:%d" uid gid; "--"; c] >>= fun () -> assert (Sys.readdir c = [| |]); write ~path:(c / "data") "v1" >>= fun () -> @@ -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)(Runc_sandbox)(Obuilder.Docker_extract) in + Runc_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox -> + let builder = Builder.v ~store ~sandbox in + Builder ((module Builder), builder) let n_steps = 4 let n_values = 3 @@ -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,19 @@ 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 (_, spec) conf = Lwt_main.run begin spec >>= fun (Store_spec.Store ((module Store), store)) -> let module T = Test(Store) in @@ -225,8 +228,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 $ Runc_sandbox.cmdliner) let () = (* Logs.(set_level (Some Info)); *) diff --git a/test/dummy.ml b/test/dummy.ml new file mode 100644 index 00000000..f04db4c1 --- /dev/null +++ b/test/dummy.ml @@ -0,0 +1,8 @@ +let () = + Printexc.record_backtrace true; + let str = "the quick brown fox jumps over the lazy dog" in + match Sys.argv.(1) with + | "stdin" -> if read_line () <> str then exit 1 + | "stdout" -> print_string str + | "stderr" -> prerr_string str + | _ -> invalid_arg "Sys.argv" diff --git a/test/dune b/test/dune index ac6f957e..c56d7242 100644 --- a/test/dune +++ b/test/dune @@ -1,7 +1,16 @@ +(copy_files ../static/manifest.bash) + +(executable + (name dummy) + (public_name dummy) + (package obuilder) + (modules dummy)) + (test - (name test) - (package obuilder) - (deps base.tar) - (libraries alcotest-lwt obuilder str logs.fmt)) + (name test) + (package obuilder) + (deps base.tar manifest.bash %{bin:dummy}) + (libraries alcotest-lwt obuilder str logs.fmt) + (modules log mock_exec mock_sandbox mock_store test)) (dirs :standard \ test1) diff --git a/test/mock_exec.ml b/test/mock_exec.ml index 799ff2ef..1fa810db 100644 --- a/test/mock_exec.ml +++ b/test/mock_exec.ml @@ -6,11 +6,21 @@ let ( / ) = Filename.concat let strf = Printf.sprintf +let unix_path path = + if Sys.win32 then + Lwt_process.pread ("", [| "cygpath"; "-u"; path|]) >|= fun str -> String.trim str + else + Lwt.return path + let next_container_id = ref 0 let base_tar = let mydir = Sys.getcwd () in - Lwt_main.run (Lwt_io.(with_file ~mode:input) (mydir / "base.tar") Lwt_io.read) + Lwt_main.run begin + let base_tar = mydir / "base.tar" in + (* unix_path (mydir / "base.tar") >>= fun base_tar -> *) + Lwt_io.(with_file ~mode:input) base_tar Lwt_io.read + end |> Bytes.of_string let with_fd x f = @@ -54,7 +64,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,9 +90,14 @@ let exec ?cwd ?stdin ?stdout ?stderr ~pp cmd = Fmt.pr "exec: %a@." Fmt.(Dump.array string) argv; begin match Array.to_list argv with | "docker" :: args -> exec_docker ?stdout args - | "sudo" :: ("tar" :: _ as tar) -> Os.default_exec ?cwd ?stdin ?stdout ~pp ("", Array.of_list tar) - | "sudo" :: "mkdir" :: args - | "mkdir" :: args -> mkdir args + | "sudo" :: "--" :: ("tar" :: _ as tar) when not Os.running_as_root -> + Os.default_exec ?cwd ?stdin ?stdout ~pp ("", Array.of_list tar) + | "tar" :: "-C" :: path :: opts when Os.running_as_root -> + unix_path path >>= fun path -> + let tar = (if Sys.win32 then "C:\\cygwin64\\bin\\tar.exe" else "tar") :: "-C" :: path :: opts in + Os.default_exec ?cwd ?stdin ?stdout ~pp ("", Array.of_list tar) + | "mkdir" :: args when Os.running_as_root -> mkdir args + | "sudo" :: "--" :: "mkdir" :: args when not Os.running_as_root -> mkdir args | x -> Fmt.failwith "Unknown mock command %a" Fmt.(Dump.list string) x end | (x, _) -> Fmt.failwith "Unexpected absolute path: %S" x diff --git a/test/mock_store.ml b/test/mock_store.ml index ec379ee8..9775543f 100644 --- a/test/mock_store.ml +++ b/test/mock_store.ml @@ -10,6 +10,12 @@ type t = { mutable builds : int; } +let unix_path path = + if Sys.win32 then + Lwt_process.pread ("", [| "cygpath"; "-u"; path|]) >|= fun str -> String.trim str + else + Lwt.return path + let delay_store = ref Lwt.return_unit let rec waitpid_non_intr pid = @@ -34,7 +40,8 @@ let build t ?base ~id fn = begin match base with | None -> Os.ensure_dir tmp_dir; Lwt.return_unit | Some base -> - Lwt_process.exec ("", [| "cp"; "-r"; t.dir / base; tmp_dir |]) >>= function + Lwt.both (unix_path (t.dir / base)) (unix_path tmp_dir) >>= fun (src, dst) -> + Lwt_process.exec ("", [| "cp"; "-r"; src; dst |]) >>= function | Unix.WEXITED 0 -> Lwt.return_unit | _ -> failwith "cp failed!" end >>= fun () -> @@ -45,6 +52,7 @@ let build t ?base ~id fn = Unix.rename tmp_dir dir; Lwt_result.return () | Error _ as e -> + unix_path tmp_dir >>= fun tmp_dir -> rm_r tmp_dir; Lwt.return e ) @@ -61,8 +69,11 @@ let path t id = t.dir / id let result t id = let dir = path t id in match Os.check_dir dir with - | `Present -> Some dir - | `Missing -> None + | `Present -> Lwt.return_some dir + | `Missing -> Lwt.return_none + +let log_file t id = + Lwt.return (t.dir / "logs" / (id ^ ".log")) let rec finish t = if t.builds > 0 then ( @@ -75,12 +86,13 @@ let with_store fn = Lwt_io.with_temp_dir ~prefix:"mock-store-" @@ fun dir -> let t = { dir; cond = Lwt_condition.create (); builds = 0 } in Obuilder.Os.ensure_dir (state_dir t); + Obuilder.Os.ensure_dir (t.dir / "logs"); Lwt.finalize (fun () -> fn t) (fun () -> finish t) let delete t id = - match result t id with + result t id >>= function | Some path -> rm_r path; Lwt.return_unit | None -> Lwt.return_unit @@ -103,3 +115,5 @@ let cache ~user:_ _t _ = assert false let delete_cache _t _ = assert false let complete_deletes _t = Lwt.return_unit + +let root t = t.dir diff --git a/test/test.ml b/test/test.ml index 1b94a226..9b19a9e0 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,10 +1,12 @@ 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 +let sprintf = Printf.sprintf +let root = if Sys.win32 then "C:/" else "/" let () = Logs.(set_level ~all:true (Some Info)); @@ -26,16 +28,27 @@ let with_config fn = Mock_store.with_store @@ fun store -> let sandbox = Mock_sandbox.create () in let builder = B.v ~store ~sandbox in + Fun.flip Lwt.finalize (fun () -> B.finish builder) @@ fun () -> let src_dir = Mock_store.state_dir store / "src" in Os.ensure_dir src_dir; fn ~src_dir ~store ~sandbox ~builder +let with_default_exec fn = + Lwt.finalize (fun () -> + Os.lwt_process_exec := Os.default_exec; + fn ()) + (fun () -> Os.lwt_process_exec := Mock_exec.exec; Lwt.return_unit) + +let with_file path flags perms fn = + Lwt_unix.openfile path flags perms >>= fun fd -> + Lwt.finalize (fun () -> fn fd) (fun () -> Lwt_unix.close fd) + let mock_op ?(result=Lwt_result.return ()) ?(delay_store=Lwt.return_unit) ?cancel ?output () = fun ~cancelled ?stdin:_ ~log (config:Obuilder.Config.t) dir -> Mock_store.delay_store := delay_store; let cmd = match config.argv with - | ["/bin/bash"; "-c"; cmd] -> cmd + | ["/bin/bash"; "-c"; cmd] | ["cmd"; "/S"; "/C"; cmd] -> cmd | x -> Fmt.str "%a" Fmt.(Dump.list string) x in Build_log.printf log "%s@." cmd >>= fun () -> @@ -64,23 +77,23 @@ let test_simple _switch () = B.build builder context spec >>!= get store "output" >>= fun result -> Alcotest.(check build_result) "Final result" (Ok "base-distro\nrunner") result; Log.check "Check log" - {|(from base) + (sprintf {|(from base) ;---> saved as .* - /: (run (shell Append)) + %s: (run (shell Append)) Append ;---> saved as .* - |} log; + |} root) log; (* Check result is cached *) Log.clear log; B.build builder context spec >>!= get store "output" >>= fun result -> Alcotest.(check build_result) "Final result cached" (Ok "base-distro\nrunner") result; Log.check "Check cached log" - {|(from base) + (sprintf {|(from base) ;---> using .* from cache - /: (run (shell Append)) + %s: (run (shell Append)) Append ;---> using .* from cache - |} log; + |} root) log; Lwt.return_unit let test_prune _switch () = @@ -93,12 +106,12 @@ let test_prune _switch () = B.build builder context spec >>!= get store "output" >>= fun result -> Alcotest.(check build_result) "Final result" (Ok "base-distro\nrunner") result; Log.check "Check log" - {|(from base) + (sprintf {|(from base) ;---> saved as .* - /: (run (shell Append)) + %s: (run (shell Append)) Append ;---> saved as .* - |} log; + |} root) log; let log id = Logs.info (fun f -> f "Deleting %S" id) in B.prune ~log builder ~before:start 10 >>= fun n -> Alcotest.(check int) "Nothing before start time" 0 n; @@ -131,26 +144,26 @@ let test_concurrent _switch () = Alcotest.(check build_result) "Final result" (Ok "AB") b1; Alcotest.(check build_result) "Final result" (Ok "AC") b2; Log.check "Check AB log" - {| (from base) + (sprintf {| (from base) ;---> saved as .* - /: (run (shell A)) + %s: (run (shell A)) A ;---> saved as .* - /: (run (shell B)) + %s: (run (shell B)) B ;---> saved as .* - |} + |} root root) log1; Log.check "Check AC log" - {| (from base) + (sprintf {| (from base) ;---> using .* from cache - /: (run (shell A)) + %s: (run (shell A)) A ;---> saved as .* - /: (run (shell C)) + %s: (run (shell C)) C ;---> saved as .* - |} + |} root root) log2; Lwt.return () @@ -175,18 +188,18 @@ let test_concurrent_failure _switch () = Alcotest.(check build_result) "B1 result" (Error (`Msg "Mock build failure")) b1; Alcotest.(check build_result) "B2 result" (Error (`Msg "Mock build failure")) b2; Log.check "Check AB log" - {| (from base) + (sprintf {| (from base) ;---> saved as .* - /: (run (shell A)) + %s: (run (shell A)) A - |} + |} root) log1; Log.check "Check AC log" - {| (from base) + (sprintf {| (from base) ;---> using .* from cache - /: (run (shell A)) + %s: (run (shell A)) A - |} + |} root) log2; Lwt.return () @@ -212,18 +225,18 @@ let test_concurrent_failure_2 _switch () = Alcotest.(check build_result) "B1 result" (Error (`Msg "Mock build failure")) b1; Alcotest.(check build_result) "B2 result" (Error (`Msg "Mock build failure")) b2; Log.check "Check AB log" - {| (from base) + (sprintf {| (from base) ;---> saved as .* - /: (run (shell A)) + %s: (run (shell A)) A - |} + |} root) log1; Log.check "Check AC log" - {| (from base) + (sprintf {| (from base) ;---> using .* from cache - /: (run (shell A)) + %s: (run (shell A)) A - |} + |} root) log2; Lwt.return () @@ -241,11 +254,11 @@ let test_cancel _switch () = b >>= fun result -> Alcotest.(check build_result) "Final result" (Error `Cancelled) result; Log.check "Check log" - {|(from base) + (sprintf {|(from base) ;---> saved as .* - /: (run (shell Wait)) + %s: (run (shell Wait)) Wait - |} log; + |} root) log; Lwt.return_unit (* Two users are sharing a build. One cancels. *) @@ -268,21 +281,21 @@ let test_cancel_2 _switch () = b1 >>= fun result1 -> Alcotest.(check build_result) "User 1 result" (Error `Cancelled) result1; Log.check "Check log" - {|(from base) + (sprintf {|(from base) ;---> saved as .* - /: (run (shell Wait)) + %s: (run (shell Wait)) Wait - |} log1; + |} root) log1; Lwt.wakeup set_r (Ok ()); b2 >>!= get store "output" >>= fun result2 -> Alcotest.(check build_result) "Final result" (Ok "ok") result2; Log.check "Check log" - {|(from base) + (sprintf {|(from base) ;---> using .* from cache - /: (run (shell Wait)) + %s: (run (shell Wait)) Wait ;---> saved as .* - |} log2; + |} root) log2; Lwt.return_unit (* Two users are sharing a build. Both cancel. *) @@ -305,20 +318,20 @@ let test_cancel_3 _switch () = b1 >>= fun result1 -> Alcotest.(check build_result) "User 1 result" (Error `Cancelled) result1; Log.check "Check log" - {|(from base) + (sprintf {|(from base) ;---> saved as .* - /: (run (shell Wait)) + %s: (run (shell Wait)) Wait - |} log1; + |} root) log1; Lwt_switch.turn_off switch2 >>= fun () -> b2 >>!= get store "output" >>= fun result2 -> Alcotest.(check build_result) "User 2 result" (Error `Cancelled) result2; Log.check "Check log" - {|(from base) + (sprintf {|(from base) ;---> using .* from cache - /: (run (shell Wait)) + %s: (run (shell Wait)) Wait - |} log2; + |} root) log2; r >>= fun r -> let r = Result.map (fun () -> "-") r in Alcotest.(check build_result) "Build cancelled" (Error `Cancelled) r; @@ -426,10 +439,10 @@ let test_tar_long_filename _switch () = (src_dir / filename) (fun ch -> Lwt_io.write ch "file-data") >>= fun () -> - Lwt_unix.openfile (dst_dir / "out.tar") [Lwt_unix.O_WRONLY; Lwt_unix.O_CREAT] 0 - >>= fun to_untar -> + with_file (dst_dir / "out.tar") Lwt_unix.[O_WRONLY; O_CREAT; O_CLOEXEC] 0 + @@ fun to_untar -> let src_manifest = Manifest.generate ~exclude:[] ~src_dir "." |> Result.get_ok in - let user = {Spec.uid=1000; gid=1000} in + let user = Spec.(`Unix { uid=1000; gid=1000 }) in Tar_transfer.send_file ~src_dir ~src_manifest @@ -439,7 +452,8 @@ let test_tar_long_filename _switch () = in do_test 80 >>= fun () -> do_test 160 >>= fun () -> - do_test 240 + (* Maximum path length on Windows is 260 characters. *) + do_test (260 - 1 (* NUL *) - String.length {|C:\cygwin64\tmp\test-copy-src-123456\|}) let sexp = Alcotest.of_pp Sexplib.Sexp.pp_hum @@ -485,10 +499,10 @@ let test_sexp () = (user (uid 1) (gid 2)) )|} -let test_docker () = +let test_docker_unix () = let test ~buildkit name expect sexp = let spec = Spec.t_of_sexp (Sexplib.Sexp.of_string sexp) in - let got = Obuilder_spec.Docker.dockerfile_of_spec ~buildkit spec in + let got = Obuilder_spec.Docker.dockerfile_of_spec ~buildkit ~os:`Unix spec in let expect = remove_indent expect in Alcotest.(check string) name expect got in @@ -582,6 +596,59 @@ let test_docker () = (shell "command1")) ) |} +let test_docker_windows () = + let test ~buildkit name expect sexp = + let spec = Spec.t_of_sexp (Sexplib.Sexp.of_string sexp) in + let got = Obuilder_spec.Docker.dockerfile_of_spec ~buildkit ~os:`Windows spec in + let expect = remove_indent expect in + Alcotest.(check string) name expect got + in + test ~buildkit:false "Dockerfile" + {| #escape=` + FROM base + # A test comment + WORKDIR C:/src + RUN command1 + SHELL [ "C:/Windows/System32/cmd.exe", "/c" ] + RUN command2 && ` + command3 + COPY a b c + COPY a b c + ENV DEBUG="1" + USER Zaphod + COPY a b c + |} {| + ((from base) + (comment "A test comment") + (workdir C:/src) + (run (shell "command1")) + (shell C:/Windows/System32/cmd.exe /c) + (run + (cache (a (target /data)) + (b (target /srv))) + (shell "command2 && + command3")) + (copy (src a b) (dst c)) + (copy (src a b) (dst c) (exclude .git _build)) + (env DEBUG 1) + (user (name Zaphod)) + (copy (src a b) (dst c)) + ) |}; + test ~buildkit:false "Multi-stage" + {| #escape=` + FROM base as tools + RUN make tools + + FROM base + COPY --from=tools binary /usr/local/bin/ + |} {| + ((build tools + ((from base) + (run (shell "make tools")))) + (from base) + (copy (from (build tools)) (src binary) (dst /usr/local/bin/)) + ) |} + let manifest = Alcotest.result (Alcotest.testable @@ -590,48 +657,85 @@ let manifest = (Alcotest.of_pp (fun f (`Msg m) -> Fmt.string f m)) (* Test copy step. *) -let test_copy _switch () = - Lwt_io.with_temp_dir ~prefix:"test-copy-" @@ fun src_dir -> +let test_copy generate = + Lwt_io.with_temp_dir ~prefix:"test-copy-bash-" @@ fun src_dir -> Lwt_io.(with_file ~mode:output) (src_dir / "file") (fun ch -> Lwt_io.write ch "file-data") >>= fun () -> + let root = if Sys.unix then "/root" else "C:/Windows" in (* Files *) let f1hash = Sha256.string "file-data" in - Alcotest.(check manifest) "File" (Ok (`File ("file", f1hash))) - @@ Manifest.generate ~exclude:[] ~src_dir "file"; - Alcotest.(check manifest) "File" (Ok (`File ("file", f1hash))) - @@ Manifest.generate ~exclude:[] ~src_dir "./file"; - Alcotest.(check manifest) "File" (Ok (`File ("file", f1hash))) - @@ Manifest.generate ~exclude:[] ~src_dir "/file"; - Alcotest.(check manifest) "Missing" (Error (`Msg {|Source path "file2" not found|})) - @@ Manifest.generate ~exclude:[] ~src_dir "file2"; - Alcotest.(check manifest) "Not dir" (Error (`Msg {|Not a directory: file (in "file/file2")|})) - @@ Manifest.generate ~exclude:[] ~src_dir "file/file2"; - Alcotest.(check manifest) "Parent" (Error (`Msg {|Can't use .. in source paths! (in "../file")|})) - @@ Manifest.generate ~exclude:[] ~src_dir "../file"; + generate ~exclude:[] ~src_dir "file" >>= fun r -> + Alcotest.(check manifest) "File" (Ok (`File ("file", f1hash))) r; + generate ~exclude:[] ~src_dir "./file" >>= fun r -> + Alcotest.(check manifest) "File relative" (Ok (`File ("file", f1hash))) r; + generate ~exclude:[] ~src_dir "/file" >>= fun r -> + Alcotest.(check manifest) "File absolute" (Ok (`File ("file", f1hash))) r; + generate ~exclude:[] ~src_dir "file2" >>= fun r -> + Alcotest.(check manifest) "Missing" (Error (`Msg {|Source path "file2" not found|})) r; + generate ~exclude:[] ~src_dir "file/file2" >>= fun r -> + Alcotest.(check manifest) "Not dir" (Error (`Msg {|Not a directory: file (in "file/file2")|})) r; + generate ~exclude:[] ~src_dir "../file" >>= fun r -> + Alcotest.(check manifest) "Parent" (Error (`Msg {|Can't use .. in source paths! (in "../file")|})) r; (* Symlinks *) - Unix.symlink "/root" (src_dir / "link"); - Alcotest.(check manifest) "Link" (Ok (`Symlink (("link", "/root")))) - @@ Manifest.generate ~exclude:[] ~src_dir "link"; - Alcotest.(check manifest) "Follow link" (Error (`Msg {|Not a regular file: link (in "link/file")|})) - @@ Manifest.generate ~exclude:[] ~src_dir "link/file"; + Unix.symlink ~to_dir:true root (src_dir / "link"); + generate ~exclude:[] ~src_dir "link" >>= fun r -> + Alcotest.(check manifest) "Link" (Ok (`Symlink (("link", root)))) r; + generate ~exclude:[] ~src_dir "link/file" >>= fun r -> + Alcotest.(check manifest) "Follow link" (Error (`Msg {|Not a regular file: link (in "link/file")|})) r; (* Directories *) + generate ~exclude:["file"] ~src_dir "" >>= fun r -> Alcotest.(check manifest) "Tree" - (Ok (`Dir ("", [`Symlink ("link", "/root")]))) - @@ Manifest.generate ~exclude:["file"] ~src_dir ""; + (Ok (`Dir ("", [`Symlink ("link", root)]))) r; + generate ~exclude:[] ~src_dir "." >>= fun r -> Alcotest.(check manifest) "Tree" (Ok (`Dir ("", [`File ("file", f1hash); - `Symlink ("link", "/root")]))) - @@ Manifest.generate ~exclude:[] ~src_dir "."; + `Symlink ("link", root)]))) r; Unix.mkdir (src_dir / "dir1") 0o700; Unix.mkdir (src_dir / "dir1" / "dir2") 0o700; Lwt_io.(with_file ~mode:output) (src_dir / "dir1" / "dir2" / "file2") (fun ch -> Lwt_io.write ch "file2") >>= fun () -> let f2hash = Sha256.string "file2" in - Alcotest.(check manifest) "Nested file" (Ok (`File ("dir1/dir2/file2", f2hash))) - @@ Manifest.generate ~exclude:[] ~src_dir "dir1/dir2/file2"; + generate ~exclude:[] ~src_dir "dir1/dir2/file2" >>= fun r -> + Alcotest.(check manifest) "Nested file" (Ok (`File ("dir1/dir2/file2", f2hash))) r; + generate ~exclude:[] ~src_dir "dir1" >>= fun r -> Alcotest.(check manifest) "Tree" - (Ok (`Dir ("dir1", [`Dir ("dir1/dir2", [`File ("dir1/dir2/file2", f2hash)])]))) - @@ Manifest.generate ~exclude:[] ~src_dir "dir1"; + (Ok (`Dir ("dir1", [`Dir ("dir1/dir2", [`File ("dir1/dir2/file2", f2hash)])]))) r; Lwt.return_unit +(* Test the Manifest module. *) +let test_copy_ocaml _switch () = + test_copy (fun ~exclude ~src_dir src -> Lwt_result.lift (Manifest.generate ~exclude ~src_dir src)) + +(* Test the manifest.bash script. *) +let test_copy_bash _switch () = + 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) @@ -666,23 +770,45 @@ let test_secrets_simple _switch () = Alcotest.(check build_result) "Final result" (Ok "base-distro\nrunner") result; Log.check "Check b log" {| (from base) - ;---> saved as .* + ;---> saved as ".*" /: (run (secrets (test (target /testsecret)) (test2 (target /run/secrets/test2))) - ........(shell Append)) + [ ]+(shell Append)) Append - ;---> saved as .* + ;---> saved as ".*" |} log; Lwt.return_unit +let test_exec_nul _switch () = + with_default_exec @@ fun () -> + let args = ["dummy"; "stdout"] in + Os.exec ~stdout:`Dev_null ~stderr:`Dev_null args >>= fun actual -> + Alcotest.(check unit) "stdout" actual (); + let args = ["dummy"; "stderr"] in + Os.exec ~stdout:`Dev_null ~stderr:`Dev_null args >|= fun actual -> + Alcotest.(check unit) "stderr" actual () + +let test_pread_nul _switch () = + with_default_exec @@ fun () -> + let expected = "the quick brown fox jumps over the lazy dog" in + let args = ["dummy"; "stdout"] in + Os.pread ~stderr:`Dev_null args >|= fun actual -> + Alcotest.(check string) "stdout" actual expected + let () = let open Alcotest_lwt in Lwt_main.run begin + let manifest = + test_case "Copy using manifest.bash" `Quick test_copy_bash :: + 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; test_case_sync "Cache ID" `Quick test_cache_id; - test_case_sync "Docker" `Quick test_docker; + test_case_sync "Docker Windows" `Quick test_docker_windows; + test_case_sync "Docker UNIX" `Quick test_docker_unix; ]; "build", [ test_case "Simple" `Quick test_simple; @@ -704,8 +830,10 @@ let () = "tar_transfer", [ test_case "Long filename" `Quick test_tar_long_filename; ]; - "manifest", [ - test_case "Copy" `Quick test_copy; + "manifest", manifest; + "process", [ + test_case "Execute a process" `Quick test_exec_nul; + test_case "Read stdout of a process" `Quick test_pread_nul; ]; ] end