Updates to container-image

dune

@@ -3,7 +3,7 @@
   (name main)
   (package obuilder)
   (preprocess (pps ppx_deriving.show))
-  (libraries lwt lwt.unix fmt fmt.cli fmt.tty tar-unix obuilder cmdliner logs.fmt logs.cli))
+  (libraries lwt lwt.unix fmt fmt.cli fmt.tty tar-unix obuilder cmdliner logs.fmt logs.cli eio_main))
 
 
 ; (rule

dune-project

@@ -42,6 +42,8 @@
   fpath
   (extunix (>= 0.4.0))
   (ocaml (>= 4.14.1))
+  eio_main
+  container-image
   (alcotest-lwt (and (>= 1.7.0) :with-test))))
 
 (package

lib/container_image_extract.mli

@@ -0,0 +1,10 @@
+(** Fetching of base images as .tar.gz archives *)
+
+module Make (_ : sig
+    val fs : Eio.Fs.dir_ty Eio.Path.t
+    val net : [ `Generic ] Eio.Net.ty Eio.Net.t 
+    val domain_mgr : Eio.Domain_manager.ty Eio.Domain_manager.t
+    val progress : bool
+end) : sig
+  include S.FETCHER
+end

lib/dune

@@ -28,4 +28,4 @@
   (public_name obuilder)
   (preprocess (pps ppx_sexp_conv))
   (flags (:standard -w -69))
-  (libraries fpath lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner extunix))
+  (libraries fpath lwt lwt.unix fmt yojson tar-unix sexplib sqlite3 astring logs sha obuilder-spec cmdliner extunix container-image xdg))

lib/obuilder.ml

@@ -20,6 +20,7 @@ module Docker_store = Docker_store
 module Zfs_clone = Zfs_clone
 module Docker_extract = Docker.Extract
 module Archive_extract = Archive_extract
+module Container_image_extract = Container_image_extract
 
 (** {2 Sandboxes} *)
 

main.ml

@@ -17,9 +17,16 @@ let log tag msg =
   | `Note -> Fmt.pr "%a@." Fmt.(styled (`Fg `Yellow) string) msg
   | `Output -> output_string stdout msg; flush stdout
 
-let create_builder store_spec conf =
+let create_builder env store_spec conf =
+  let module T = struct
+    let fs = Eio.Stdenv.fs env
+    let net = (Eio.Stdenv.net env :> [`Generic] Eio.Net.ty Eio.Net.t)
+    let domain_mgr = Eio.Stdenv.domain_mgr env
+    let progress = true
+  end in
+  let module Fetcher = Obuilder.Container_image_extract.Make (T) in
   store_spec >>= fun (Store_spec.Store ((module Store), store)) ->
-  let module Builder = Obuilder.Builder (Store) (Native_sandbox) (Docker_extract) in
+  let module Builder = Obuilder.Builder (Store) (Native_sandbox) (Fetcher) in
   Native_sandbox.create ~state_dir:(Store.state_dir store / "sandbox") conf >|= fun sandbox ->
   let builder = Builder.v ~store ~sandbox in
   Builder ((module Builder), builder)
@@ -37,14 +44,14 @@ let read_whole_file path =
   let len = in_channel_length ic in
   really_input_string ic len
 
-let select_backend (sandbox, store_spec) native_conf docker_conf =
+let select_backend env (sandbox, store_spec) native_conf docker_conf =
   match sandbox with
-  | `Native -> create_builder store_spec native_conf
+  | `Native -> create_builder env store_spec native_conf
   | `Docker -> create_docker_builder store_spec docker_conf
 
-let build () store spec native_conf docker_conf src_dir secrets =
+let build env () store spec native_conf docker_conf src_dir secrets =
   Lwt_main.run begin
-    select_backend store native_conf docker_conf
+    select_backend env store native_conf docker_conf
     >>= fun (Builder ((module Builder), builder)) ->
     Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
     let spec =
@@ -67,9 +74,9 @@ let build () store spec native_conf docker_conf src_dir secrets =
       exit 1
   end
 
-let run () (_, store) conf id =
+let run env () (_, store) conf id =
   Lwt_main.run begin
-    create_builder store conf >>= fun (Builder ((module Builder), builder)) ->
+    create_builder env store conf >>= fun (Builder ((module Builder), builder)) ->
     Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
     let _, v = Builder.shell builder id in
     v >>= fun v -> match v with
@@ -82,9 +89,9 @@ let run () (_, store) conf id =
       exit 1
   end
 
-let healthcheck () store native_conf docker_conf =
+let healthcheck env () store native_conf docker_conf =
   Lwt_main.run begin
-    select_backend store native_conf docker_conf
+    select_backend env store native_conf docker_conf
     >>= fun (Builder ((module Builder), builder)) ->
     Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
     Builder.healthcheck builder >|= function
@@ -95,17 +102,17 @@ let healthcheck () store native_conf docker_conf =
       Fmt.pr "Healthcheck passed@."
   end
 
-let delete () store native_conf docker_conf id =
+let delete env () store native_conf docker_conf id =
   Lwt_main.run begin
-    select_backend store native_conf docker_conf
+    select_backend env store native_conf docker_conf
     >>= fun (Builder ((module Builder), builder)) ->
     Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ fun () ->
     Builder.delete builder id ~log:(fun id -> Fmt.pr "Removing %s@." id)
   end
 
-let clean () store native_conf docker_conf =
+let clean env () store native_conf docker_conf =
   Lwt_main.run begin
-    select_backend store native_conf docker_conf
+    select_backend env store native_conf docker_conf
     >>= fun (Builder ((module Builder), builder)) ->
     Fun.flip Lwt.finalize (fun () -> Builder.finish builder) @@ begin fun () ->
       let now = Unix.(gmtime (gettimeofday ())) in
@@ -167,25 +174,25 @@ let secrets =
      ~docv:"SECRET"
      ["secret"])
 
-let build =
+let build env =
   let doc = "Build a spec file." in
   let info = Cmd.info "build" ~doc in
   Cmd.v info
-    Term.(const build $ setup_log $ store $ spec_file $ Native_sandbox.cmdliner
+    Term.(const (build env) $ setup_log $ store $ spec_file $ Native_sandbox.cmdliner
           $ Docker_sandbox.cmdliner $ src_dir $ secrets)
 
-let delete =
+let delete env =
   let doc = "Recursively delete a cached build result." in
   let info = Cmd.info "delete" ~doc in
   Cmd.v info
-    Term.(const delete $ setup_log $ store $ Native_sandbox.cmdliner
+    Term.(const (delete env) $ setup_log $ store $ Native_sandbox.cmdliner
           $ Docker_sandbox.cmdliner $ id)
 
-let clean =
+let clean env =
   let doc = "Clean all cached build results." in
   let info = Cmd.info "clean" ~doc in
   Cmd.v info
-    Term.(const clean $ setup_log $ store $ Native_sandbox.cmdliner
+    Term.(const (clean env) $ setup_log $ store $ Native_sandbox.cmdliner
           $ Docker_sandbox.cmdliner)
 
 let buildkit =
@@ -210,22 +217,24 @@ let dockerfile =
   Cmd.v info
     Term.(const dockerfile $ setup_log $ buildkit $ escape $ spec_file)
 
-let healthcheck =
+let healthcheck env =
   let doc = "Perform a self-test" in
   let info = Cmd.info "healthcheck" ~doc in
   Cmd.v info
-    Term.(const healthcheck $ setup_log $ store $ Native_sandbox.cmdliner
+    Term.(const (healthcheck env) $ setup_log $ store $ Native_sandbox.cmdliner
           $ Docker_sandbox.cmdliner)
 
-let run =
+let run env =
   let doc = "Run a shell inside a container" in
   let info = Cmd.info "run" ~doc in
   Cmd.v info
-    Term.(const run $ setup_log $ store $ Native_sandbox.cmdliner $ id)
+    Term.(const (run env) $ setup_log $ store $ Native_sandbox.cmdliner $ id)
 
-let cmds = [build; run; delete; clean; dockerfile; healthcheck]
+let cmds env = [build env; run env; delete env; clean env; dockerfile; healthcheck env]
 
 let () =
+  Eio_main.run @@ fun env ->
+  Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
   let doc = "a command-line interface for OBuilder" in
   let info = Cmd.info ~doc "obuilder" in
-  exit (Cmd.eval @@ Cmd.group info cmds)
+  exit (Cmd.eval @@ Cmd.group info (cmds env))

obuilder.opam

@@ -42,6 +42,8 @@ depends: [
   "fpath"
   "extunix" {>= "0.4.0"}
   "ocaml" {>= "4.14.1"}
+  "eio_main"
+  "container-image"
   "alcotest-lwt" {>= "1.7.0" & with-test}
   "odoc" {with-doc}
 ]
@@ -60,3 +62,6 @@ build: [
   ]
 ]
 dev-repo: "git+https://github.com/ocurrent/obuilder.git"
+pin-depends:[
+  [ "container-image.dev" "file:./vendor/container-image" ]
+]

obuilder.opam.template

@@ -0,0 +1,3 @@
+pin-depends:[
+  [ "container-image.dev" "file:./vendor/container-image" ]
+]

vendor/container-image/bin/main.ml

@@ -14,6 +14,13 @@ let platform =
     @@ info ~doc:"Set platform if server is multi-platform capable"
          [ "platform" ])
 
+let checkout_directory =
+  Arg.(
+    value
+    @@ opt (some dir) None
+    @@ info ~doc:"The directory to checkout the image to."
+         [ "checkout-directory" ])
+
 let image =
   let open Container_image in
   let image = Arg.conv (Image.of_string, Image.pp) in
@@ -136,10 +143,16 @@ let list () =
   PrintBox_text.output stdout box;
   Fmt.pr "\n%!"
 
-let checkout () image =
+let checkout () image path =
   Eio_main.run @@ fun env ->
   let cache = cache env in
-  let root = Eio.Stdenv.cwd env in
+  let root =
+    match path with
+    | None -> Eio.Stdenv.cwd env
+    | Some path ->
+        let fs = Eio.Stdenv.fs env in
+        Eio.Path.(fs / path)
+  in
   let image = Container_image.Cache.Manifest.guess cache image in
   Container_image.checkout ~cache ~root image
 
@@ -171,7 +184,9 @@ let list_term = Term.(const list $ setup)
 let list_cmd = Cmd.v (Cmd.info "list" ~version) list_term
 
 let checkout_cmd =
-  Cmd.v (Cmd.info "checkout" ~version) Term.(const checkout $ setup $ image_id)
+  Cmd.v
+    (Cmd.info "checkout" ~version)
+    Term.(const checkout $ setup $ image_id $ checkout_directory)
 
 let show_cmd =
   Cmd.v (Cmd.info "show" ~version) Term.(const show $ setup $ image_id)

vendor/container-image/src/checkout.ml

@@ -20,6 +20,10 @@ let bytes_to_size ?(decimals = 2) ppf = function
       let r = n /. Float.pow 1024. i in
       Format.fprintf ppf "%.*f %s" decimals r sizes.(int_of_float i)
 
+
+external lchown : string -> int -> int -> unit = "container_image_unix_lchown"
+external lchmod : string -> int -> unit = "container_image_unix_lchmod"
+
 let checkout_layer ~sw ~cache layer dir =
   let fd = Cache.Blob.get_fd ~sw cache layer in
   let fd = Tar_eio_gz.of_source fd in
@@ -29,41 +33,65 @@ let checkout_layer ~sw ~cache layer dir =
     (fun hdr src () ->
       let path = dir / hdr.file_name in
       mkdir_parent path;
-      Eio.Switch.run @@ fun sw ->
-      let dst =
-        Eio.Path.open_out ~sw ~append:false ~create:(`If_missing hdr.file_mode)
-          path
-      in
-      Eio.Flow.copy src dst;
-      Fmt.pr "%s (%s, %a)\n%!" hdr.file_name
-        (Tar.Header.Link.to_string hdr.link_indicator)
-        (bytes_to_size ~decimals:2)
-        hdr.file_size)
+      let file_mode = hdr.file_mode in
+      let () = 
+        match hdr.link_indicator with
+        | Directory -> Eio.Path.mkdir ~perm:file_mode path
+        | Symbolic ->
+          Eio_unix.run_in_systhread ~label:"symlink" (fun () -> Unix.symlink hdr.link_name (Eio.Path.native_exn path))
+        | _ ->
+            Eio.Switch.run @@ fun sw ->
+            let dst =
+              Eio.Path.open_out ~sw ~append:false ~create:(`If_missing file_mode)
+                path
+            in
+            Eio.Flow.copy src dst;
+        in
+        Eio_unix.run_in_systhread ~label:"lchown+chmod+utimes" (fun () ->
+          let path = Eio.Path.native_exn path in
+          lchown path hdr.user_id hdr.group_id;
+          (* For setting the user bit etc. *)
+          (if hdr.link_indicator <> Symbolic then lchmod path file_mode);
+          (* Setting times *)
+          let access_time = 
+            Option.value ~default:0. @@
+            Option.bind hdr.extended (fun e -> Option.map Int64.to_float e.access_time) 
+          in
+          let mod_time = hdr.mod_time |> Int64.to_float in
+          (if hdr.link_indicator <> Symbolic then Unix.utimes path access_time mod_time)
+        )
+      )
     fd ()
 
 let checkout_layers ~sw ~cache ~dir layers =
-  List.iteri
-    (fun i layer ->
-      let dir = Eio.Path.(dir / string_of_int i) in
-      let d = Descriptor.digest layer in
-      checkout_layer ~sw ~cache d dir)
-    layers
+  match layers with
+  | [ layer ] ->
+    let d = Descriptor.digest layer in
+    checkout_layer ~sw ~cache d dir
+  | layers ->
+    List.iteri
+      (fun i layer ->
+        let dir = Eio.Path.(dir / string_of_int i) in
+        let d = Descriptor.digest layer in
+        checkout_layer ~sw ~cache d dir)
+      layers
 
 let checkout_docker_manifest ~sw ~cache ~dir m =
   checkout_layers ~sw ~cache ~dir (Manifest.Docker.layers m)
 
 let checkout_oci_manifest ~sw ~cache ~dir m =
   checkout_layers ~sw ~cache ~dir (Manifest.OCI.layers m)
 
-let checkout_docker_manifests ~sw ~cache ~dir ds =
+let checkout_docker_manifests ~sw ~cache ~dir img ds =
   let ms =
     List.map
       (fun d ->
         let digest = Descriptor.digest d in
-        let str = Cache.Blob.get_string cache digest in
-        match Manifest.Docker.of_string str with
-        | Ok m -> m
-        | Error (`Msg e) -> failwith e)
+        let img = Image.v ~digest img in
+        let manifest = Cache.Manifest.get cache img in
+        match manifest with
+        | `Docker_manifest mani -> mani
+        | _ -> failwith "Exptected single docker manifest")
       ds
   in
   List.iteri
@@ -89,17 +117,20 @@ let checkout_oci_manifests ~sw ~cache ~dir ds =
       checkout_oci_manifest ~sw ~cache ~dir m)
     ms
 
-let checkout_docker_manifest_list ~sw ~cache ~dir l =
-  checkout_docker_manifests ~sw ~cache ~dir (Manifest_list.manifests l)
+let checkout_docker_manifest_list ~sw ~cache ~dir img l =
+  checkout_docker_manifests ~sw ~cache ~dir img (Manifest_list.manifests l)
 
 let checkout_oci_index ~sw ~cache ~dir i =
   checkout_oci_manifests ~sw ~cache ~dir (Index.manifests i)
 
-let checkout ~cache ~root i =
-  let dir = root / Image.to_string i in
+let checkout ?(only_rootfs=false) ~cache ~root i =
+  let dir = 
+    if only_rootfs then root else root / Image.to_string i 
+  in
   Eio.Switch.run @@ fun sw ->
   match Cache.Manifest.get cache i with
   | `Docker_manifest m -> checkout_docker_manifest ~sw ~cache ~dir m
-  | `Docker_manifest_list m -> checkout_docker_manifest_list ~sw ~cache ~dir m
+  | `Docker_manifest_list m ->
+      checkout_docker_manifest_list ~sw ~cache ~dir (Image.repository i) m
   | `OCI_index i -> checkout_oci_index ~sw ~cache ~dir i
   | `OCI_manifest m -> checkout_oci_manifest ~sw ~cache ~dir m

vendor/container-image/src/container_image.ml

@@ -2,6 +2,7 @@ module Spec = Container_image_spec
 module Cache = Cache
 module Image = Image
 module List = Ls
+module Util = Util
 
 let fetch = Fetch.fetch
 let list = List.list