WIP tar_lwt_unix gzip functions

dune-project

@@ -46,7 +46,7 @@
  (tags ("org:xapi-project" "org:mirage"))
  (depends
   (ocaml (>= 4.08.0))
-  lwt
+  (lwt (>= 5.7.0))
   (tar (= :version))
  )
 )

unix/dune

@@ -1,5 +1,5 @@
 (library
  (name tar_unix)
  (public_name tar-unix)
- (libraries tar lwt lwt.unix)
+ (libraries tar tar_gz lwt lwt.unix)
  (wrapped false))

unix/tar_lwt_unix.ml

@@ -105,12 +105,16 @@ let run t fd =
       run x >>= fun value -> run (f value) in
   run t
 
-let fold f filename init =
+let with_in filename f =
   let open Lwt_result.Infix in
   safe Lwt_unix.(openfile filename [ O_RDONLY ]) 0 >>= fun fd ->
-  Lwt.finalize
-    (fun () -> run (Tar.fold f init) fd)
-    (fun () -> safe_close fd)
+  Lwt.finalize (fun () -> f fd) (fun () -> safe_close fd)
+
+let fold f filename init =
+  with_in filename (fun fd -> run (Tar.fold f init) fd)
+
+let fold_gz f filename init =
+  with_in filename (fun fd -> run (Tar_gz.in_gzipped (Tar.fold f init)) fd)
 
 let unix_err_to_msg = function
   | `Unix (e, f, s) ->
@@ -131,13 +135,10 @@ let copy ~dst_fd len =
   in
   read_write ~dst_fd len
 
-let extract ?(filter = fun _ -> true) ~src dst =
+let extract ~filter dst =
   let safe_close fd =
     let open Lwt.Infix in
-    Lwt.catch
-      (fun () -> Lwt_unix.close fd)
-      (fun _ -> Lwt.return_unit)
-    >|= Result.ok in
+    safe_close fd >|= Result.ok in
   let f ?global:_ hdr () =
     let ( let* ) = Tar.( let* ) in
     match filter hdr, hdr.Tar.Header.link_indicator with
@@ -158,7 +159,12 @@ let extract ?(filter = fun _ -> true) ~src dst =
       let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in
       Tar.return (Ok ())
   in
-  fold f src ()
+  Tar.fold f ()
+
+let extract ?(filter = fun _ -> true) ~src dst =
+  with_in src (fun fd -> run (extract ~filter dst) fd)
+and extract_gz ?(filter = fun _ -> true) ~src dst =
+  with_in src (fun fd -> run (Tar_gz.in_gzipped (extract ~filter dst)) fd)
 
 (** Return the header needed for a particular file on disk *)
 let header_of_file ?level file =
@@ -296,3 +302,7 @@ let create ?level ?global ?(filter = fun _ -> true) ~src dst =
        copy_files src >>= fun () ->
        write_end dst_fd)
     (fun () -> safe_close dst_fd)
+
+let create_gz ?level:_ ?global:_ ?filter:_ ~src:_ _dst =
+  (* TODO *)
+  assert false

unix/tar_lwt_unix.mli

@@ -37,6 +37,13 @@ val fold :
   ('a, [> decode_error ] as 'err, t) Tar.t) ->
   string -> 'a -> ('a, 'err) result Lwt.t
 
+(** [fold_gz f filename acc] is like [fold f filename acc] working on a gzip
+    compressed tar archive. *)
+val fold_gz :
+  (?global:Tar.Header.Extended.t -> Tar.Header.t -> 'a ->
+  ('a, [> decode_error | Tar_gz.error ] as 'err, t) Tar.t) ->
+  string -> 'a -> ('a, 'err) result Lwt.t
+
 (** [extract ~filter ~src dst] extracts the tar archive [src] into the
     directory [dst]. If [dst] does not exist, it is created. If [filter] is
     provided (defaults to [fun _ -> true]), any file where [filter hdr] returns
@@ -46,6 +53,13 @@ val extract :
   src:string -> string ->
   (unit, [> `Exn of exn | decode_error ]) result Lwt.t
 
+(** [extract_gz ~filter ~src dst] is like [extract ~filter ~src dst] extracting
+    a gzip compressed archive. *)
+val extract_gz :
+  ?filter:(Tar.Header.t -> bool) ->
+  src:string -> string ->
+  (unit, [> `Exn of exn | decode_error | Tar_gz.error ]) result Lwt.t
+
 (** [create ~level ~filter ~src dst] creates a tar archive at [dst]. It uses
     [src], a directory name, as input. If [filter] is provided
     (defaults to [fun _ -> true]), any file where [filter hdr] returns [false]
@@ -56,6 +70,14 @@ val create : ?level:Tar.Header.compatibility ->
   src:string -> string ->
   (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t
 
+(** [create_gz ~level ~filter ~src dst] is like [create ~level ~filter ~src
+    dst] creating a gzip compressed archive. *)
+val create_gz : ?level:Tar.Header.compatibility ->
+  ?global:Tar.Header.Extended.t ->
+  ?filter:(Tar.Header.t -> bool) ->
+  src:string -> string ->
+  (unit, [ `Msg of string | `Unix of (Unix.error * string * string) | Tar_gz.error ]) result Lwt.t
+
 (** [header_of_file ~level filename] returns the tar header of [filename]. *)
 val header_of_file : ?level:Tar.Header.compatibility -> string ->
   (Tar.Header.t, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t