diff --git a/mirage/config.ml b/mirage/config.ml index 4369a8f..b223b7e 100644 --- a/mirage/config.ml +++ b/mirage/config.ml @@ -38,8 +38,8 @@ let mirror = package ~max:"0.0.5" "git-kv" ; package ~min:"3.10.0" "git-paf" ; package "opam-file-format" ; - package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ; - package ~min:"2.2.0" "tar-mirage" ; + package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ~pin:"https://github.com/mirage/ocaml-tar.git#da4b1eb9fb903b3e6641b09e712156bd4a826f84"; + package ~min:"2.2.0" "tar-mirage" ~pin:"https://github.com/mirage/ocaml-tar.git#da4b1eb9fb903b3e6641b09e712156bd4a826f84"; package ~max:"0.2.0" "mirage-block-partition" ; package "oneffs" ; ] diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index 0a4cb34..1a76120 100644 --- a/mirage/unikernel.ml +++ b/mirage/unikernel.ml @@ -778,62 +778,73 @@ module Make end module Tarball = struct - module Async = struct - type 'a t = 'a - let ( >>= ) x f = f x - let return x = x + module High : sig + type t + type 'a s = 'a Lwt.t + + external inj : 'a s -> ('a, t) Tar.io = "%identity" + external prj : ('a, t) Tar.io -> 'a s = "%identity" + end = struct + type t + type 'a s = 'a Lwt.t + + external inj : 'a -> 'b = "%identity" + external prj : 'a -> 'b = "%identity" end - module Writer = struct - type out_channel = Buffer.t - type 'a t = 'a - let really_write buf data = - Buffer.add_string buf (Cstruct.to_string data) - end + let to_buffer buf t = + let rec run : type a. (a, [> `Msg of string ] as 'err, High.t) Tar.t -> (a, 'err) result Lwt.t + = function + | Tar.Write str -> + Buffer.add_string buf str; + Lwt.return_ok () + | Tar.Read _ -> assert false + | Tar.Really_read _ -> assert false + | Tar.Seek _ -> assert false + | Tar.Return value -> Lwt.return value + | Tar.High value -> High.prj value + | Tar.Bind (x, f) -> + let open Lwt_result.Infix in + run x >>= fun value -> run (f value) in + run t - (* That's not very interesting here, we just ignore everything*) - module Reader = struct - type in_channel = unit - type 'a t = 'a - let really_read _in _data = () - let skip _in _len = () - let read _in _data = 0 - end + let once data = + let closed = ref false in + fun () -> if !closed + then Tar.High (High.inj (Lwt.return_ok None)) + else begin closed := true; Tar.High (High.inj (Lwt.return_ok (Some data))) end - module Tar_Gz = Tar_gz.Make (Async)(Writer)(Reader) + let entries_of_git ~mtime store repo = + Git.find_contents store >>= fun paths -> + let entries = Lwt_stream.of_list paths in + let to_entry path = + Store.get store path >|= function + | Ok data -> + let data = + if Mirage_kv.Key.(equal path (v "repo")) + then repo else data in + let file_mode = 0o644 + and mod_time = Int64.of_int mtime + and user_id = 0 + and group_id = 0 + and size = String.length data in + let hdr = Tar.Header.make ~file_mode ~mod_time ~user_id ~group_id + (Mirage_kv.Key.to_string path) (Int64.of_int size) in + Some (None, hdr, once data) + | Error _ -> None in + let entries = Lwt_stream.filter_map_s to_entry entries in + Lwt.return begin fun () -> Tar.High (High.inj (Lwt_stream.get entries >|= Result.ok)) end let of_git repo store = - let out_channel = Buffer.create 1024 in let now = Ptime.v (Pclock.now_d_ps ()) in let mtime = Option.value ~default:0 Ptime.(Span.to_int_s (to_span now)) in - let gz_out = - Tar_Gz.of_out_channel ~level:4 ~mtime:(Int32.of_int mtime) - Gz.Unix out_channel - in - Git.find_contents store >>= fun paths -> - Lwt_list.iter_s (fun path -> - Store.get store path >|= function - | Ok data -> - let data = - if Mirage_kv.Key.(equal path (v "repo")) then repo else data - in - let file_mode = 0o644 (* would be great to retrieve the actual one - but not needed (since opam-repository doesn't use it anyways)! *) - and mod_time = Int64.of_int mtime - and user_id = 0 - and group_id = 0 - and size = String.length data - in - let hdr = - Tar.Header.make ~file_mode ~mod_time ~user_id ~group_id - (Mirage_kv.Key.to_string path) (Int64.of_int size) - in - let o = ref false in - let stream () = if !o then None else (o := true; Some data) in - Tar_Gz.write_block ~level:Tar.Header.Ustar hdr gz_out stream - | Error e -> Logs.warn (fun m -> m "Store error: %a" Store.pp_error e)) - paths >|= fun () -> - Tar_Gz.write_end gz_out; - Buffer.contents out_channel + entries_of_git ~mtime store repo >>= fun entries -> + let t = Tar.out entries in + let t = Tar_gz.out_gzipped ~level:4 ~mtime:(Int32.of_int mtime) Gz.Unix t in + let buf = Buffer.create 1024 in + to_buffer buf t >|= function + | Ok () -> Buffer.contents buf + | Error (`Msg msg) -> failwith msg end module Serve = struct