Update the unikernel with the new version of tar

This commit is contained in:
Calascibetta Romain 2024-07-31 14:54:26 +02:00
parent c2ffbdb891
commit 8fc8f1c62d
2 changed files with 61 additions and 50 deletions

View file

@ -38,8 +38,8 @@ let mirror =
package ~max:"0.0.5" "git-kv" ; package ~max:"0.0.5" "git-kv" ;
package ~min:"3.10.0" "git-paf" ; package ~min:"3.10.0" "git-paf" ;
package "opam-file-format" ; package "opam-file-format" ;
package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ; package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ~pin:"https://github.com/mirage/ocaml-tar.git#da4b1eb9fb903b3e6641b09e712156bd4a826f84";
package ~min:"2.2.0" "tar-mirage" ; 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 ~max:"0.2.0" "mirage-block-partition" ;
package "oneffs" ; package "oneffs" ;
] ]

View file

@ -778,62 +778,73 @@ module Make
end end
module Tarball = struct module Tarball = struct
module Async = struct module High : sig
type 'a t = 'a type t
let ( >>= ) x f = f x type 'a s = 'a Lwt.t
let return x = x
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 end
module Writer = struct let to_buffer buf t =
type out_channel = Buffer.t let rec run : type a. (a, [> `Msg of string ] as 'err, High.t) Tar.t -> (a, 'err) result Lwt.t
type 'a t = 'a = function
let really_write buf data = | Tar.Write str ->
Buffer.add_string buf (Cstruct.to_string data) Buffer.add_string buf str;
end 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*) let once data =
module Reader = struct let closed = ref false in
type in_channel = unit fun () -> if !closed
type 'a t = 'a then Tar.High (High.inj (Lwt.return_ok None))
let really_read _in _data = () else begin closed := true; Tar.High (High.inj (Lwt.return_ok (Some data))) end
let skip _in _len = ()
let read _in _data = 0
end
module Tar_Gz = Tar_gz.Make (Async)(Writer)(Reader) let entries_of_git ~mtime store repo =
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 -> Git.find_contents store >>= fun paths ->
Lwt_list.iter_s (fun path -> let entries = Lwt_stream.of_list paths in
let to_entry path =
Store.get store path >|= function Store.get store path >|= function
| Ok data -> | Ok data ->
let data = let data =
if Mirage_kv.Key.(equal path (v "repo")) then repo else data if Mirage_kv.Key.(equal path (v "repo"))
in 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)! *) let file_mode = 0o644
and mod_time = Int64.of_int mtime and mod_time = Int64.of_int mtime
and user_id = 0 and user_id = 0
and group_id = 0 and group_id = 0
and size = String.length data and size = String.length data in
in let hdr = Tar.Header.make ~file_mode ~mod_time ~user_id ~group_id
let hdr = (Mirage_kv.Key.to_string path) (Int64.of_int size) in
Tar.Header.make ~file_mode ~mod_time ~user_id ~group_id Some (None, hdr, once data)
(Mirage_kv.Key.to_string path) (Int64.of_int size) | Error _ -> None in
in let entries = Lwt_stream.filter_map_s to_entry entries in
let o = ref false in Lwt.return begin fun () -> Tar.High (High.inj (Lwt_stream.get entries >|= Result.ok)) end
let stream () = if !o then None else (o := true; Some data) in
Tar_Gz.write_block ~level:Tar.Header.Ustar hdr gz_out stream let of_git repo store =
| Error e -> Logs.warn (fun m -> m "Store error: %a" Store.pp_error e)) let now = Ptime.v (Pclock.now_d_ps ()) in
paths >|= fun () -> let mtime = Option.value ~default:0 Ptime.(Span.to_int_s (to_span now)) in
Tar_Gz.write_end gz_out; entries_of_git ~mtime store repo >>= fun entries ->
Buffer.contents out_channel 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 end
module Serve = struct module Serve = struct