Repository: mirage/ocaml-tar
Pull request #146 (2024-05-15 12:48:06)

New tar gz
This PR is the continuity of #140 and #143. It adds the support to make a `*.tar.gz` archive. I extended the GADT and introduce the `Write` operation. Then, it just matters of composition between the `('a, 'err, 't) Tar.t` and the `decompress` layer.


Patch:
diff --git a/bin/dune b/bin/dune
index ad0a49e..eaf47cd 100644
--- a/bin/dune
+++ b/bin/dune
@@ -2,4 +2,4 @@
  (name otar)
  (public_name otar)
  (package tar-unix)
- (libraries unix tar.gz))
+ (libraries unix tar.gz tar_unix))
diff --git a/bin/otar.ml b/bin/otar.ml
index 33de886..59c3245 100644
--- a/bin/otar.ml
+++ b/bin/otar.ml
@@ -16,75 +16,72 @@
 
 let () = Printexc.record_backtrace true
 
-module Tar_gz = Tar_gz.Make
-  (struct type 'a t = 'a
-          let ( >>= ) x f = f x
-          let return x = x end)
-  (struct type out_channel = Stdlib.out_channel
-          type 'a io = 'a
-          let really_write oc str =
-            output_string oc str end)
-  (struct type in_channel = Stdlib.in_channel
-          type 'a io = 'a
-          let read ic buf =
-            input ic buf 0 (Bytes.length buf)
-        end)
-
-
 let ( / ) = Filename.concat
 
-let stream_of_fd fd =
-  let buf = Bytes.create 0x1000 in
-  fun () -> match Unix.read fd buf 0 (Bytes.length buf) with
-  | 0 -> None
-  | len ->
-    let str = Bytes.sub_string buf 0 len in
-    Some str
-  | exception End_of_file -> None
+let contents_of_path path =
+  let fd = ref `None in
+  let buf = Bytes.create 0x100 in
+  let rec dispenser () = match !fd with
+  | `Closed -> Tar.return (Ok None)
+  | `None ->
+    let fd' = Unix.openfile path Unix.[ O_RDONLY; O_CLOEXEC ] 0o644 in
+    fd := `Active fd';
+    dispenser ()
+  | `Active fd' ->
+    match Unix.read fd' buf 0 (Bytes.length buf) with
+    | 0 | exception End_of_file ->
+      Unix.close fd'; fd := `Closed; Tar.return (Ok None)
+    | len ->
+      let str = Bytes.sub_string buf 0 len in
+      Tar.return (Ok (Some str)) in
+  dispenser
 
-let always x = fun _ -> x
+let to_stream lst =
+  let lst = ref lst in
+  fun () -> match !lst with
+  | [] -> None
+  | x :: r -> lst := r; Some x
 
-let create_tarball directory oc =
+let create_tarball directory fd =
   let files = Sys.readdir directory in
   let os = match Sys.os_type with
     | "Win32" -> Gz.NTFS (* XXX(dinosaure): true? *)
     | "Unix" | "Cygwin" | _ -> Gz.Unix in
   let mtime = Unix.gettimeofday () in
-  let out_channel = Tar_gz.of_out_channel ~level:4 ~mtime:(Int32.of_float mtime) os oc in
-  let hdr = Tar.Header.make ~file_mode:0o755
-      ~mod_time:(Int64.of_float mtime) (Filename.concat directory "") 0L in
-  (match Tar_gz.write_block ~level:Tar.Header.Ustar hdr out_channel (always None) with
-   | Ok () -> ()
-   | Error `Msg msg -> Format.eprintf "Error %s writing block\n%!" msg);
-  Array.iter begin fun filename ->
-  let fd        = Unix.openfile (directory / filename) Unix.[ O_RDONLY; O_CLOEXEC ] 0o644 in
-  let stat      = Unix.LargeFile.lstat (directory / filename) in
-  match stat.st_kind with
-  | Unix.S_REG ->
-    let stream    = stream_of_fd fd in
-    let file_mode = if stat.Unix.LargeFile.st_perm land 0o111 <> 0 then 0o755 else 0o644 in
-    let mod_time  = Int64.of_float stat.Unix.LargeFile.st_mtime in
-    let user_id   = stat.Unix.LargeFile.st_uid in
-    let group_id  = stat.Unix.LargeFile.st_gid in
-    let hdr = Tar.Header.make
+  let dir_hdr = Tar.Header.make ~file_mode:0o755
+    ~mod_time:(Int64.of_float mtime) (Filename.concat directory "") 0L in
+  let dir_entry = (None, dir_hdr, (fun () -> Tar.return (Ok None))) in
+  let entries = Array.fold_left begin fun acc filename ->
+    let stat        = Unix.LargeFile.stat (directory / filename) in
+    match stat.st_kind with
+    | Unix.S_REG ->
+      let file_mode = if stat.st_perm land 0o111 <> 0 then 0o755 else 0o644 in
+      let mod_time  = Int64.of_float stat.Unix.LargeFile.st_mtime in
+      let user_id   = stat.st_uid in
+      let group_id  = stat.st_gid in
+      let level     = Some Tar.Header.Ustar in
+      let hdr       = Tar.Header.make
         ~file_mode ~mod_time ~user_id ~group_id
-        (directory / filename) stat.Unix.LargeFile.st_size in
-    (match Tar_gz.write_block ~level:Tar.Header.Ustar hdr out_channel stream with
-     | Ok () -> ()
-     | Error `Msg msg -> Format.eprintf "Error %s writing block\n%!" msg);
-    Unix.close fd ;
-  | _ ->
-    Format.eprintf "Skipping non-regular file %s\n" (Filename.concat directory filename)
-  end files ;
-  Tar_gz.write_end out_channel
+        (directory / filename) stat.st_size in
+      (level, hdr, contents_of_path (directory / filename)) :: acc
+    | _ -> acc end [] files in
+  let entries = to_stream (dir_entry :: entries) in
+  let entries () = Tar.return (Ok (entries ())) in
+  let t = Tar.out ~level:Tar.Header.Ustar entries in
+  let t = Tar_gz.out_gzipped ~level:4 ~mtime:(Int32.of_float mtime) os t in
+  match Tar_unix.run t fd with
+  | Ok () -> ()
+  | Error err ->
+    Format.eprintf "%s: %a\n%!" Sys.executable_name Tar_unix.pp_error err
 
 let make directory oc =
-  let oc, oc_close, _gz = match oc with
-    | None -> stdout, ignore, false
+  let fd, fd_close = match oc with
+    | None -> Unix.stdout, ignore
     | Some filename ->
-      let oc = open_out filename in
-      oc, (fun () -> close_out oc), Filename.extension filename = ".gz" in
-  create_tarball directory oc ; oc_close ()
+      let fd = Unix.openfile filename Unix.[ O_TRUNC; O_CREAT; O_WRONLY; O_CLOEXEC ] 0o644 in
+      fd, (fun () -> Unix.close fd) in
+  Fun.protect ~finally:fd_close @@ fun () ->
+  create_tarball directory fd
 
 let sizes = [| "B"; "KiB"; "MiB"; "GiB"; "TiB"; "PiB"; "EiB"; "ZiB"; "YiB" |]
 
@@ -97,27 +94,28 @@ let bytes_to_size ?(decimals = 2) ppf = function
       Format.fprintf ppf "%.*f %s" decimals r sizes.(int_of_float i)
 
 let list filename =
-  let ic = open_in filename in
-  let ic = Tar_gz.of_in_channel ~internal:(De.bigstring_create 0x1000) ic in
-  let rec go global () = match Tar_gz.HeaderReader.read ~global ic with
-    | Ok (hdr, global) ->
-      Format.printf "%s (%s, %a)\n%!"
-        hdr.Tar.Header.file_name
-        (Tar.Header.Link.to_string hdr.link_indicator)
-        (bytes_to_size ~decimals:2) hdr.Tar.Header.file_size ;
-      (* Alternatively:
-           let padding = Tar.Header.compute_zero_padding_length hdr in
-           let data = Int64.to_int hdr.Tar.Header.file_size in
-           let to_skip = data + padding in *)
-      let to_skip = Tar.Header.(Int64.to_int (to_sectors hdr) * length) in
-      Tar_gz.skip ic to_skip ;
-      go global ()
-    | Error `Eof -> ()
-    | Error `Fatal e ->
-      Format.eprintf "Error listing archive: %a\n%!" Tar.pp_error e;
-      exit 2
+  let go ?global:_ hdr () =
+    Format.printf "%s (%s, %a)\n%!"
+      hdr.Tar.Header.file_name
+      (Tar.Header.Link.to_string hdr.link_indicator)
+      (bytes_to_size ~decimals:2) hdr.Tar.Header.file_size ;
+    let open Tar in
+    let* _ = seek (Int64.to_int hdr.Tar.Header.file_size) in
+    return (Ok ())
   in
-  go None ()
+  let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0 in
+  match Tar_unix.run (Tar_gz.in_gzipped (Tar.fold go ())) fd with
+  | Ok () -> ()
+  | Error (`Unix _) ->
+    Format.eprintf "Some UNIX error occurred.\n%!"
+  | Error (`Msg e) ->
+    Format.eprintf "Some error: %s.\n%!" e
+  | Error (`Unexpected_end_of_file | `Eof) ->
+    Format.eprintf "Unexpected end of file.\n%!"
+  | Error `Gz err ->
+    Format.eprintf "Some Gzip error occurred: %s.\n%!" err
+  | Error (`Fatal _) ->
+    Format.eprintf "Some fatal error occurred.\n%!"
 
 let () = match Sys.argv with
   | [| _; "list"; filename; |] when Sys.file_exists filename ->
diff --git a/dune-project b/dune-project
index 480654e..ab04d55 100644
--- a/dune-project
+++ b/dune-project
@@ -89,7 +89,7 @@
  (tags ("org:xapi-project" "org:mirage"))
  (depends
   (ocaml (>= 5.00.0))
-  (eio (and (>= 0.10.0) (< 0.12)))
+  (eio (and (>= 1.1) (< 1.2)))
   (tar (= :version))
  )
 )
diff --git a/eio/tar_eio.ml b/eio/tar_eio.ml
index d1d07c3..d0fae0b 100644
--- a/eio/tar_eio.ml
+++ b/eio/tar_eio.ml
@@ -18,42 +18,64 @@
 
 open Eio
 
-module Monad = struct
-  type 'a t = 'a
-  let (>>=) a f = f a
-  let return = Fun.id
-end
+module High : sig
+  type t
+  type 'a s = 'a
 
-module Io = struct
-  type in_channel = Flow.source
-  type 'a io = 'a
-  let really_read f b =
-    let len = Bytes.length b in
-    let cs = Cstruct.create len in
-    Flow.read_exact f cs;
-    Cstruct.blit_to_bytes cs 0 b 0 len
-  let skip f (n: int) =
-    let buffer_size = 32768 in
-    let buffer = Cstruct.create buffer_size in
-    let rec loop (n: int) =
-      if n <= 0 then ()
-      else
-        let amount = min n buffer_size in
-        let block = Cstruct.sub buffer 0 amount in
-        Flow.read_exact f block;
-        loop (n - amount) in
-    loop n
+  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
 
-  type out_channel = Flow.sink
-  let really_write f str = Flow.write f [ Cstruct.of_string str ]
+  external inj : 'a -> 'b = "%identity"
+  external prj : 'b -> 'a = "%identity"
 end
 
-let really_read = Flow.read_exact
-let skip = Io.skip
-let really_write f b = Flow.write f [ b ]
+type t = High.t
+
+let value v = Tar.High (High.inj v)
 
-module HeaderReader = Tar.HeaderReader(Monad)(Io)
-module HeaderWriter = Tar.HeaderWriter(Monad)(Io)
+let run_read_only t f =
+  let rec run : type a. (a, 'err, t) Tar.t -> (a, 'err) result = function
+    | Tar.Write _ -> assert false
+    | Tar.Read len ->
+      let b = Cstruct.create len in
+      (match Flow.single_read f b with
+       | len ->
+         Ok (Cstruct.to_string ~len b)
+       | exception End_of_file ->
+         (* XXX: should we catch other exceptions?! *)
+         Error `Unexpected_end_of_file)
+    | Tar.Really_read len ->
+      let b = Cstruct.create len in
+      (try
+         Flow.read_exact f b;
+         Ok (Cstruct.to_string b)
+       with End_of_file -> Error `Unexpected_end_of_file)
+    | Tar.Seek n ->
+      let buffer_size = 32768 in
+      let buffer = Cstruct.create buffer_size in
+      let rec loop (n: int) =
+        if n <= 0 then Ok ()
+        else
+          let amount = min n buffer_size in
+          let block = Cstruct.sub buffer 0 amount in
+          Flow.read_exact f block;
+          loop (n - amount) in
+      loop n
+    | Tar.Return value -> value
+    | Tar.High value -> High.prj value
+    | Tar.Bind (x, f) ->
+      match run x with
+      | Ok value -> run (f value)
+      | Error _ as err -> err in
+  run t
+
+let fold f filename init =
+  (* XXX(reynir): ??? *)
+  Eio.Path.with_open_in filename
+    (run_read_only (Tar.fold f init))
 
 (* Eio needs a non-file-opening stat. *)
 let stat path =
@@ -79,3 +101,28 @@ let header_of_file ?level ?getpwuid ?getgrgid filepath : Tar.Header.t =
   let devminor    = if level = Ustar then stat.rdev |> Int64.to_int else 0 in
   Tar.Header.make ~file_mode ~user_id ~group_id ~mod_time ~link_indicator ~link_name
                   ?uname ?gname ~devmajor ~devminor (snd filepath) file_size
+let extract ?filter:(_ = fun _ -> true) ~src:_ _dst =
+  (* TODO *)
+  failwith "TODO"
+
+let create ?level:_ ?global:_ ?filter:(_ = fun _ -> true) ~src:_ _dst =
+  (* TODO *)
+  failwith "TODO"
+
+let append_file ?level:_ ?header:_ _filename _dst =
+  (* TODO *)
+  failwith "TODO"
+
+let write_header ?level:_ _hdr _fl =
+  (* TODO *)
+  failwith "TODO"
+
+let write_global_extended_header ?level:_ _global _fl =
+  (* TODO *)
+  failwith "TODO"
+
+let write_end fl =
+  let zero_block = Cstruct.of_string Tar.Header.zero_block in
+  (* TODO: catch exceptions?! *)
+  Eio.Flow.write fl [ zero_block; zero_block ];
+  Ok ()
diff --git a/eio/tar_eio.mli b/eio/tar_eio.mli
index 3c44aea..e2877fc 100644
--- a/eio/tar_eio.mli
+++ b/eio/tar_eio.mli
@@ -16,17 +16,20 @@
 
 (** I/O for tar-formatted data *)
 
-val really_read: Eio.Flow.source -> Cstruct.t -> unit
-(** [really_read fd buf] fills [buf] with data from [fd] or fails
-    with {!Stdlib.End_of_file}. *)
+type t
 
-val really_write: Eio.Flow.sink -> Cstruct.t -> unit
-(** [really_write fd buf] writes the full contents of [buf] to
-    [fd] or fails with {!Stdlib.End_of_file}. *)
+val value : ('a, 'err) result -> ('a, 'err, t) Tar.t
 
-val skip : Eio.Flow.source -> int -> unit
-(** [skip fd n] reads [n] bytes from [fd] and discards them. If possible, you
-    should use [Lwt_unix.lseek fd n Lwt_unix.SEEK_CUR] instead. *)
+val run_read_only : ('a, [> `Unexpected_end_of_file] as 'b, t) Tar.t -> [> `R ] Eio.Flow.source -> ('a, 'b) result
+
+val fold :
+  (?global:Tar.Header.Extended.t ->
+   Tar.Header.t ->
+   'a ->
+   ('a, [> `Fatal of Tar.error | `Unexpected_end_of_file ] as 'b, t) Tar.t) ->
+  Eio.Fs.dir_ty Eio.Path.t ->
+  'a ->
+  ('a, 'b) result
 
 (** Return the header needed for a particular file on disk. [getpwuid] and [getgrgid] are optional
     functions that should take the uid and gid respectively and return the passwd and group entry
@@ -35,8 +38,33 @@ val header_of_file :
     ?level:Tar.Header.compatibility ->
     ?getpwuid:(int64 -> string) ->
     ?getgrgid:(int64 -> string) ->
-    Eio.Fs.dir Eio.Path.t ->
+    Eio.Fs.dir_ty Eio.Path.t ->
     Tar.Header.t
 
-module HeaderReader : Tar.HEADERREADER with type in_channel = Eio.Flow.source and type 'a io = 'a
-module HeaderWriter : Tar.HEADERWRITER with type out_channel = Eio.Flow.sink and type 'a io = 'a
+val extract : ?filter:(Tar.Header.t -> bool) ->
+  src:Eio.Fs.dir_ty Eio.Path.t ->
+  Eio.Fs.dir_ty Eio.Path.t ->
+  (unit, _) result
+
+val create : ?level:Tar.Header.compatibility ->
+  ?global:Tar.Header.Extended.t ->
+  ?filter:(Tar.Header.t -> bool) ->
+  src:Eio.Fs.dir_ty Eio.Path.t ->
+  Eio.Fs.dir_ty Eio.Path.t ->
+  (unit, _) result
+
+val append_file : ?level:Tar.Header.compatibility ->
+  ?header:Tar.Header.t ->
+  Eio.Fs.dir_ty Eio.Path.t ->
+  [> `W ] Eio.Flow.sink ->
+  (unit, _) result
+
+val write_header : ?level:Tar.Header.compatibility ->
+  Tar.Header.t -> [> `W ] Eio.Flow.sink ->
+  (unit, _) result
+
+val write_global_extended_header : ?level:Tar.Header.compatibility ->
+  Tar.Header.Extended.t -> [> `W ] Eio.Flow.sink ->
+  (unit, _) result
+
+val write_end : [> `W ] Eio.Flow.sink -> (unit, _) result
diff --git a/lib/tar.ml b/lib/tar.ml
index cda2780..fe01e93 100644
--- a/lib/tar.ml
+++ b/lib/tar.ml
@@ -510,12 +510,11 @@ module Header = struct
   let checksum x : int64 =
     (* Sum of all the byte values of the header with the checksum field taken
        as 8 ' ' (spaces) *)
-    assert (String.length x >= length);
     let result = ref 0 in
     let in_checksum_range i =
       i >= hdr_chksum_off && i < hdr_chksum_off + sizeof_hdr_chksum
     in
-    for i = 0 to length - 1 do
+    for i = 0 to String.length x - 1 do
       let v =
         if in_checksum_range i then
           int_of_char ' '
@@ -578,11 +577,6 @@ module Header = struct
   (** Marshal a header block, computing and inserting the checksum *)
   let marshal ?level c (x: t) =
     let level = compatibility level in
-    let* () =
-      if Bytes.length c < length then
-        Error (`Msg "buffer too short")
-      else Ok ()
-    in
     (* The caller (e.g. write_block) is expected to insert the extra ././@LongLink header *)
     let* () =
       if String.length x.file_name > sizeof_hdr_file_name && level <> GNU then
@@ -667,230 +661,243 @@ module Header = struct
     Int64.(div (add (pred (of_int length)) x.file_size) (of_int length))
 end
 
-module type ASYNC = sig
-  type 'a t
-  val ( >>= ): 'a t -> ('a -> 'b t) -> 'b t
-  val return: 'a -> 'a t
-end
-
-module type READER = sig
-  type in_channel
-  type 'a io
-  val really_read: in_channel -> bytes -> unit io
-  val skip: in_channel -> int -> unit io
-end
-
-module type WRITER = sig
-  type out_channel
-  type 'a io
-  val really_write: out_channel -> string -> unit io
-end
-
-module type HEADERREADER = sig
-  type in_channel
-  type 'a io
-  val read : global:Header.Extended.t option -> in_channel ->
-    (Header.t * Header.Extended.t option, [ `Eof | `Fatal of [ `Checksum_mismatch | `Corrupt_pax_header | `Unmarshal of string ] ]) result io
-end
-
-module type HEADERWRITER = sig
-  type out_channel
-  type 'a io
-  val write : ?level:Header.compatibility -> Header.t -> out_channel -> (unit, [> `Msg of string ]) result io
-  val write_global_extended_header : Header.Extended.t -> out_channel -> (unit, [> `Msg of string ]) result io
-end
-
 let longlink = "././@LongLink"
 
-module HeaderReader(Async: ASYNC)(Reader: READER with type 'a io = 'a Async.t) = struct
-  open Async
-  open Reader
-
-  type in_channel = Reader.in_channel
-  type 'a io = 'a t
-
-  (* This is not a bind, but more a lift and bind combined. *)
-  let ( let^* ) x f =
-    match x with
-    | Ok x -> f x
-    | Error _ as e -> return e
-
-  let fix_link_indicator x =
-    (* For backward compatibility we treat normal files ending in slash as
-       directories. Because [Link.of_char] treats unrecognized link indicator
-       values as normal files we check directly. This is not completely correct
-       as [Header.Link.of_char] turns unknown link indicators into
-       [Header.Link.Normal]. Ideally, it should only be done for '0' and
-       '\000'. *)
-    if String.length x.Header.file_name > 0
-    && x.file_name.[String.length x.file_name - 1] = '/'
-    && x.link_indicator = Header.Link.Normal then
-      { x with link_indicator = Header.Link.Directory }
-    else
-      x
-
-  let read ~global (ifd: Reader.in_channel) : (Header.t * Header.Extended.t option, [ `Eof | `Fatal of [ `Checksum_mismatch | `Corrupt_pax_header | `Unmarshal of string ] ]) result t =
-    (* We might need to read 2 headers at once if we encounter a Pax header *)
-    let buffer = Bytes.make Header.length '\000' in
-    let real_header_buf = Bytes.make Header.length '\000' in
-
-    let next_block global () =
-      really_read ifd buffer >>= fun () ->
-      return (Header.unmarshal ?extended:global (Bytes.unsafe_to_string buffer))
+let fix_link_indicator x =
+  (* For backward compatibility we treat normal files ending in slash as
+     directories. Because [Link.of_char] treats unrecognized link indicator
+     values as normal files we check directly. This is not completely correct
+     as [Header.Link.of_char] turns unknown link indicators into
+     [Header.Link.Normal]. Ideally, it should only be done for '0' and
+     '\000'. *)
+  if String.length x.Header.file_name > 0
+  && x.file_name.[String.length x.file_name - 1] = '/'
+  && x.link_indicator = Header.Link.Normal then
+    { x with link_indicator = Header.Link.Directory }
+  else
+    x
+
+type decode_state = {
+  global : Header.Extended.t option;
+  state : [ `Active of bool
+          | `Global_extended_header of Header.t
+          | `Per_file_extended_header of Header.t
+          | `Real_header of Header.Extended.t
+          | `Next_longlink of Header.t ];
+  next_longlink : string option ;
+  next_longname : string option
+}
+
+let decode_state ?global () =
+  { global ; state = `Active false ; next_longlink = None ; next_longname = None }
+
+let construct_header t (hdr : Header.t) =
+  let hdr = Option.fold ~none:hdr ~some:(fun file_name -> { hdr with file_name }) t.next_longname in
+  let hdr = Option.fold ~none:hdr ~some:(fun link_name -> { hdr with link_name }) t.next_longlink in
+  let hdr = fix_link_indicator hdr in
+  { t with next_longlink = None ; next_longname = None ; state = `Active false },
+  hdr
+
+let decode t data =
+  match t.state with
+  | `Global_extended_header x ->
+    let* global =
+      (* unmarshal merges the previous global (if any) with the
+         discovered global (if any) and returns the new global. *)
+      Result.map_error (fun e -> `Fatal e)
+        (Header.Extended.unmarshal ~global:t.global data)
     in
-
-    let rec get_hdr ~next_longname ~next_longlink global () : (Header.t * Header.Extended.t option, [> `Eof | `Fatal of [ `Checksum_mismatch | `Corrupt_pax_header | `Unmarshal of string ] ]) result t =
-      next_block global () >>= function
-      | Ok x when x.Header.link_indicator = Header.Link.GlobalExtendedHeader ->
-        let extra_header_buf = Bytes.make (Int64.to_int x.Header.file_size) '\000' in
-        really_read ifd extra_header_buf >>= fun () ->
-        skip ifd (Header.compute_zero_padding_length x) >>= fun () ->
-        (* unmarshal merges the previous global (if any) with the
-           discovered global (if any) and returns the new global. *)
-        let^* global =
-          Result.map_error
-            (fun e -> `Fatal e)
-            (Header.Extended.unmarshal ~global (Bytes.unsafe_to_string extra_header_buf))
-        in
-        get_hdr ~next_longname ~next_longlink (Some global) ()
-      | Ok x when x.Header.link_indicator = Header.Link.PerFileExtendedHeader ->
-        let extra_header_buf = Bytes.make (Int64.to_int x.Header.file_size) '\000' in
-        really_read ifd extra_header_buf >>= fun () ->
-        skip ifd (Header.compute_zero_padding_length x) >>= fun () ->
-        let^* extended =
-          Result.map_error
-            (fun e -> `Fatal e)
-            (Header.Extended.unmarshal ~global (Bytes.unsafe_to_string extra_header_buf))
-        in
-        really_read ifd real_header_buf >>= fun () ->
-        let^* x =
-          Result.map_error
-            (fun _ -> `Fatal `Corrupt_pax_header)
-            (Header.unmarshal ~extended (Bytes.unsafe_to_string real_header_buf))
-        in
-        let x = fix_link_indicator x in
-        return (Ok (x, global))
-      | Ok ({ Header.link_indicator = Header.Link.LongLink | Header.Link.LongName; _ } as x) when x.Header.file_name = longlink ->
-        let extra_header_buf = Bytes.create (Int64.to_int x.Header.file_size) in
-        really_read ifd extra_header_buf >>= fun () ->
-        skip ifd (Header.compute_zero_padding_length x) >>= fun () ->
-        let name = String.sub (Bytes.unsafe_to_string extra_header_buf) 0 (Bytes.length extra_header_buf - 1) in
-        let next_longlink = if x.Header.link_indicator = Header.Link.LongLink then Some name else next_longlink in
-        let next_longname = if x.Header.link_indicator = Header.Link.LongName then Some name else next_longname in
-        get_hdr ~next_longname ~next_longlink global ()
-      | Ok x ->
-        (* XXX: unclear how/if pax headers should interact with gnu extensions *)
-        let x = match next_longname with
-          | None -> x
-          | Some file_name -> { x with file_name }
-        in
-        let x = match next_longlink with
-          | None -> x
-          | Some link_name -> { x with link_name }
-        in
-        let x = fix_link_indicator x in
-        return (Ok (x, global))
-      | Error `Zero_block ->
-        begin
-          next_block global () >>= function
-          | Ok x -> return (Ok (x, global))
-          | Error `Zero_block -> return (Error `Eof)
-          | Error ((`Checksum_mismatch | `Unmarshal _) as e) -> return (Error (`Fatal e))
-        end
-      | Error ((`Checksum_mismatch | `Unmarshal _) as e) ->
-        return (Error (`Fatal e))
+    Ok ({ t with global = Some global ; state = `Active false },
+        Some (`Skip (Header.compute_zero_padding_length x)),
+        Some global)
+  | `Per_file_extended_header x ->
+    let* extended =
+      Result.map_error
+        (fun e -> `Fatal e)
+        (Header.Extended.unmarshal ~global:t.global data)
     in
-    get_hdr ~next_longname:None ~next_longlink:None global ()
-
-end
-
-module HeaderWriter(Async: ASYNC)(Writer: WRITER with type 'a io = 'a Async.t) = struct
-  open Async
-  open Writer
-
-  type out_channel = Writer.out_channel
-  type 'a io = 'a t
-
-  let write_unextended ?level header fd =
-    let level = Header.compatibility level in
-    let blank = {Header.file_name = longlink; file_mode = 0; user_id = 0; group_id = 0; mod_time = 0L; file_size = 0L; link_indicator = Header.Link.LongLink; link_name = ""; uname = "root"; gname = "root"; devmajor = 0; devminor = 0; extended = None} in
-    (if level = Header.GNU then begin
-        begin
-          if String.length header.Header.link_name > Header.sizeof_hdr_link_name then begin
-            let file_size = String.length header.Header.link_name + 1 in
-            let blank = {blank with Header.file_size = Int64.of_int file_size} in
-            let buffer = Bytes.make Header.length '\000' in
-            match
-              Header.marshal ~level buffer { blank with link_indicator = Header.Link.LongLink }
-            with
-            | Error _ as e -> return e
-            | Ok () ->
-              really_write fd (Bytes.unsafe_to_string buffer) >>= fun () ->
-              let payload = header.Header.link_name ^ "\000" in
-              really_write fd payload >>= fun () ->
-              really_write fd (Header.zero_padding blank) >>= fun () ->
-              return (Ok ())
-          end else
-            return (Ok ())
-        end >>= function
-        | Error _ as e -> return e
-        | Ok () ->
-          begin
-            if String.length header.Header.file_name > Header.sizeof_hdr_file_name then begin
-              let file_size = String.length header.Header.file_name + 1 in
-              let blank = {blank with Header.file_size = Int64.of_int file_size} in
-              let buffer = Bytes.make Header.length '\000' in
-              match
-                Header.marshal ~level buffer { blank with link_indicator = Header.Link.LongName }
-              with
-              | Error _ as e -> return e
-              | Ok () ->
-                really_write fd (Bytes.unsafe_to_string buffer) >>= fun () ->
-                let payload = header.Header.file_name ^ "\000" in
-                really_write fd payload >>= fun () ->
-                really_write fd (Header.zero_padding blank) >>= fun () ->
-                return (Ok ())
-            end else
-              return (Ok ())
-          end >>= function
-          | Error _ as e -> return e
-          | Ok () -> return (Ok ())
-      end else
-       return (Ok ())) >>= function
-    | Error _ as e -> return e
-    | Ok () ->
-      let buffer = Bytes.make Header.length '\000' in
-      match Header.marshal ~level buffer header with
-      | Error _  as e -> return e
-      | Ok () ->
-        really_write fd (Bytes.unsafe_to_string buffer) >>= fun () ->
-        return (Ok ())
-
-  let write_extended ?level ~link_indicator hdr fd =
-    let link_indicator_name = match link_indicator with
-      | Header.Link.PerFileExtendedHeader -> "paxheader"
-      | Header.Link.GlobalExtendedHeader -> "pax_global_header"
-      | _ -> assert false
+    Ok ({ t with state = `Real_header extended },
+        Some (`Skip (Header.compute_zero_padding_length x)),
+        None)
+  | `Real_header extended ->
+    let* x =
+      Result.map_error
+        (fun _ -> `Fatal `Corrupt_pax_header) (* NB better error *)
+        (Header.unmarshal ~extended data)
     in
-    let pax_payload = Header.Extended.marshal hdr in
-    let pax = Header.make ~link_indicator link_indicator_name
-                (Int64.of_int @@ String.length pax_payload) in
-    write_unextended ?level pax fd >>= function
-    | Error _ as e -> return e
-    | Ok () ->
-      really_write fd pax_payload >>= fun () ->
-      really_write fd (Header.zero_padding pax) >>= fun () ->
+    let t, hdr = construct_header t x in
+    Ok (t, Some (`Header hdr), None)
+  | `Next_longlink x ->
+    let name = String.sub data 0 (String.length data - 1) in
+    let next_longlink = if x.Header.link_indicator = Header.Link.LongLink then Some name else t.next_longlink in
+    let next_longname = if x.Header.link_indicator = Header.Link.LongName then Some name else t.next_longname in
+    Ok ({ t with next_longlink ; next_longname ; state = `Active false },
+        Some (`Skip (Header.compute_zero_padding_length x)),
+        None)
+  | `Active read_zero ->
+    match Header.unmarshal ?extended:t.global data with
+    | Ok x when x.Header.link_indicator = Header.Link.GlobalExtendedHeader ->
+      Ok ({ t with state = `Global_extended_header x },
+          Some (`Read (Int64.to_int x.Header.file_size)),
+          None)
+    | Ok x when x.Header.link_indicator = Header.Link.PerFileExtendedHeader ->
+      Ok ({ t with state = `Per_file_extended_header x },
+          Some (`Read (Int64.to_int x.Header.file_size)),
+          None)
+    | Ok ({ Header.link_indicator = Header.Link.LongLink | Header.Link.LongName; _ } as x) when x.Header.file_name = longlink ->
+      Ok ({ t with state = `Next_longlink x },
+          Some (`Read (Int64.to_int x.Header.file_size)),
+          None)
+    | Ok x ->
+      let t, hdr = construct_header t x in
+      Ok (t, Some (`Header hdr), None)
+    | Error `Zero_block ->
+      if read_zero then
+        Error `Eof
+      else
+        Ok ({ t with state = `Active true }, None, None)
+    | Error ((`Checksum_mismatch | `Unmarshal _) as e) ->
+      Error (`Fatal e)
+
+let encode_long level link_indicator payload =
+  let blank = {Header.file_name = longlink; file_mode = 0; user_id = 0; group_id = 0; mod_time = 0L; file_size = 0L; link_indicator = Header.Link.LongLink; link_name = ""; uname = "root"; gname = "root"; devmajor = 0; devminor = 0; extended = None} in
+  let payload = payload ^ "\000" in
+  let file_size = String.length payload in
+  let blank = {blank with Header.file_size = Int64.of_int file_size} in
+  let buffer = Bytes.make Header.length '\000' in
+  let* () = Header.marshal ~level buffer { blank with link_indicator } in
+  Ok [ Bytes.unsafe_to_string buffer ; payload ; Header.zero_padding blank ]
+
+let encode_unextended_header ?level header =
+  let level = Header.compatibility level in
+  let* pre =
+    if level = Header.GNU then
+      let* longlink =
+        if String.length header.Header.link_name > Header.sizeof_hdr_link_name then
+          encode_long level Header.Link.LongLink header.Header.link_name
+        else
+          Ok []
+      in
+      let* longname =
+        if String.length header.Header.file_name > Header.sizeof_hdr_file_name then
+          encode_long level Header.Link.LongName header.Header.file_name
+        else
+          Ok []
+      in
+      Ok (longlink @ longname)
+    else
+      Ok []
+  in
+  let buffer = Bytes.make Header.length '\000' in
+  let* () = Header.marshal ~level buffer header in
+  Ok (pre @ [ Bytes.unsafe_to_string buffer ])
+
+let encode_extended_header ?level scope hdr =
+  let link_indicator, link_indicator_name = match scope with
+    | `Per_file -> Header.Link.PerFileExtendedHeader, "paxheader"
+    | `Global -> Header.Link.GlobalExtendedHeader, "pax_global_header"
+  in
+  let pax_payload = Header.Extended.marshal hdr in
+  let pax =
+    Header.make ~link_indicator link_indicator_name
+      (Int64.of_int @@ String.length pax_payload)
+  in
+  let* pax_hdr = encode_unextended_header ?level pax in
+  Ok (pax_hdr @ [ pax_payload ; Header.zero_padding pax ])
+
+let encode_header ?level header =
+  let* extended =
+    Option.fold ~none:(Ok []) ~some:(encode_extended_header ?level `Per_file) header.Header.extended
+  in
+  let* rest = encode_unextended_header ?level header in
+  Ok (extended @ rest)
+
+let encode_global_extended_header ?level global =
+  encode_extended_header ?level `Global global
+
+type ('a, 't) io
+
+type ('a, 'err, 't) t =
+  | Really_read : int -> (string, 'err, 't) t
+  | Read : int -> (string, 'err, 't) t
+  | Seek : int -> (unit, 'err, 't) t
+  | Bind : ('a, 'err, 't) t * ('a -> ('b, 'err, 't) t) -> ('b, 'err, 't) t
+  | Return : ('a, 'err) result -> ('a, 'err, 't) t
+  | High : (('a, 'err) result, 't) io -> ('a, 'err, 't) t
+  | Write : string -> (unit, 'err, 't) t
+
+let ( let* ) x f = Bind (x, f)
+let return x = Return x
+let really_read n = Really_read n
+let read n = Read n
+let seek n = Seek n
+let write str = Write str
+
+type ('a, 'err, 't) fold = (?global:Header.Extended.t -> Header.t -> 'a -> ('a, 'err, 't) t) -> 'a -> ('a, 'err, 't) t
+
+let fold f init =
+  let rec go t ?global ?data acc =
+    let* data = match data with
+      | None -> really_read Header.length
+      | Some data -> return (Ok data) in
+    match decode t data with
+    | Ok (t, Some `Header hdr, g) ->
+      let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
+      let* acc' = f ?global hdr acc in
+      let* () = seek (Header.compute_zero_padding_length hdr) in
+      go t ?global acc'
+    | Ok (t, Some `Skip n, g) ->
+      let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
+      let* () = seek n in
+      go t ?global acc
+    | Ok (t, Some `Read n, g) ->
+      let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
+      let* data = really_read n in
+      go t ?global ~data acc
+    | Ok (t, None, g) ->
+      let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
+      go t ?global acc
+    | Error `Eof -> return (Ok acc)
+    | Error `Fatal _ as e -> return e in
+  go (decode_state ()) init
+
+let rec writev = function
+  | [] -> return (Ok ())
+  | x :: r ->
+    let* () = write x in
+    writev r
+
+let rec pipe stream =
+  let* block = stream () in
+  match block with
+  | Some str -> let* () = write str in pipe stream
+  | None -> return (Ok ())
+
+type ('err, 't) content = unit -> (string option, 'err, 't) t
+type ('err, 't) entry = Header.compatibility option * Header.t * ('err, 't) content
+type ('err, 't) entries = unit -> (('err, 't) entry option, 'err, 't) t
+
+let out ?level ?global_hdr entries =
+  let rec go () =
+    let* entry = entries () in
+    match entry with
+    | None ->
+      let* () = writev [ Header.zero_block; Header.zero_block ] in
       return (Ok ())
-
-  let write ?level header fd =
-    ( match header.Header.extended with
-      | None -> return (Ok ())
-      | Some e ->
-        write_extended ?level ~link_indicator:Header.Link.PerFileExtendedHeader e fd )
-    >>= function
-    | Error _ as e -> return e
-    | Ok () -> write_unextended ?level header fd
-
-  let write_global_extended_header global fd =
-    write_extended ~link_indicator:Header.Link.GlobalExtendedHeader global fd
-end
+    | Some (level, hdr, stream) ->
+      match encode_header ?level hdr with
+      | Ok sstr ->
+        let* () = writev sstr in
+        let* () = pipe stream in
+        let* () = write (Header.zero_padding hdr) in
+        go ()
+      | Error _ as err -> return err in
+  match global_hdr with
+  | None -> go ()
+  | Some hdr ->
+    (* [encode_extended_header] includes padding *)
+    match encode_extended_header ?level `Global hdr with
+    | Error _ as err -> return err
+    | Ok sstr ->
+      let* () = writev sstr in
+      go ()
diff --git a/lib/tar.mli b/lib/tar.mli
index c995969..4a8af7e 100644
--- a/lib/tar.mli
+++ b/lib/tar.mli
@@ -19,7 +19,7 @@
     {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} *)
 
 (** The type of errors that may occur. *)
-type error = [`Checksum_mismatch | `Corrupt_pax_header | `Zero_block | `Unmarshal of string]
+type error = [ `Checksum_mismatch | `Corrupt_pax_header | `Zero_block | `Unmarshal of string ]
 
 (** [pp_error ppf e] pretty prints the error [e] on the formatter [ppf]. *)
 val pp_error : Format.formatter -> [< error] -> unit
@@ -123,7 +123,7 @@ module Header : sig
   (** Unmarshal a header block, returning [None] if it's all zeroes.
       This header block may be preceded by an [?extended] block which
       will override some fields. *)
-  val unmarshal : ?extended:Extended.t -> string -> (t, [`Zero_block | `Checksum_mismatch | `Unmarshal of string]) result
+  val unmarshal : ?extended:Extended.t -> string -> (t, [> `Zero_block | `Checksum_mismatch | `Unmarshal of string]) result
 
   (** Marshal a header block, computing and inserting the checksum. *)
   val marshal : ?level:compatibility -> bytes -> t -> (unit, [> `Msg of string ]) result
@@ -139,47 +139,88 @@ module Header : sig
   val to_sectors: t -> int64
 end
 
-module type ASYNC = sig
-  type 'a t
-  val ( >>= ): 'a t -> ('a -> 'b t) -> 'b t
-  val return: 'a -> 'a t
-end
-
-module type READER = sig
-  type in_channel
-  type 'a io
-  val really_read: in_channel -> bytes -> unit io
-  val skip: in_channel -> int -> unit io
-end
-
-module type WRITER = sig
-  type out_channel
-  type 'a io
-  val really_write: out_channel -> string -> unit io
-end
-
-module type HEADERREADER = sig
-  type in_channel
-  type 'a io
-
-  (** Returns the next header block or error [`Eof] if two consecutive
-      zero-filled blocks are discovered. Assumes stream is positioned at the
-      possible start of a header block.
-      @param global Holds the current global pax extended header, if
-        any. Needs to be given to the next call to [read]. *)
-  val read : global:Header.Extended.t option -> in_channel ->
-    (Header.t * Header.Extended.t option, [ `Eof | `Fatal of [ `Checksum_mismatch | `Corrupt_pax_header | `Unmarshal of string ] ]) result io
-end
-
-module type HEADERWRITER = sig
-  type out_channel
-  type 'a io
-  val write : ?level:Header.compatibility -> Header.t -> out_channel -> (unit, [> `Msg of string ]) result io
-  val write_global_extended_header : Header.Extended.t -> out_channel -> (unit, [> `Msg of string ]) result io
-end
-
-module HeaderReader(Async: ASYNC)(Reader: READER with type 'a io = 'a Async.t) :
-  HEADERREADER with type in_channel = Reader.in_channel and type 'a io = 'a Async.t
-
-module HeaderWriter(Async: ASYNC)(Writer: WRITER with type 'a io = 'a Async.t) :
-  HEADERWRITER with type out_channel = Writer.out_channel and type 'a io = 'a Async.t
+(** {1 Decoding and encoding of a whole archive} *)
+
+(** The type of the decode state. *)
+type decode_state
+
+(** [decode_state ~global ()] constructs a decode_state. *)
+val decode_state : ?global:Header.Extended.t -> unit -> decode_state
+
+(** [decode t data] decodes [data] taking the current state [t] into account.
+    It may result on success in a new state, optionally some action that should
+    be done ([`Read] or [`Skip]), or a decoded [`Header]. Possibly a new global
+    PAX header is provided as well.
+
+    If no [`Read] or [`Skip] is returned, the new state should be used with
+    [decode] with the next [Header.length] sized string, which will lead to
+    further decoding until [`Eof] (or an error) occurs. *)
+val decode : decode_state -> string ->
+  (decode_state * [ `Read of int | `Skip of int | `Header of Header.t ] option * Header.Extended.t option,
+   [ `Eof | `Fatal of error ])
+    result
+
+(** [encode_header ~level hdr] encodes the header with the provided [level]
+    (defaults to [V7]) into a list of strings to be written to the disk.
+    Once a header is written, the payload (padded to multiples of
+    [Header.length]) should follow. *)
+val encode_header : ?level:Header.compatibility ->
+  Header.t -> (string list, [> `Msg of string ]) result
+
+(** [encode_global_extended_header hdr] encodes the global extended header as
+    a list of strings. *)
+val encode_global_extended_header : ?level:Header.compatibility -> Header.Extended.t -> (string list, [> `Msg of string ]) result
+
+(** {1 Pure implementation of [fold].}
+
+    [fold] produces a [('a, 'err, 't) t] value which can be {b evaluated} by
+    a scheduler (such as [lwt] or [unix]). This value describe when we require
+    to [Read] (like {!val:Stdlib.input}), [Really_read] (like
+    {!val:Stdlib.really_read}) and [Seek] (like {!val:Stdlib.seek_in}).
+
+    We can compose these actions with [Bind], [Return] and [High]. The latter
+    allows you to use a value [('a, 't) io] that comes from the scheduler used -
+    so you can use an Lwt value (['a Lwt.t]) without depending on Lwt
+    ([('a, lwt) t]) at this stage.
+
+    For further informations, you can look at the paper about Lightweight
+    Higher Kind Polymorphism available
+    {{:https://www.cl.cam.ac.uk/~jdy22/papers/lightweight-higher-kinded-polymorphism.pdf} here}. *)
+
+type ('a, 't) io
+
+type ('a, 'err, 't) t =
+  | Really_read : int -> (string, 'err, 't) t
+  | Read : int -> (string, 'err, 't) t
+  | Seek : int -> (unit, 'err, 't) t
+  | Bind : ('a, 'err, 't) t * ('a -> ('b, 'err, 't) t) -> ('b, 'err, 't) t
+  | Return : ('a, 'err) result -> ('a, 'err, 't) t
+  | High : (('a, 'err) result, 't) io -> ('a, 'err, 't) t
+  | Write : string -> (unit, 'err, 't) t
+
+val really_read : int -> (string, _, _) t
+val read : int -> (string, _, _) t
+val seek : int -> (unit, _, _) t
+val ( let* ) : ('a, 'err, 't) t -> ('a -> ('b, 'err, 't) t) -> ('b, 'err, 't) t
+val return : ('a, 'err) result -> ('a, 'err, _) t
+val write : string -> (unit, _, _) t
+
+type ('a, 'err, 't) fold = (?global:Header.Extended.t -> Header.t -> 'a -> ('a, 'err, 't) t) -> 'a -> ('a, 'err, 't) t
+
+val fold : ('a, [> `Fatal of error ], 't) fold
+(** [fold f] is a [_ t] that reads an archive and executes [f] on each header.
+    [f] is expected to either read or skip the file contents, or return an
+    error. *)
+
+type ('err, 't) content = unit -> (string option, 'err, 't) t
+type ('err, 't) entry = Header.compatibility option * Header.t * ('err, 't) content
+type ('err, 't) entries = unit -> (('err, 't) entry option, 'err, 't) t
+
+val out :
+     ?level:Header.compatibility
+  -> ?global_hdr:Header.Extended.t
+  -> ([> `Msg of string ] as 'err, 't) entries
+  -> (unit, 'err, 't) t
+(** [out hdr entries] is a [_ t] that writes [entries] into an archive. [hdr] is
+    the global header and each entry must come from a {!type:content} stream and
+    the associated header.*)
diff --git a/lib/tar_gz.ml b/lib/tar_gz.ml
index e197482..26fc22a 100644
--- a/lib/tar_gz.ml
+++ b/lib/tar_gz.ml
@@ -14,34 +14,9 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
-module type READER = sig
-  type in_channel
-  type 'a io
-  val read : in_channel -> bytes -> int io
-end
-
 external ba_get_int32_ne : De.bigstring -> int -> int32 = "%caml_bigstring_get32"
 external ba_set_int32_ne : De.bigstring -> int -> int32 -> unit = "%caml_bigstring_set32"
 
-let bigstring_to_string ?(off= 0) ?len ba =
-  let len = match len with
-    | Some len -> len
-    | None -> De.bigstring_length ba - off in
-  let res = Bytes.create len in
-  let len0 = len land 3 in
-  let len1 = len asr 2 in
-  for i = 0 to len1 - 1 do
-    let i = i * 4 in
-    let v = ba_get_int32_ne ba i in
-    Bytes.set_int32_ne res i v
-  done;
-  for i = 0 to len0 - 1 do
-    let i = (len1 * 4) + i in
-    let v = Bigarray.Array1.get ba i in
-    Bytes.set res i v
-  done;
-  Bytes.unsafe_to_string res
-
 let bigstring_blit_string src ~src_off dst ~dst_off ~len =
   let len0 = len land 3 in
   let len1 = len asr 2 in
@@ -71,162 +46,170 @@ let bigstring_blit_bytes src ~src_off dst ~dst_off ~len =
     Bytes.set dst (dst_off + i) v
   done
 
-module Make
-  (Async : Tar.ASYNC)
-  (Writer : Tar.WRITER with type 'a io = 'a Async.t)
-  (Reader : READER with type 'a io = 'a Async.t)
-= struct
-  open Async
-
-  module Gz_writer = struct
-    type out_channel =
-      { mutable gz : Gz.Def.encoder
-      ; ic_buffer : De.bigstring
-      ; oc_buffer : De.bigstring
-      ; out_channel : Writer.out_channel }
-
-    type 'a io = 'a Async.t
-
-    let really_write ({ gz; ic_buffer; oc_buffer; out_channel; _ } as state) str =
-      let rec until_await gz =
-        match Gz.Def.encode gz with
-        | `Await gz -> Async.return gz
-        | `Flush gz ->
-          let len = De.bigstring_length oc_buffer - Gz.Def.dst_rem gz in
-          let str = bigstring_to_string oc_buffer ~off:0 ~len in
-          Writer.really_write out_channel str >>= fun () ->
-          until_await (Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer))
-        | `End _gz -> assert false
-      and go gz (str, str_off, str_len) =
-        if str_len = 0
-        then ( state.gz <- gz ; Async.return () )
-        else ( let len = min str_len (De.bigstring_length ic_buffer) in
-               bigstring_blit_string str ~src_off:0 ic_buffer ~dst_off:0 ~len;
-               let gz = Gz.Def.src gz ic_buffer 0 len in
-               until_await gz >>= fun gz ->
-               go gz (str, str_off + len, str_len - len) ) in
-      go gz (str, 0, String.length str)
-  end
-
-  module Gz_reader = struct
-    type in_channel =
-      { mutable gz : Gz.Inf.decoder
-      ; ic_buffer : De.bigstring
-      ; oc_buffer : De.bigstring
-      ; tp_buffer : bytes
-      ; in_channel : Reader.in_channel
-      ; mutable pos : int }
-
-    type 'a io = 'a Async.t
-
-    let really_read
-      : in_channel -> bytes -> unit io
-      = fun ({ ic_buffer; oc_buffer; in_channel; tp_buffer; _ } as state) res ->
-        let rec until_full_or_end gz (res, res_off, res_len) =
-          match Gz.Inf.decode gz with
-          | `Flush gz ->
-            let max = De.bigstring_length oc_buffer - Gz.Inf.dst_rem gz in
-            let len = min res_len max in
-            bigstring_blit_bytes oc_buffer ~src_off:0 res ~dst_off:res_off ~len;
-            if len < max
-            then ( state.pos <- len
-                 ; state.gz <- gz
-                 ; Async.return () )
-            else until_full_or_end (Gz.Inf.flush gz) (res, res_off + len, res_len - len)
-          | `End gz ->
-            let max = De.bigstring_length oc_buffer - Gz.Inf.dst_rem gz in
-            let len = min res_len max in
-            bigstring_blit_bytes oc_buffer ~src_off:0 res ~dst_off:res_off ~len;
-            if res_len > len
-            then raise End_of_file
-            else ( state.pos <- len
-                 ; state.gz <- gz
-                 ; Async.return () )
-          | `Await gz ->
-            Reader.read in_channel tp_buffer >>= fun len ->
-            bigstring_blit_string (Bytes.unsafe_to_string tp_buffer) ~src_off:0 ic_buffer ~dst_off:0 ~len;
-            let gz = Gz.Inf.src gz ic_buffer 0 len in
-            until_full_or_end gz (res, res_off, res_len)
-          | `Malformed err -> failwith ("gzip: " ^ err) in
-        let max = (De.bigstring_length oc_buffer - Gz.Inf.dst_rem state.gz) - state.pos in
-        let len = min (Bytes.length res) max in
-        bigstring_blit_bytes oc_buffer ~src_off:state.pos res ~dst_off:0 ~len;
+type decoder =
+  { mutable gz : Gz.Inf.decoder
+  ; ic_buffer : De.bigstring
+  ; oc_buffer : De.bigstring
+  ; tp_length : int
+  ; mutable pos : int }
+
+let really_read_through_gz
+  : decoder -> bytes -> (unit, 'err, _) Tar.t
+  = fun ({ ic_buffer; oc_buffer; tp_length; _ } as state) res ->
+    let open Tar in
+    let rec until_full_or_end gz (res, res_off, res_len) =
+      match Gz.Inf.decode gz with
+      | `Flush gz ->
+        let max = De.bigstring_length oc_buffer - Gz.Inf.dst_rem gz in
+        let len = min res_len max in
+        bigstring_blit_bytes oc_buffer ~src_off:0 res ~dst_off:res_off ~len;
         if len < max
-        then ( state.pos <- state.pos + len
-             ; Async.return () )
-        else until_full_or_end (Gz.Inf.flush state.gz) (res, len, Bytes.length res - len)
-
-    let skip : in_channel -> int -> unit io = fun state len ->
-      let res = Bytes.create len in
-      really_read state res
-  end
-
-  module HeaderWriter = Tar.HeaderWriter (Async) (Gz_writer)
-  module HeaderReader = Tar.HeaderReader (Async) (Gz_reader)
-
-  type in_channel = Gz_reader.in_channel
-
-  let of_in_channel ~internal:oc_buffer in_channel =
-    { Gz_reader.gz= Gz.Inf.decoder `Manual ~o:oc_buffer
+        then ( state.pos <- len
+             ; state.gz <- gz
+             ; return (Ok ()) )
+        else until_full_or_end (Gz.Inf.flush gz) (res, res_off + len, res_len - len)
+      | `End gz ->
+        let max = De.bigstring_length oc_buffer - Gz.Inf.dst_rem gz in
+        let len = min res_len max in
+        bigstring_blit_bytes oc_buffer ~src_off:0 res ~dst_off:res_off ~len;
+        if res_len > len
+        then return (Error `Eof)
+        else ( state.pos <- len
+             ; state.gz <- gz
+             ; return (Ok ()) )
+      | `Await gz ->
+        let* tp_buffer = Tar.read tp_length in
+        let len = String.length tp_buffer in
+        bigstring_blit_string tp_buffer ~src_off:0 ic_buffer ~dst_off:0 ~len;
+        let gz = Gz.Inf.src gz ic_buffer 0 len in
+        until_full_or_end gz (res, res_off, res_len)
+      | `Malformed err -> return (Error (`Gz err)) in
+    let max = (De.bigstring_length oc_buffer - Gz.Inf.dst_rem state.gz) - state.pos in
+    let len = min (Bytes.length res) max in
+    bigstring_blit_bytes oc_buffer ~src_off:state.pos res ~dst_off:0 ~len;
+    if len < max
+    then ( state.pos <- state.pos + len
+         ; return (Ok ()) )
+    else until_full_or_end (Gz.Inf.flush state.gz) (res, len, Bytes.length res - len)
+
+let really_read_through_gz decoder len =
+  let open Tar in
+  let res = Bytes.create len in
+  let* () = really_read_through_gz decoder res in
+  Tar.return (Ok (Bytes.unsafe_to_string res))
+
+type error = [ `Fatal of Tar.error | `Eof | `Gz of string ]
+
+let seek_through_gz
+  : decoder -> int -> (unit, [> error ], _) Tar.t
+  = fun state len ->
+  let open Tar in
+  let* _buf = really_read_through_gz state len in
+  Tar.return (Ok ())
+
+let in_gzipped t =
+  let rec go
+    : type a. decoder -> (a, [> error ] as 'err, 't) Tar.t -> (a, 'err, 't) Tar.t
+    = fun decoder -> function
+    | Tar.Really_read len ->
+      really_read_through_gz decoder len
+    | Tar.Read _len as v -> v
+    | Tar.Seek len -> seek_through_gz decoder len
+    | Tar.Return _ as ret -> ret
+    | Tar.Bind (x, f) ->
+      Tar.Bind (go decoder x, (fun x -> go decoder (f x)))
+    | Tar.High _ as high -> high
+    | Tar.Write _ as v -> v in
+  let decoder =
+    let oc_buffer = De.bigstring_create 0x1000 in
+    { gz= Gz.Inf.decoder `Manual ~o:oc_buffer
     ; oc_buffer
     ; ic_buffer= De.bigstring_create 0x1000
-    ; tp_buffer= Bytes.create 0x1000
-    ; in_channel
-    ; pos= 0 }
-
-  let really_read = Gz_reader.really_read
-  let skip = Gz_reader.skip
-
-  type out_channel = Gz_writer.out_channel
-
-  let of_out_channel ?bits:(w_bits= 15) ?q:(q_len= 0x1000) ~level ~mtime os out_channel =
-    let ic_buffer = De.bigstring_create (4 * 4 * 1024) in
-    let oc_buffer = De.bigstring_create 4096 in
-    let gz =
-      let w = De.Lz77.make_window ~bits:w_bits in
-      let q = De.Queue.create q_len in
-      Gz.Def.encoder `Manual `Manual ~mtime os ~q ~w ~level in
-    let gz = Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer) in
-    { Gz_writer.gz; ic_buffer; oc_buffer; out_channel; }
-
-  let write_block ?level hdr ({ Gz_writer.ic_buffer= buf; oc_buffer; out_channel; _ } as state) block =
-    HeaderWriter.write ?level hdr state >>= function
-    | Error _ as e -> return e
-    | Ok () ->
-      (* XXX(dinosaure): we can refactor this codec with [Gz_writer.really_write]
-         but this loop saves and uses [ic_buffer]/[buf] to avoid extra
-         allocations on the case between [string] and [bigstring]. *)
-      let rec deflate (str, off, len) gz = match Gz.Def.encode gz with
-        | `Await gz ->
-          if len = 0
-          then block () >>= function
-            | None -> state.gz <- gz ; Async.return ()
-            | Some str -> deflate (str, 0, String.length str) gz
-          else ( let len' = min len (De.bigstring_length buf) in
-                 bigstring_blit_string str ~src_off:off buf ~dst_off:0 ~len:len';
-                 deflate (str, off + len', len - len')
-                   (Gz.Def.src gz buf 0 len') )
-        | `Flush gz ->
-          let len = De.bigstring_length oc_buffer - Gz.Def.dst_rem gz in
-          let out = bigstring_to_string oc_buffer ~len in
-          Writer.really_write out_channel out >>= fun () ->
-          deflate (str, off, len) (Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer))
-        | `End _gz -> assert false in
-      deflate ("", 0, 0) state.gz >>= fun () ->
-      Gz_writer.really_write state (Tar.Header.zero_padding hdr) >>= fun () ->
-      return (Ok ())
-
- let write_end ({ Gz_writer.oc_buffer; out_channel; _ } as state) =
-   Gz_writer.really_write state Tar.Header.zero_block >>= fun () ->
-   Gz_writer.really_write state Tar.Header.zero_block >>= fun () ->
-   let rec until_end gz = match Gz.Def.encode gz with
-     | `Await _gz -> assert false
-     | `Flush gz | `End gz as flush_or_end ->
-       let max = De.bigstring_length oc_buffer - Gz.Def.dst_rem gz in
-       Writer.really_write out_channel (bigstring_to_string oc_buffer ~len:max) >>= fun () ->
-       match flush_or_end with
-       | `Flush gz ->
-         until_end (Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer))
-       | `End _gz -> Async.return () in
-   until_end (Gz.Def.src state.gz De.bigstring_empty 0 0)
-end
+    ; tp_length= 0x1000
+    ; pos= 0 } in
+  go decoder t
+
+type encoder =
+  { mutable state : [ `Await of Gz.Def.encoder ]
+  ; ic_buffer : De.bigstring
+  ; oc_buffer : De.bigstring }
+
+let ( let* ) x f = Tar.Bind (x, f)
+
+let rec until_await oc_pos oc_buffer = function
+  | `Flush gz as state ->
+    let max = De.bigstring_length oc_buffer - Gz.Def.dst_rem gz - oc_pos in
+    let len = min 0x100 max in
+    let res = Bytes.create len in
+    bigstring_blit_bytes oc_buffer ~src_off:oc_pos res ~dst_off:0 ~len;
+    let* () = Tar.write (Bytes.unsafe_to_string res) in
+    if len > 0 then until_await (oc_pos + len) oc_buffer state
+    else
+      Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer)
+      |> Gz.Def.encode
+      |> until_await 0 oc_buffer
+  | `Await gz -> Tar.return (Ok (`Await gz))
+  | `End _ -> assert false
+
+let rec until_end oc_pos oc_buffer = function
+  | `Await _ -> assert false
+  | (`Flush gz | `End gz) as state ->
+    let max = De.bigstring_length oc_buffer - Gz.Def.dst_rem gz - oc_pos in
+    let len = min 0x100 max in
+    let res = Bytes.create len in
+    bigstring_blit_bytes oc_buffer ~src_off:oc_pos res ~dst_off:0 ~len;
+    let* () = Tar.write (Bytes.unsafe_to_string res) in
+    if len > 0 then until_end (oc_pos + len) oc_buffer state
+    else match state with
+    | `End _ -> Tar.return (Ok ())
+    | `Flush gz ->
+      Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer)
+      |> Gz.Def.encode
+      |> until_end 0 oc_buffer
+
+let write_gz ({ state; ic_buffer; oc_buffer; } as encoder) str =
+  let rec go (str, str_off, str_len) state =
+    if str_len = 0
+    then Tar.return (Ok state)
+    else begin
+      let len = min str_len (De.bigstring_length ic_buffer) in
+      bigstring_blit_string str ~src_off:str_off ic_buffer ~dst_off:0 ~len;
+      let `Await gz = state in
+      let gz = Gz.Def.src gz ic_buffer 0 len in
+      let* state = until_await 0 oc_buffer (Gz.Def.encode gz) in
+      go (str, str_off + len, str_len - len) state
+    end in
+  let* state = go (str, 0, String.length str) state in
+  encoder.state <- state;
+  Tar.return (Ok ())
+
+let out_gzipped ~level ~mtime os t =
+  let rec go
+    : type a. encoder -> (a, 'err, 't) Tar.t -> (a, 'err, 't) Tar.t
+    = fun encoder -> function
+    | Tar.Really_read _ as ret -> ret
+    | Tar.Read _ as ret -> ret
+    | Tar.Seek _ as ret -> ret
+    | Tar.Return _ as ret -> ret
+    | Tar.Bind (x, f) ->
+      Tar.Bind (go encoder x, (fun x -> go encoder (f x)))
+    | Tar.High _ as high -> high
+    | Tar.Write str -> write_gz encoder str in
+  let ic_buffer = De.bigstring_create 0x1000 in
+  let oc_buffer = De.bigstring_create 0x1000 in
+  let q = De.Queue.create 4096 in
+  let w = De.Lz77.make_window ~bits:15 in
+  let gz = Gz.Def.encoder `Manual `Manual ~q ~w ~level ~mtime os in
+  let gz = Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer) in
+  let* state = until_await 0 oc_buffer (Gz.Def.encode gz) in
+  let encoder =
+    { state 
+    ; ic_buffer
+    ; oc_buffer } in
+  let* result = go encoder t in
+  let `Await gz = encoder.state in
+  let* () =
+    Gz.Def.src gz ic_buffer 0 0
+    |> Gz.Def.encode 
+    |> until_end 0 oc_buffer  in
+  Tar.return (Ok result)
diff --git a/lib/tar_gz.mli b/lib/tar_gz.mli
index de18b76..f7dd4ae 100644
--- a/lib/tar_gz.mli
+++ b/lib/tar_gz.mli
@@ -14,61 +14,17 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
-module type READER = sig
-  type in_channel
-  type 'a io
-  val read : in_channel -> bytes -> int io
-end
-
-module Make
-  (Async : Tar.ASYNC)
-  (Writer : Tar.WRITER with type 'a io = 'a Async.t)
-  (Reader : READER with type 'a io = 'a Async.t)
-: sig
-  type in_channel
-
-  val of_in_channel : internal:De.bigstring -> Reader.in_channel -> in_channel
-
-  val really_read : in_channel -> bytes -> unit Async.t
-  (** [really_read fd buf] fills [buf] with data from [fd] or raises
-      {!Stdlib.End_of_file}. *)
-
-  val skip : in_channel -> int -> unit Async.t
-
-  type out_channel
-
-  val of_out_channel : ?bits:int -> ?q:int -> level:int ->
-    mtime:int32 -> Gz.os -> Writer.out_channel -> out_channel
-
-  val write_block : ?level:Tar.Header.compatibility -> Tar.Header.t ->
-    out_channel -> (unit -> string option Async.t) -> (unit, [> `Msg of string ]) result Async.t
-  (** [write_block hdr oc stream] writes [hdr], then {i deflate} the given
-      [stream], then zero-pads so the stream is positionned for the next
-      block.
-
-      A simple usage to write a file:
-      {[
-        let stream_of_fd fd =
-          let buf = Bytes.create 0x1000 in
-          fun () -> match Unix.read fd buf 0 (Bytes.length buf) with
-          | 0 -> None
-          | len -> Some (Bytes.sub_string buf 0 len)
-          | exception End_of_file -> None
-
-        let add_file oc filename =
-          let fd = Unix.openfile filename Unix.[ O_RDONLY ] 0o644 in
-          let hdr = Tar.Header.make ... in
-          (match write_block hdr oc (stream_of_fd fd) with
-           | Ok () -> ()
-           | Error `Msg msg -> print_endline ("error: " ^ msg));
-          Unix.close fd
-      ]} *)
-
-  val write_end : out_channel -> unit Async.t
-  (** [write_end oc] writes a stream terminator to [oc]. *)
-
-  module HeaderReader :
-    Tar.HEADERREADER with type in_channel = in_channel and type 'a io = 'a Async.t
-  module HeaderWriter :
-    Tar.HEADERWRITER with type out_channel = out_channel and type 'a io = 'a Async.t
-end
+type error = [ `Fatal of Tar.error | `Eof | `Gz of string ]
+
+val in_gzipped : ('a, ([> error ] as 'err), 't) Tar.t -> ('a, 'err, 't) Tar.t
+  (** [in_gzipped] takes a {i tar process} (like {!val:Tar.fold}) and add a
+      uncompression layer to be able to manipulate a [*.tar.gz] archive. *)
+
+val out_gzipped :
+     level:int
+  -> mtime:int32
+  -> Gz.os
+  -> ('a, 'err, 't) Tar.t
+  -> ('a, 'err, 't) Tar.t
+(** [out_gzipped] takes a {i tar process} (like {!val:Tar.out}) and add a
+    compression layer to be able to generate a [*.tar.gz] archive. *)
diff --git a/mirage/tar_mirage.ml b/mirage/tar_mirage.ml
index 35f5b55..4e45bbc 100644
--- a/mirage/tar_mirage.ml
+++ b/mirage/tar_mirage.ml
@@ -75,42 +75,66 @@ module Make_KV_RO (BLOCK : Mirage_block.S) = struct
     in
     Lwt.return r
 
-  module Reader = struct
-    type in_channel = {
-      b: BLOCK.t;
-      (** offset in bytes *)
-      mutable offset: int64;
-      info: Mirage_block.info;
-    }
-    type 'a io = 'a Lwt.t
-    let really_read in_channel buffer =
-      let len = Bytes.length buffer in
-      assert(len <= 512);
-      (* Tar assumes 512 byte sectors, but BLOCK might have 4096 byte sectors for example *)
-      let sector_size = in_channel.info.Mirage_block.sector_size in
-      let sector' = Int64.(div in_channel.offset (of_int sector_size)) in
-      let sector_aligned_len =
-        if len mod sector_size == 0 then len else
-          len + (sector_size - len mod sector_size)
-      in
-      let tmp = Cstruct.create sector_aligned_len in
-      BLOCK.read in_channel.b sector' [ tmp ]
-      >>= function
-      | Error e -> failwith (Format.asprintf "Failed to read sector %Ld from block device: %a" sector'
-                               BLOCK.pp_error e)
-      | Ok () ->
-        (* If the BLOCK sector size is big, then we need to select the 512 bytes we want *)
-        let offset = Int64.(to_int (sub in_channel.offset (mul sector' (of_int sector_size)))) in
-        in_channel.offset <- Int64.(add in_channel.offset (of_int len));
-        Cstruct.blit_to_bytes tmp offset buffer 0 len;
-        Lwt.return_unit
-    let skip in_channel n =
-      in_channel.offset <- Int64.(add in_channel.offset (of_int n));
-      Lwt.return_unit
-    let _get_current_tar_sector in_channel = Int64.div in_channel.offset 512L
-
-  end
-  module HR = Tar.HeaderReader(Lwt)(Reader)
+  let read_data info b offset buffer len =
+    assert(len <= 512);
+    (* Tar assumes 512 byte sectors, but BLOCK might have 4096 byte sectors for example *)
+    let sector_size = info.Mirage_block.sector_size in
+    let sector' = Int64.(div offset (of_int sector_size)) in
+    let sector_aligned_len =
+      if len mod sector_size == 0 then
+        len
+      else
+        len + (sector_size - len mod sector_size)
+    in
+    let tmp = Cstruct.create sector_aligned_len in
+    BLOCK.read b sector' [ tmp ] >>= function
+    | Error e ->
+      Lwt.return (Error (`Msg
+                           (Format.asprintf "Failed to read sector %Ld from block device: %a" sector'
+                              BLOCK.pp_error e)))
+    | Ok () ->
+      (* If the BLOCK sector size is big, then we need to select the 512 bytes we want *)
+      let offset_in_cs = Int64.(to_int (sub offset (mul sector' (of_int sector_size)))) in
+      Cstruct.blit_to_bytes tmp offset_in_cs buffer 0 len;
+      Lwt.return (Ok ())
+
+  let fold info b f init =
+    let open Lwt_result.Infix in
+    let rec go t offset ?global ?data acc =
+      (match data with
+       | None ->
+         let buf = Bytes.make Tar.Header.length '\000' in
+         read_data info b offset buf Tar.Header.length >|= fun () ->
+         Int64.(add offset (of_int Tar.Header.length)), Bytes.unsafe_to_string buf
+       | Some data ->
+         Lwt.return (Ok (offset, data))) >>= fun (offset, data) ->
+      match Tar.decode t data with
+      | Ok (t, Some `Header hdr, g) ->
+        let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
+        f offset ?global hdr acc >>= fun acc' ->
+        let off' =
+          Int64.(add offset (add hdr.Tar.Header.file_size
+                               (of_int (Tar.Header.compute_zero_padding_length hdr))))
+        in
+        go t off' ?global acc'
+      | Ok (t, Some `Skip n, g) ->
+        let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
+        let off' = Int64.(add offset (of_int n)) in
+        go t off' ?global acc
+      | Ok (t, Some `Read n, g) ->
+        let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
+        let buf = Bytes.make n '\000' in
+        read_data info b offset buf n >>= fun () ->
+        let data = Bytes.unsafe_to_string buf in
+        let off' = Int64.(add offset (of_int n)) in
+        go t off' ?global ~data acc
+      | Ok (t, None, g) ->
+        let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
+        go t offset ?global acc
+      | Error `Eof -> Lwt.return (Ok acc)
+      | Error `Fatal _ as e -> Lwt.return e
+    in
+    go (Tar.decode_state ()) 0L init
 
   (* [read_partial_sector t sector_start ~offset ~length dst]
      reads a single sector and blits [length] bytes from [offset] into [dst]
@@ -255,33 +279,37 @@ module Make_KV_RO (BLOCK : Mirage_block.S) = struct
     let ssize = info.Mirage_block.sector_size in
     if ssize mod 512 <> 0 || ssize < 512 then
       invalid_arg "Sector size needs to be >= 512 and a multiple of 512";
-    let in_channel = { Reader.b; offset = 0L; info } in
-    let rec loop ~global map =
-      HR.read ~global in_channel >>= function
-      | Error `Eof -> Lwt.return map
-      | Error `Fatal e ->
-        Format.kasprintf failwith "Error reading archive: %a" Tar.pp_error e
-      | Ok (tar, global) ->
-        let filename = trim_slash tar.Tar.Header.file_name in
-        let map =
-          if filename = "" then
-            map
-          else
-            let data_tar_offset = Int64.div in_channel.Reader.offset 512L in
-            let v_or_d = if is_dict filename then Dict (tar, StringMap.empty) else Value (tar, data_tar_offset) in
-            insert map (Mirage_kv.Key.v filename) v_or_d
-        in
-        Reader.skip in_channel (Int64.to_int tar.Tar.Header.file_size) >>= fun () ->
-        Reader.skip in_channel (Tar.Header.compute_zero_padding_length tar) >>= fun () ->
-        loop ~global map
+    let f offset ?global:_ hdr (_, map) =
+      let filename = trim_slash hdr.Tar.Header.file_name in
+      let map =
+        if filename = "" then
+          map
+        else
+          let data_tar_offset = Int64.(div offset (of_int Tar.Header.length)) in
+          let v_or_d =
+            if is_dict filename then
+              Dict (hdr, StringMap.empty)
+            else
+              Value (hdr, data_tar_offset)
+          in
+          insert map (Mirage_kv.Key.v filename) v_or_d
+      in
+      let eof = Int64.(add offset
+                         (add hdr.Tar.Header.file_size
+                            (of_int (Tar.Header.compute_zero_padding_length hdr))))
+      in
+      Lwt.return (Ok (eof, map))
     in
-    let root = StringMap.empty in
-    loop ~global:None root >>= fun map ->
-    (* This is after the two [zero_block]s *)
-    let end_of_archive = in_channel.Reader.offset in
-    let map = Dict (Tar.Header.make "/" 0L, map) in
-    let write_lock = Lwt_mutex.create () in
-    Lwt.return ({ b; map; info; end_of_archive; write_lock })
+    fold info b f (0L, StringMap.empty) >>= function
+    | Error `Fatal e ->
+      Format.kasprintf failwith "Fatal error reading archive: %a" Tar.pp_error e
+    | Error `Msg msg ->
+      Format.kasprintf failwith "Error reading archive: %s" msg
+    | Ok (end_of_archive, map) ->
+      let end_of_archive = Int64.(add end_of_archive (of_int (2 * Tar.Header.length))) in
+      let map = Dict (Tar.Header.make "/" 0L, map) in
+      let write_lock = Lwt_mutex.create () in
+      Lwt.return ({ b; map; info; end_of_archive; write_lock })
 
   let disconnect _ = Lwt.return_unit
 
@@ -292,7 +320,14 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
 
   include Make_KV_RO(BLOCK)
 
-  type write_error = [ `Block of BLOCK.error | `Block_write of BLOCK.write_error | Mirage_kv.write_error | `Entry_already_exists | `Path_segment_is_a_value | `Append_only | `Write_header of string ]
+  type write_error = [
+    | `Block of BLOCK.error
+    | `Block_write of BLOCK.write_error
+    | Mirage_kv.write_error
+    | `Entry_already_exists
+    | `Path_segment_is_a_value
+    | `Append_only
+    | `Msg of string ]
 
   let pp_write_error ppf = function
    | `Block e -> Fmt.pf ppf "read error while writing: %a" BLOCK.pp_error e
@@ -301,7 +336,7 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
    | `Entry_already_exists -> Fmt.string ppf "entry already exists"
    | `Path_segment_is_a_value -> Fmt.string ppf "path segment is a value"
    | `Append_only -> Fmt.string ppf "append only"
-   | `Write_header msg -> Fmt.pf ppf "writing tar header failed: %s" msg
+   | `Msg msg -> Fmt.pf ppf "writing tar header failed: %s" msg
 
   let write t sector_start buffers =
     Lwt_result.map_error (fun e -> `Block_write e)
@@ -364,51 +399,31 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
       let map = remove map key in
       Dict (root, map)
 
-  module Writer = struct
-    type out_channel = {
-      b: BLOCK.t;
-      (** offset in bytes *)
-      mutable offset: int64;
-      info: Mirage_block.info;
-    }
-    type 'a io = 'a Lwt.t
-    exception Read of BLOCK.error
-    exception Write of BLOCK.write_error
-    let really_write out_channel str =
-      assert (String.length str <= Tar.Header.length);
-      let data =
-        let cs = Cstruct.create Tar.Header.length in
-        Cstruct.blit_from_string str 0 cs 0 (String.length str);
-        cs
-      in
-      let sector_size = out_channel.info.sector_size in
-      let sector = Int64.(div out_channel.offset (of_int sector_size)) in
-      let block = Cstruct.create sector_size in
-      BLOCK.read out_channel.b sector [ block ] >>= function
-      | Error e -> raise (Read e)
-      | Ok () ->
-        let start_offset = Int64.to_int out_channel.offset mod sector_size in
-        Cstruct.blit data 0 block start_offset (Cstruct.length data);
-        BLOCK.write out_channel.b sector [ block ] >>= function
-        | Error e -> raise (Write e)
-        | Ok () ->
-          Lwt.return_unit
-  end
-  module HW = Tar.HeaderWriter(Lwt)(Writer)
+  let write_data info b offset buffer =
+    assert (String.length buffer <= Tar.Header.length);
+    let sector_size = info.Mirage_block.sector_size in
+    let sector = Int64.(div offset (of_int sector_size)) in
+    let block = Cstruct.create sector_size in
+    BLOCK.read b sector [ block ] >>= function
+    | Error e -> Lwt.return (Error (`Block e))
+    | Ok () ->
+      let start_offset = Int64.to_int offset mod sector_size in
+      Cstruct.blit_from_string buffer 0 block start_offset (String.length buffer);
+      BLOCK.write b sector [ block ] >>= function
+      | Error e -> Lwt.return (Error (`Block_write e))
+      | Ok () -> Lwt.return (Ok ())
 
   let write_header (t : t) header_start_bytes hdr =
-    let hw = Writer.{ b = t.b ; offset = header_start_bytes ; info = t.info } in
     (* it is important we write at level [Ustar] at most as we assume the
        header(s) taking up exactly 512 bytes. With [GNU] level extra blocks
        may be used for long names. *)
-    Lwt.catch
-      (fun () -> HW.write ~level:Tar.Header.Ustar hdr hw >|= function
-         | Ok () -> Ok ()
-         | Error `Msg msg -> Error (`Write_header msg))
-      (function
-        | Writer.Read e -> Lwt.return (Error (`Block e))
-        | Writer.Write e -> Lwt.return (Error (`Block_write e))
-        | exn -> raise exn)
+    let open Lwt_result.Infix in
+    Lwt_result.lift (Tar.encode_header ~level:Tar.Header.Ustar hdr) >>= fun datas ->
+    Lwt_list.fold_left_s (fun acc buf ->
+        Lwt_result.lift acc >>= fun off' ->
+        write_data t.info t.b off' buf >|= fun () ->
+        Int64.(add off' (of_int (String.length buf))))
+      (Ok header_start_bytes) datas
 
   let set t key data =
     Lwt_mutex.with_lock t.write_lock (fun () ->
@@ -486,7 +501,7 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
         in
         write t (succ data_start_sector) remaining_sectors >>>= fun () ->
         (* finally write header and first block *)
-        write_header t header_start_bytes hdr >>>= fun () ->
+        write_header t header_start_bytes hdr >>>= fun _new_offset ->
         (* read in slack at beginning which could include the header *)
         read_partial_sector t data_start_sector first_sector
           ~offset:0L ~length:data_start_sector_offset >>>= fun () ->
@@ -555,7 +570,7 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
           | Error _ as e -> e
         end >>>= fun (hdr, data_offset) ->
         let hdr = { hdr with Tar.Header.file_name = Mirage_kv.Key.to_string dest } in
-        write_header t Int64.(sub (mul data_offset (of_int Tar.Header.length)) (of_int Tar.Header.length)) hdr >>>= fun () ->
+        write_header t Int64.(sub (mul data_offset (of_int Tar.Header.length)) (of_int Tar.Header.length)) hdr >>>= fun _new_off ->
         t.map <- update_insert t.map dest hdr data_offset;
         t.map <- update_remove t.map source;
         Lwt_result.return ())
@@ -680,7 +695,7 @@ module Make_KV_RW (CLOCK : Mirage_clock.PCLOCK) (BLOCK : Mirage_block.S) = struc
             ~length:(sub sector_size last_sector_offset)
         end >>>= fun () ->
         write t to_zero_start_sector (Array.to_list data) >>>= fun () ->
-        write_header t header_start_bytes hdr >>>= fun () ->
+        write_header t header_start_bytes hdr >>>= fun _new_offset ->
         let tar_offset = div (sub t.end_of_archive (of_int Tar.Header.length)) (of_int Tar.Header.length) in
         t.end_of_archive <- end_bytes;
         t.map <- update_insert t.map key hdr tar_offset;
diff --git a/tar-eio.opam b/tar-eio.opam
index ce4e32e..f59ac83 100644
--- a/tar-eio.opam
+++ b/tar-eio.opam
@@ -22,7 +22,7 @@ bug-reports: "https://github.com/mirage/ocaml-tar/issues"
 depends: [
   "dune" {>= "2.9"}
   "ocaml" {>= "5.00.0"}
-  "eio" {>= "0.10.0" & < "0.12"}
+  "eio" {>= "1.1" & < "1.2"}
   "tar" {= version}
   "odoc" {with-doc}
 ]
diff --git a/unix/tar_lwt_unix.ml b/unix/tar_lwt_unix.ml
index 60cf251..cb7bcb5 100644
--- a/unix/tar_lwt_unix.ml
+++ b/unix/tar_lwt_unix.ml
@@ -15,57 +15,284 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
-open Lwt.Infix
-
-module Io = struct
-  type in_channel = Lwt_unix.file_descr
-  type 'a io = 'a Lwt.t
-  let really_read fd buf =
-    let len = Bytes.length buf in
-    let rec loop idx =
-      if idx = len then
-        Lwt.return_unit
-      else
-        Lwt_unix.read fd buf idx (len - idx) >>= fun n ->
-        loop (n + idx)
-    in
-    loop 0
-  let skip (ifd: Lwt_unix.file_descr) (n: int) =
-    Lwt_unix.(lseek ifd n SEEK_CUR) >|= ignore
-
-  type out_channel = Lwt_unix.file_descr
-  let really_write fd buf =
-    let len = String.length buf in
-    let rec loop idx =
-      if idx = len then
-        Lwt.return_unit
+type decode_error = [
+  | `Fatal of Tar.error
+  | `Unix of Unix.error * string * string
+  | `Unexpected_end_of_file
+  | `Msg of string
+]
+
+let pp_decode_error ppf = function
+  | `Fatal err -> Tar.pp_error ppf err
+  | `Unix (err, fname, arg) ->
+    Format.fprintf ppf "Unix error %s (function %s, arg %s)"
+      (Unix.error_message err) fname arg
+  | `Unexpected_end_of_file ->
+    Format.fprintf ppf "Unexpected end of file"
+  | `Msg msg ->
+    Format.fprintf ppf "Error %s" msg
+
+let safe f a =
+  let open Lwt.Infix in
+  Lwt.catch
+    (fun () -> f a >|= fun r -> Ok r)
+    (function
+      | Unix.Unix_error (e, f, a) -> Lwt.return (Error (`Unix (e, f, a)))
+      | e -> Lwt.reraise e)
+
+let read_complete fd buf len =
+  let open Lwt_result.Infix in
+  let rec loop offset =
+    if offset < len then
+      safe (Lwt_unix.read fd buf offset) (len - offset) >>= fun read ->
+      if read = 0 then
+        Lwt.return (Error `Unexpected_end_of_file)
       else
-        Lwt_unix.write_string fd buf idx (len - idx) >>= fun n ->
-        loop (idx + n)
-    in
-    loop 0
+        loop (offset + read)
+    else
+      Lwt.return (Ok ())
+  in
+  loop 0
+
+let seek fd n =
+  safe (Lwt_unix.lseek fd n) Unix.SEEK_CUR
+  |> Lwt_result.map ignore
+
+let safe_close fd =
+  Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit)
+
+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
 
-include Io
-module HeaderReader = Tar.HeaderReader(Lwt)(Io)
-module HeaderWriter = Tar.HeaderWriter(Lwt)(Io)
+type t = High.t
+
+let value v = Tar.High (High.inj v)
+
+let run t fd =
+  let open Lwt_result.Infix in
+  let rec run : type a. (a, [> decode_error ] as 'err, t) Tar.t -> (a, 'err) result Lwt.t = function
+    | Tar.Write str ->
+      safe (Lwt_unix.write_string fd str 0) (String.length str) >>= fun _write ->
+      Lwt_result.return ()
+    | Tar.Read len ->
+      let b = Bytes.make len '\000' in
+      safe (Lwt_unix.read fd b 0) len >>= fun read ->
+      if read = 0 then
+        Lwt_result.fail `Unexpected_end_of_file
+      else if len = read then
+        Lwt_result.return (Bytes.unsafe_to_string b)
+      else
+        Lwt_result.return (Bytes.sub_string b 0 read)
+    | Tar.Really_read len ->
+      let buf = Bytes.make len '\000' in
+      read_complete fd buf Tar.Header.length >|= fun () ->
+      Bytes.unsafe_to_string buf
+    | Tar.Seek len -> seek fd len
+    | Tar.Return value -> Lwt.return value
+    | Tar.High value -> High.prj value
+    | Tar.Bind (x, f) ->
+      run x >>= fun value -> run (f value) in
+  run t
+
+let fold f filename init =
+  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)
+
+let unix_err_to_msg = function
+  | `Unix (e, f, s) ->
+    `Msg (Format.sprintf "error %s in function %s %s"
+            (Unix.error_message e) f s)
+
+let copy ~dst_fd len =
+  let blen = 65536 in
+  let rec read_write ~dst_fd len =
+    if len = 0 then value (Lwt.return (Ok ()))
+    else
+      let ( let* ) = Tar.( let* ) in
+      let slen = min blen len in
+      let* str = Tar.really_read slen in
+      let* _written = Lwt_result.map_error unix_err_to_msg
+        (safe (Lwt_unix.write_string dst_fd str 0) slen) |> value in
+      read_write ~dst_fd (len - slen)
+  in
+  read_write ~dst_fd len
+
+let extract ?(filter = fun _ -> true) ~src dst =
+  let safe_close fd =
+    let open Lwt.Infix in
+    Lwt.catch
+      (fun () -> Lwt_unix.close fd)
+      (fun _ -> Lwt.return_unit)
+    >|= Result.ok in
+  let f ?global:_ hdr () =
+    let ( let* ) = Tar.( let* ) in
+    match filter hdr, hdr.Tar.Header.link_indicator with
+    | true, Tar.Header.Link.Normal ->
+      let* dst = Lwt_result.map_error
+        unix_err_to_msg
+        (safe Lwt_unix.(openfile (Filename.concat dst hdr.Tar.Header.file_name) [ O_WRONLY; O_CREAT ]) hdr.Tar.Header.file_mode)
+        |> value in
+      begin try
+        let* () = copy ~dst_fd:dst (Int64.to_int hdr.Tar.Header.file_size) in
+        let* () = value (safe_close dst) in
+        Tar.return (Ok ())
+      with exn ->
+        let* () = value (safe_close dst) in
+        Tar.return (Error (`Exn exn))
+      end
+    | _ ->
+      let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in
+      Tar.return (Ok ())
+  in
+  fold f src ()
 
 (** Return the header needed for a particular file on disk *)
-let header_of_file ?level (file: string) : Tar.Header.t Lwt.t =
+let header_of_file ?level file =
+  let open Lwt_result.Infix in
   let level = Tar.Header.compatibility level in
-  Lwt_unix.LargeFile.stat file >>= fun stat ->
-  Lwt_unix.getpwuid stat.Lwt_unix.LargeFile.st_uid >>= fun pwent ->
-  Lwt_unix.getgrgid stat.Lwt_unix.LargeFile.st_gid >>= fun grent ->
-  let file_mode   = stat.Lwt_unix.LargeFile.st_perm in
-  let user_id     = stat.Lwt_unix.LargeFile.st_uid in
-  let group_id    = stat.Lwt_unix.LargeFile.st_gid in
-  let file_size   = stat.Lwt_unix.LargeFile.st_size in
-  let mod_time    = Int64.of_float stat.Lwt_unix.LargeFile.st_mtime in
+  safe Lwt_unix.LargeFile.stat file >>= fun stat ->
+  let file_mode = stat.Lwt_unix.LargeFile.st_perm in
+  let user_id = stat.Lwt_unix.LargeFile.st_uid in
+  let group_id = stat.Lwt_unix.LargeFile.st_gid in
+  let file_size = stat.Lwt_unix.LargeFile.st_size in
+  let mod_time = Int64.of_float stat.Lwt_unix.LargeFile.st_mtime in
   let link_indicator = Tar.Header.Link.Normal in
-  let link_name   = "" in
-  let uname       = if level = V7 then "" else pwent.Lwt_unix.pw_name in
-  let gname       = if level = V7 then "" else grent.Lwt_unix.gr_name in
-  let devmajor    = if level = Ustar then stat.Lwt_unix.LargeFile.st_dev else 0 in
-  let devminor    = if level = Ustar then stat.Lwt_unix.LargeFile.st_rdev else 0 in
-  Lwt.return (Tar.Header.make ~file_mode ~user_id ~group_id ~mod_time ~link_indicator ~link_name
-    ~uname ~gname ~devmajor ~devminor file file_size)
+  let link_name = "" in
+  (if level = V7 then
+     Lwt.return (Ok "")
+   else
+     Lwt.catch
+       (fun () -> safe Lwt_unix.getpwuid stat.Lwt_unix.LargeFile.st_uid)
+       (function
+         | Not_found ->
+           Lwt.return (Error (`Msg ("No user entry found for UID")))
+         | e -> Lwt.reraise e) >|= fun pwent ->
+     pwent.Lwt_unix.pw_name) >>= fun uname ->
+  (if level = V7 then
+     Lwt.return (Ok "")
+   else
+     Lwt.catch
+       (fun () -> safe Lwt_unix.getgrgid stat.Lwt_unix.LargeFile.st_gid)
+       (function
+         | Not_found ->
+           Lwt.return (Error (`Msg ("No group entry found for GID")))
+         | e -> Lwt.reraise e) >|= fun grent ->
+     grent.Lwt_unix.gr_name) >>= fun gname ->
+  let devmajor = if level = Ustar then stat.Lwt_unix.LargeFile.st_dev else 0 in
+  let devminor = if level = Ustar then stat.Lwt_unix.LargeFile.st_rdev else 0 in
+  let hdr = Tar.Header.make ~file_mode ~user_id ~group_id ~mod_time ~link_indicator ~link_name
+      ~uname ~gname ~devmajor ~devminor file file_size
+  in
+  Lwt.return (Ok hdr)
+
+let write_strings fd datas =
+  let open Lwt_result.Infix in
+  Lwt_list.fold_left_s (fun acc d ->
+      Lwt_result.lift acc >>= fun _written ->
+      Lwt_result.map_error unix_err_to_msg
+        (safe (Lwt_unix.write_string fd d 0) (String.length d)))
+    (Ok 0) datas >|= fun _written ->
+  ()
+
+let write_header ?level header fd =
+  let open Lwt_result.Infix in
+  Lwt_result.lift (Tar.encode_header ?level header) >>= fun header_strings ->
+  write_strings fd header_strings
+
+let copy ~src_fd ~dst_fd len =
+  let open Lwt_result.Infix in
+  let blen = 65536 in
+  let buffer = Bytes.make blen '\000' in
+  let rec read_write ~src_fd ~dst_fd len =
+    if len = 0 then
+      Lwt.return (Ok ())
+    else
+      let l = min blen len in
+      Lwt_result.map_error
+        (function
+          | `Unix _ as e -> unix_err_to_msg e
+          | `Unexpected_end_of_file ->
+            `Msg "Unexpected end of file")
+        (read_complete src_fd buffer l) >>= fun () ->
+      Lwt_result.map_error unix_err_to_msg
+        (safe (Lwt_unix.write dst_fd buffer 0) l) >>= fun _written ->
+      read_write ~src_fd ~dst_fd (len - l)
+  in
+  read_write ~src_fd ~dst_fd len
+
+let append_file ?level ?header filename fd =
+  let open Lwt_result.Infix in
+  (match header with
+   | None -> header_of_file ?level filename
+   | Some x -> Lwt.return (Ok x)) >>= fun header ->
+  write_header ?level header fd >>= fun () ->
+  Lwt_result.map_error unix_err_to_msg
+    (safe Lwt_unix.(openfile filename [ O_RDONLY ]) 0) >>= fun src ->
+  (* TOCTOU [also, header may not be valid for file] *)
+  Lwt.finalize
+    (fun () -> copy ~src_fd:src ~dst_fd:fd
+        (Int64.to_int header.Tar.Header.file_size))
+    (fun () -> safe_close src)
+
+let write_global_extended_header ?level header fd =
+  let open Lwt_result.Infix in
+  Lwt_result.lift (Tar.encode_global_extended_header ?level header) >>= fun header_strings ->
+  write_strings fd header_strings
+
+let write_end fd =
+  write_strings fd [ Tar.Header.zero_block ; Tar.Header.zero_block ]
+
+let create ?level ?global ?(filter = fun _ -> true) ~src dst =
+  let open Lwt_result.Infix in
+  Lwt_result.map_error unix_err_to_msg
+    (safe Lwt_unix.(openfile dst [ O_WRONLY ; O_CREAT ]) 0o644) >>= fun dst_fd ->
+  Lwt.finalize
+    (fun () ->
+       (match global with
+        | None -> Lwt.return (Ok ())
+        | Some hdr -> write_global_extended_header ?level hdr dst_fd) >>= fun () ->
+       let rec copy_files directory =
+         safe Lwt_unix.opendir directory >>= fun dir ->
+         Lwt.finalize
+           (fun () ->
+              let rec next () =
+                try
+                  safe Lwt_unix.readdir dir >>= fun name ->
+                  let filename = Filename.concat directory name in
+                  header_of_file ?level filename >>= fun header ->
+                  if filter header then
+                    match header.Tar.Header.link_indicator with
+                    | Normal ->
+                      append_file ?level ~header filename dst_fd >>= fun () ->
+                      next ()
+                    | Directory ->
+                      (* TODO first finish curdir (and close the dir fd), then go deeper *)
+                      copy_files filename >>= fun () ->
+                      next ()
+                    | _ -> Lwt.return (Ok ()) (* NYI *)
+                  else Lwt.return (Ok ())
+                with End_of_file -> Lwt.return (Ok ())
+              in
+              next ())
+           (fun () ->
+              Lwt.catch
+                (fun () -> Lwt_unix.closedir dir)
+                (fun _ -> Lwt.return_unit))
+       in
+       copy_files src >>= fun () ->
+       write_end dst_fd)
+    (fun () -> safe_close dst_fd)
diff --git a/unix/tar_lwt_unix.mli b/unix/tar_lwt_unix.mli
index 9b97e4d..106a9dc 100644
--- a/unix/tar_lwt_unix.mli
+++ b/unix/tar_lwt_unix.mli
@@ -16,20 +16,67 @@
 
 (** Lwt_unix I/O for tar-formatted data *)
 
-val really_read: Lwt_unix.file_descr -> bytes -> unit Lwt.t
-(** [really_read fd buf] fills [buf] with data from [fd] or fails
-    with {!Stdlib.End_of_file}. *)
+type decode_error = [
+  | `Fatal of Tar.error
+  | `Unix of Unix.error * string * string
+  | `Unexpected_end_of_file
+  | `Msg of string
+]
 
-val really_write: Lwt_unix.file_descr -> string -> unit Lwt.t
-(** [really_write fd buf] writes the full contents of [buf] to
-    [fd] or fails with {!Stdlib.End_of_file}. *)
+val pp_decode_error : Format.formatter -> decode_error -> unit
 
-val skip : Lwt_unix.file_descr -> int -> unit Lwt.t
-(** [skip fd n] reads [n] bytes from [fd] and discards them. If possible, you
-    should use [Lwt_unix.lseek fd n Lwt_unix.SEEK_CUR] instead. *)
+type t
 
-(** Return the header needed for a particular file on disk. *)
-val header_of_file : ?level:Tar.Header.compatibility -> string -> Tar.Header.t Lwt.t
+val value : ('a, 'err) result Lwt.t -> ('a, 'err, t) Tar.t
 
-module HeaderReader : Tar.HEADERREADER with type in_channel = Lwt_unix.file_descr and type 'a io = 'a Lwt.t
-module HeaderWriter : Tar.HEADERWRITER with type out_channel = Lwt_unix.file_descr and type 'a io = 'a Lwt.t
+(** [fold f filename acc] folds over the tar archive. The function [f] is called
+    for each [hdr : Tar.Header.t]. It should forward the position in the file
+    descriptor by [hdr.Tar.Header.file_size]. *)
+val fold :
+  (?global:Tar.Header.Extended.t -> Tar.Header.t -> 'a ->
+  ('a, [> decode_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
+    [false], is skipped. *)
+val extract :
+  ?filter:(Tar.Header.t -> bool) ->
+  src:string -> string ->
+  (unit, [> `Exn of exn | decode_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]
+    is skipped. *)
+val create : ?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) ]) 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
+
+(** [append_file ~level ~header filename fd] appends the contents of [filename]
+    to the tar archive [fd]. If [header] is not provided, {header_of_file} is
+    used for constructing a header. *)
+val append_file : ?level:Tar.Header.compatibility -> ?header:Tar.Header.t ->
+  string -> Lwt_unix.file_descr ->
+  (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t
+
+(** [write_header ~level hdr fd] writes the header [hdr] to [fd]. *)
+val write_header : ?level:Tar.Header.compatibility ->
+  Tar.Header.t -> Lwt_unix.file_descr ->
+  (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t
+
+(** [write_global_extended_header ~level hdr fd] writes the extended header [hdr] to
+    [fd]. *)
+val write_global_extended_header : ?level:Tar.Header.compatibility ->
+  Tar.Header.Extended.t -> Lwt_unix.file_descr ->
+  (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t
+
+(** [write_end fd] writes the tar end marker to [fd]. *)
+val write_end : Lwt_unix.file_descr -> (unit, [ `Msg of string ]) result Lwt.t
diff --git a/unix/tar_unix.ml b/unix/tar_unix.ml
index a1c1548..761f3b9 100644
--- a/unix/tar_unix.ml
+++ b/unix/tar_unix.ml
@@ -15,60 +15,284 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
-module Direct = struct
-  type 'a t = 'a
-  let return x = x
-  let ( >>= ) m f = f m
-end
+let ( let* ) = Result.bind
+
+let rec safe f a =
+  try Ok (f a) with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> safe f a
+  | Unix.Unix_error (e, f, s) -> Error (`Unix (e, f, s))
+
+let safe_close fd =
+  try Unix.close fd with _ -> ()
 
-module Driver = struct
-  type 'a io = 'a Direct.t
-  type in_channel = Unix.file_descr
-  type out_channel = Unix.file_descr
-
-  let rec with_restart op fd buf off len =
-    try op fd buf off len with
-      Unix.Unix_error (Unix.EINTR,_,_) ->
-      with_restart op fd buf off len
-
-  let really_read fd buf =
-    let len = Bytes.length buf in
-    let rec loop offset =
-      if offset < len then
-        let n = with_restart Unix.read fd buf offset (len - offset) in
-        if n = 0 then raise End_of_file;
+let read_complete fd buf len =
+  let rec loop offset =
+    if offset < len then
+      let* n = safe (Unix.read fd buf offset) (len - offset) in
+      if n = 0 then
+        Error `Unexpected_end_of_file
+      else
         loop (offset + n)
-    in
-    loop 0
+    else
+      Ok ()
+  in
+  loop 0
+
+let seek fd n =
+  safe (Unix.lseek fd n) Unix.SEEK_CUR
+  |> Result.map ignore
+
+type error = [
+  | `Fatal of Tar.error
+  | `Unix of Unix.error * string * string
+  | `Unexpected_end_of_file
+  | `Msg of string
+]
 
-  let skip fd n =
-    ignore (Unix.lseek fd n Unix.SEEK_CUR)
+let pp_error ppf = function
+  | `Fatal err -> Tar.pp_error ppf err
+  | `Unix (err, fname, arg) ->
+    Format.fprintf ppf "Unix error %s (function %s, arg %s)"
+      (Unix.error_message err) fname arg
+  | `Unexpected_end_of_file ->
+    Format.fprintf ppf "Unexpected end of file"
+  | `Msg msg ->
+    Format.fprintf ppf "Error %s" msg
 
-  let really_write fd buf =
-    let offset = ref 0 in
-    while !offset < String.length buf do
-      offset := !offset + with_restart Unix.write_substring fd buf !offset (String.length buf - !offset)
-    done
+(* XXX(dinosaure): This is a trick to pass from a value ['a] to a value
+   [('a, High.t) Tar.io]. It may seem that the code is "unsafe" but physically
+   the value remains the same (we mainly want to decorate the type of our value
+   with new information). For more information on this trick, it is well
+   described in this research paper:
+
+   https://www.cl.cam.ac.uk/~jdy22/papers/lightweight-higher-kinded-polymorphism.pdf
+*)
+module High : sig
+  type t
+  type 'a s = 'a
+
+  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
+
+  external inj : 'a -> 'b = "%identity"
+  external prj : 'a -> 'b = "%identity"
 end
 
-module HeaderReader = Tar.HeaderReader(Direct)(Driver)
-module HeaderWriter = Tar.HeaderWriter(Direct)(Driver)
+type t = High.t
+
+let value v = Tar.High (High.inj v)
+
+let run t fd =
+  let rec run : type a. (a, _ as 'err, t) Tar.t -> (a, 'err) result = function
+    | Tar.Write str ->
+      let* _write = safe (Unix.write_substring fd str 0) (String.length str) in
+      Ok ()
+    | Tar.Read len ->
+      let b = Bytes.make len '\000' in
+      let* read = safe (Unix.read fd b 0) len in
+      if read = 0 then
+        Error `Unexpected_end_of_file
+      else if len = read then
+        Ok (Bytes.unsafe_to_string b)
+      else
+        Ok (Bytes.sub_string b 0 read)
+    | Tar.Really_read len ->
+      let buf = Bytes.make len '\000' in
+      begin match read_complete fd buf len with
+      | Ok () -> Ok (Bytes.unsafe_to_string buf)
+      | Error _ as err -> err end
+    | Tar.Seek len -> seek fd len
+    | Tar.Return value -> value
+    | Tar.High value -> High.prj value
+    | Tar.Bind (x, f) ->
+      match run x with
+      | Ok value -> run (f value)
+      | Error _ as err -> err in
+  run t
 
-include Driver
+let fold f filename init =
+  let* fd = safe Unix.(openfile filename [ O_RDONLY ]) 0 in
+  Fun.protect
+    ~finally:(fun () -> safe_close fd)
+    (fun () -> run (Tar.fold f init) fd)
 
-  (** Return the header needed for a particular file on disk *)
-let header_of_file ?level (file: string) : Tar.Header.t =
+let unix_err_to_msg = function
+  | `Unix (e, f, s) ->
+    `Msg (Format.sprintf "error %s in function %s %s"
+            (Unix.error_message e) f s)
+
+let copy ~dst_fd len =
+  let blen = 65536 in
+  let rec read_write ~dst_fd len =
+    let ( let* ) = Tar.( let* ) in
+    if len = 0 then Tar.return (Ok ())
+    else
+      let slen = min blen len in
+      let* str = Tar.really_read (min blen len) in
+      safe (Unix.write_substring dst_fd str 0) slen
+      |> Result.map_error unix_err_to_msg
+      |> function
+      | Ok _ -> read_write ~dst_fd (len - slen)
+      | Error _ as err -> Tar.return err
+  in
+  read_write ~dst_fd len
+
+let extract ?(filter = fun _ -> true) ~src dst =
+  let f ?global:_ hdr () =
+    if filter hdr then
+      match hdr.Tar.Header.link_indicator with
+      | Tar.Header.Link.Normal ->
+        begin match Result.map_error unix_err_to_msg
+            (safe Unix.(openfile (Filename.concat dst hdr.Tar.Header.file_name)
+                          [ O_WRONLY ; O_CREAT ]) hdr.Tar.Header.file_mode) with
+        | Error _ as err -> Tar.return err
+        | Ok dst ->
+          try copy ~dst_fd:dst (Int64.to_int hdr.Tar.Header.file_size)
+          with exn -> safe_close dst; Tar.return (Error (`Exn exn))
+        end
+        (* TODO set owner / mode / mtime etc. *)
+      | _ ->
+        (* TODO handle directories, links, etc. *)
+        let ( let* ) = Tar.( let* ) in
+        let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in
+        Tar.return (Ok ())
+    else
+      let ( let* ) = Tar.( let* ) in
+      let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in
+      Tar.return (Ok ())
+  in
+  fold f src ()
+
+(** Return the header needed for a particular file on disk *)
+let header_of_file ?level file =
   let level = Tar.Header.compatibility level in
-  let stat = Unix.LargeFile.lstat file in
+  let* stat = safe Unix.LargeFile.lstat file in
   let file_mode = stat.Unix.LargeFile.st_perm in
   let user_id = stat.Unix.LargeFile.st_uid in
   let group_id = stat.Unix.LargeFile.st_gid in
   let mod_time = Int64.of_float stat.Unix.LargeFile.st_mtime in
+  (* TODO evaluate stat.st_kind *)
   let link_indicator = Tar.Header.Link.Normal in
   let link_name = "" in
-  let uname = if level = V7 then "" else (Unix.getpwuid stat.Unix.LargeFile.st_uid).Unix.pw_name in
+  let* uname =
+    if level = V7 then
+      Ok ""
+    else
+      try
+        let* passwd_entry = safe Unix.getpwuid stat.Unix.LargeFile.st_uid in
+        Ok passwd_entry.Unix.pw_name
+      with Not_found -> Error (`Msg ("No user entry found for UID"))
+  in
   let devmajor = if level = Ustar then stat.Unix.LargeFile.st_dev else 0 in
-  let gname = if level = V7 then "" else (Unix.getgrgid stat.Unix.LargeFile.st_gid).Unix.gr_name in
+  let* gname =
+    if level = V7 then
+      Ok ""
+    else
+      try
+        let* passwd_entry = safe Unix.getgrgid stat.Unix.LargeFile.st_gid in
+        Ok passwd_entry.Unix.gr_name
+      with Not_found -> Error (`Msg "No group entry found for GID")
+  in
   let devminor = if level = Ustar then stat.Unix.LargeFile.st_rdev else 0 in
-  Tar.Header.make ~file_mode ~user_id ~group_id ~mod_time ~link_indicator ~link_name
-    ~uname ~gname ~devmajor ~devminor file stat.Unix.LargeFile.st_size
+  Ok (Tar.Header.make ~file_mode ~user_id ~group_id ~mod_time ~link_indicator ~link_name
+        ~uname ~gname ~devmajor ~devminor file stat.Unix.LargeFile.st_size)
+
+let write_strings fd datas =
+  let* _written =
+    List.fold_left (fun acc d ->
+        let* _written = acc in
+        Result.map_error unix_err_to_msg
+          (safe (Unix.write_substring fd d 0) (String.length d)))
+      (Ok 0) datas
+  in
+  Ok ()
+
+let write_header ?level header fd =
+  let* header_strings = Tar.encode_header ?level header in
+  write_strings fd header_strings
+
+let copy ~src_fd ~dst_fd len =
+  let blen = 65536 in
+  let buffer = Bytes.make blen '\000' in
+  let rec read_write ~src_fd ~dst_fd len =
+    if len = 0 then Ok ()
+    else
+      let l = min blen len in
+      let* () =
+        Result.map_error
+          (function
+             | `Unix _ as e -> unix_err_to_msg e
+             | `Unexpected_end_of_file ->
+               `Msg "Unexpected end of file")
+          (read_complete src_fd buffer l)
+      in
+      let* _written =
+        Result.map_error unix_err_to_msg
+          (safe (Unix.write dst_fd buffer 0) l)
+      in
+      read_write ~src_fd ~dst_fd (len - l)
+  in
+  read_write ~src_fd ~dst_fd len
+
+let append_file ?level ?header filename fd =
+  let* header = match header with
+    | None -> header_of_file ?level filename
+    | Some x -> Ok x
+  in
+  let* () = write_header ?level header fd in
+  let* src =
+    Result.map_error unix_err_to_msg
+      (safe Unix.(openfile filename [ O_RDONLY ]) 0)
+  in
+  (* TOCTOU [also, header may not be valid for file] *)
+  Fun.protect ~finally:(fun () -> safe_close src)
+    (fun () -> copy ~src_fd:src ~dst_fd:fd
+        (Int64.to_int header.Tar.Header.file_size))
+
+let write_global_extended_header ?level header fd =
+  let* header_strings = Tar.encode_global_extended_header ?level header in
+  write_strings fd header_strings
+
+let write_end fd =
+  write_strings fd [ Tar.Header.zero_block ; Tar.Header.zero_block ]
+
+let create ?level ?global ?(filter = fun _ -> true) ~src dst =
+  let* dst_fd =
+    Result.map_error unix_err_to_msg
+      (safe Unix.(openfile dst [ O_WRONLY ; O_CREAT ]) 0o644)
+  in
+  Fun.protect ~finally:(fun () -> safe_close dst_fd)
+    (fun () ->
+       let* () = match global with
+         | None -> Ok ()
+         | Some hdr -> write_global_extended_header ?level hdr dst_fd
+       in
+       let rec copy_files directory =
+         let* dir = safe Unix.opendir directory in
+         Fun.protect ~finally:(fun () -> try Unix.closedir dir with _ -> ())
+           (fun () ->
+              let rec next () =
+                try
+                  let* name = safe Unix.readdir dir in
+                  let filename = Filename.concat directory name in
+                  let* header = header_of_file ?level filename in
+                  if filter header then
+                    match header.Tar.Header.link_indicator with
+                    | Normal ->
+                      let* () = append_file ?level ~header filename dst_fd in
+                      next ()
+                    | Directory ->
+                      (* TODO first finish curdir (and close the dir fd), then go deeper *)
+                      let* () = copy_files filename in
+                      next ()
+                    | _ -> Ok () (* NYI *)
+                  else Ok ()
+                with End_of_file -> Ok ()
+              in
+              next ())
+       in
+       let* () = copy_files src in
+       write_end dst_fd)
diff --git a/unix/tar_unix.mli b/unix/tar_unix.mli
index b21ad57..77f1b7c 100644
--- a/unix/tar_unix.mli
+++ b/unix/tar_unix.mli
@@ -16,20 +16,68 @@
 
 (** Unix I/O for tar-formatted data. *)
 
-val really_read: Unix.file_descr -> bytes -> unit
-(** [really_read fd buf] fills [buf] with data from [fd] or raises
-   {!Stdlib.End_of_file}. *)
+type error = [
+  | `Fatal of Tar.error
+  | `Unix of Unix.error * string * string
+  | `Unexpected_end_of_file
+  | `Msg of string
+]
 
-val really_write: Unix.file_descr -> string -> unit
-(** [really_write fd buf] writes the full contents of [buf] to [fd]
-    or {!Stdlib.End_of_file}. *)
+type t
 
-val skip : Unix.file_descr -> int -> unit
-(** [skip fd n] reads [n] bytes from [fd] and discards them. If possible, you
-    should use [Unix.lseek fd n Unix.SEEK_CUR] instead. *)
+val pp_error : Format.formatter -> error -> unit
 
-(** Return the header needed for a particular file on disk. *)
-val header_of_file : ?level:Tar.Header.compatibility -> string -> Tar.Header.t
+val run : ('a, [> error ] as 'b, t) Tar.t -> Unix.file_descr -> ('a, 'b) result
+val value : ('a, 'err) result -> ('a, 'err, t) Tar.t
 
-module HeaderReader : Tar.HEADERREADER with type in_channel = Unix.file_descr and type 'a io = 'a
-module HeaderWriter : Tar.HEADERWRITER with type out_channel = Unix.file_descr and type 'a io = 'a
+(** [fold f filename acc] folds over the tar archive. The function [f] is called
+    for each [hdr : Tar.Header.t]. It should forward the position in the file
+    descriptor by [hdr.Tar.Header.file_size]. *)
+val fold :
+  (?global:Tar.Header.Extended.t -> Tar.Header.t -> 'a ->
+   ('a, error, t) Tar.t) ->
+  string -> 'a -> ('a, error) result
+
+(** [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
+    [false], is skipped. *)
+val extract :
+  ?filter:(Tar.Header.t -> bool) ->
+  src:string -> string ->
+  (unit, [> `Exn of exn | error ]) result
+
+(** [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]
+    is skipped. *)
+val create : ?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) ]) result
+
+(** [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
+
+(** [append_file ~level ~header filename fd] appends the contents of [filename]
+    to the tar archive [fd]. If [header] is not provided, {header_of_file} is
+    used for constructing a header. *)
+val append_file : ?level:Tar.Header.compatibility -> ?header:Tar.Header.t ->
+  string -> Unix.file_descr ->
+  (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result
+
+(** [write_header ~level hdr fd] writes the header [hdr] to [fd]. *)
+val write_header : ?level:Tar.Header.compatibility ->
+  Tar.Header.t -> Unix.file_descr ->
+  (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result
+
+(** [write_global_extended_header ~level hdr fd] writes the extended header [hdr] to
+    [fd]. *)
+val write_global_extended_header : ?level:Tar.Header.compatibility ->
+  Tar.Header.Extended.t -> Unix.file_descr ->
+  (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result
+
+(** [write_end fd] writes the tar end marker to [fd]. *)
+val write_end : Unix.file_descr -> (unit, [> `Msg of string ]) result


Test patch:
diff --git a/lib_test/dune b/lib_test/dune
index e355bb1..79ed943 100644
--- a/lib_test/dune
+++ b/lib_test/dune
@@ -9,4 +9,5 @@
   alcotest-lwt
   lwt
   tar-unix
-  tar-mirage))
+  tar-mirage
+))
diff --git a/lib_test/global_extended_headers_test.ml b/lib_test/global_extended_headers_test.ml
index a5ae6de..a4ef1ab 100644
--- a/lib_test/global_extended_headers_test.ml
+++ b/lib_test/global_extended_headers_test.ml
@@ -1,37 +1,5 @@
 let level = Tar.Header.Ustar
 
-module Writer = struct
-  type out_channel = Stdlib.out_channel
-  type 'a io = 'a
-  let really_write oc str =
-    output_string oc str
-end
-
-module HW = Tar.HeaderWriter
-  (struct type 'a t = 'a
-          let ( >>= ) x f = f x
-          let return x = x end)
-  (Writer)
-
-module Reader = struct
-  type in_channel = Stdlib.in_channel
-  type 'a io = 'a
-  let really_read ic buf =
-    really_input ic buf 0 (Bytes.length buf)
-  let skip ic len =
-    let cur = pos_in ic in
-    seek_in ic (cur + len)
-  let read ic buf =
-    let max = Bytes.length buf in
-    input ic buf 0 max
-end
-
-module HR = Tar.HeaderReader
-  (struct type 'a t = 'a
-          let ( >>= ) x f = f x
-          let return x = x end)
-  (Reader)
-
 let make_extended user_id =
   Tar.Header.Extended.make ~user_id ()
 
@@ -41,92 +9,69 @@ let make_file =
   let name = "file" ^ string_of_int !gen in
   incr gen;
   let hdr = Tar.Header.make name 0L in
-  hdr, fun cout ->
-       Tar.Header.zero_padding hdr
-       |> output_string cout
+  hdr
+
+let ( let* ) = Result.bind
 
 (* Tests that global and per-file extended headers correctly override
    each other. *)
 let use_global_extended_headers _test_ctxt =
   (* Write an archive using global and per-file pax extended headers *)
   begin try Sys.remove "test.tar" with _ -> () end;
-  let cout = open_out_bin "test.tar" in
+  let cout = Unix.openfile "test.tar" [ Unix.O_CREAT ; Unix.O_WRONLY ] 0o644 in
   let g0 = make_extended 1000 in
-  let hdr, f = make_file () in
-  match HW.write_global_extended_header g0 cout with
-  | Error `Msg msg -> Alcotest.failf "failed to write header %s" msg
+  let g1 = make_extended 3000 in
+  match
+    Fun.protect ~finally:(fun () -> Unix.close cout)
+      (fun () ->
+         let* () = Tar_unix.write_global_extended_header ~level g0 cout in
+         let hdr = make_file () in
+         let* () = Tar_unix.write_header ~level hdr cout in
+         let hdr = make_file () in
+         let hdr = { hdr with Tar.Header.extended = Some (make_extended 2000) } in
+         let* () = Tar_unix.write_header ~level hdr cout in
+         let hdr = make_file () in
+         let* () = Tar_unix.write_header ~level hdr cout in
+         let hdr = make_file () in
+         let* () = Tar_unix.write_global_extended_header ~level g1 cout in
+         let* () = Tar_unix.write_header ~level hdr cout in
+         Tar_unix.write_end cout)
+  with
+  | Error `Msg msg -> Alcotest.failf "failed to write something: %s" msg
+  | Error `Unix (err, f, a) ->
+    Alcotest.failf "failed to write: unix error %s %s %s" (Unix.error_message err) f a
   | Ok () ->
-    match HW.write ~level hdr cout with
-    | Error `Msg msg -> Alcotest.failf "failed to write header %s" msg
-    | Ok () ->
-      f cout;
-      let hdr, f = make_file () in
-      let hdr = { hdr with Tar.Header.extended = Some (make_extended 2000) } in
-      match HW.write ~level hdr cout with
-      | Error `Msg msg -> Alcotest.failf "failed to write header %s" msg
-      | Ok () ->
-        f cout;
-        let hdr, f = make_file () in
-        match HW.write ~level hdr cout with
-        | Error `Msg msg -> Alcotest.failf "failed to write header %s" msg
-        | Ok () ->
-          f cout;
-          let g1 = make_extended 3000 in
-          let hdr, f = make_file () in
-          match HW.write_global_extended_header g1 cout with
-          | Error `Msg msg -> Alcotest.failf "failed to write header %s" msg
-          | Ok () ->
-            match HW.write ~level hdr cout with
-            | Error `Msg msg -> Alcotest.failf "failed to write header %s" msg
-            | Ok () ->
-              f cout;
-              Writer.really_write cout Tar.Header.zero_block;
-              Writer.really_write cout Tar.Header.zero_block;
-              close_out cout;
-              (* Read the same archive, testing that headers have been squashed. *)
-              let cin = open_in_bin "test.tar" in
-              let global = ref None in
-              let header =
-                let pp ppf hdr = Fmt.pf ppf "%s" (Tar.Header.Extended.to_detailed_string hdr) in
-                Alcotest.testable (fun ppf hdr -> Fmt.pf ppf "%a" Fmt.(option pp) hdr) ( = )
-              in
-              ( match HR.read ~global:!global cin with
-                | Ok (hdr, global') ->
-                  Alcotest.check header "expected global header" (Some g0) global';
-                  global := global';
-                  Alcotest.(check int) "expected user" 1000 hdr.Tar.Header.user_id;
-                  let to_skip = Tar.Header.(Int64.to_int (to_sectors hdr) * length) in
-                  Reader.skip cin to_skip;
-                | Error `Eof -> failwith "Couldn't read header, end of file"
-                | Error (`Fatal err) -> Fmt.failwith "Couldn't read header: %a" Tar.pp_error err );
-              ( match HR.read ~global:!global cin with
-                | Ok (hdr, global') ->
-                  Alcotest.check header "expected global header" (Some g0) global';
-                  global := global';
-                  Alcotest.(check int) "expected user" 2000 hdr.Tar.Header.user_id;
-                  let to_skip = Tar.Header.(Int64.to_int (to_sectors hdr) * length) in
-                  Reader.skip cin to_skip;
-                | Error _ -> failwith "Couldn't read header" );
-              ( match HR.read ~global:!global cin with
-                | Ok (hdr, global') ->
-                  Alcotest.check header "expected global header" (Some g0) global';
-                  global := global';
-                  Alcotest.(check int) "expected user" 1000 hdr.Tar.Header.user_id;
-                  let to_skip = Tar.Header.(Int64.to_int (to_sectors hdr) * length) in
-                  Reader.skip cin to_skip;
-                | Error _ -> failwith "Couldn't read header" );
-              ( match HR.read ~global:!global cin with
-                | Ok (hdr, global') ->
-                  Alcotest.check header "expected global header" (Some g1) global';
-                  global := global';
-                  Alcotest.(check int) "expected user" 3000 hdr.Tar.Header.user_id;
-                  let to_skip = Tar.Header.(Int64.to_int (to_sectors hdr) * length) in
-                  Reader.skip cin to_skip;
-                | Error _ -> failwith "Couldn't read header" );
-              ( match HR.read ~global:!global cin with
-                | Error `Eof -> ()
-                | _ -> failwith "Should have found EOF");
-              ()
+    (* Read the same archive, testing that headers have been squashed. *)
+    let header =
+      let pp ppf hdr = Fmt.pf ppf "%s" (Tar.Header.Extended.to_detailed_string hdr) in
+      Alcotest.testable (fun ppf hdr -> Fmt.pf ppf "%a" Fmt.(option pp) hdr) ( = )
+    in
+    let f ?global hdr idx =
+      let ( let* ) = Tar.( let* ) in
+      let* _pos = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in
+      match idx with
+      | 0 ->
+        Alcotest.check header "expected global header" (Some g0) global;
+        Alcotest.(check int) "expected user" 1000 hdr.Tar.Header.user_id;
+        Tar.return (Ok 1)
+      | 1 ->
+        Alcotest.check header "expected global header" (Some g0) global;
+        Alcotest.(check int) "expected user" 2000 hdr.Tar.Header.user_id;
+        Tar.return (Ok 2)
+      | 2 ->
+        Alcotest.check header "expected global header" (Some g0) global;
+        Alcotest.(check int) "expected user" 1000 hdr.Tar.Header.user_id;
+        Tar.return (Ok 3)
+      | 3 ->
+        Alcotest.check header "expected global header" (Some g1) global;
+        Alcotest.(check int) "expected user" 3000 hdr.Tar.Header.user_id;
+        Tar.return (Ok 4)
+      | _ -> Alcotest.fail "too many headers"
+    in
+    match Tar_unix.fold f "test.tar" 0 with
+    | Ok 4 -> ()
+    | Ok n -> Alcotest.failf "early abort, expected 4, received %u" n
+    | Error e -> Alcotest.failf "failed to read: %a" Tar_unix.pp_error e
 
 let () =
   let suite = "tar - pax global extended headers", [
diff --git a/lib_test/parse_test.ml b/lib_test/parse_test.ml
index 05ee8e2..30f303b 100644
--- a/lib_test/parse_test.ml
+++ b/lib_test/parse_test.ml
@@ -31,26 +31,21 @@ module Unix = struct
     if Sys.win32 then truncate (convert_path `Windows path) else truncate path
 end
 
-let list fd =
-  let rec loop global acc =
-    match Tar_unix.HeaderReader.read ~global fd with
-    | Ok (hdr, global) ->
-      print_endline hdr.Tar.Header.file_name;
-      Tar_unix.skip fd
-        (Int64.to_int hdr.Tar.Header.file_size + Tar.Header.compute_zero_padding_length hdr);
-      loop global (hdr :: acc)
-    | Error `Eof ->
-      List.rev acc
-    | Error `Fatal e -> Alcotest.failf "unexpected error: %a" Tar.pp_error e
+let list filename =
+  let f ?global:_ hdr acc =
+    print_endline hdr.Tar.Header.file_name;
+    let ( let* ) = Tar.( let* ) in
+    let* _pos = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in
+    Tar.return (Ok (hdr :: acc))
   in
-  let r = loop None [] in
-  List.iter (fun h -> print_endline h.Tar.Header.file_name) r;
-  r
+  match Tar_unix.fold f filename [] with
+  | Ok acc -> List.rev acc
+  | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_error e
 
 let pp_header f x = Fmt.pf f "%s" (Tar.Header.to_detailed_string x)
 let header = Alcotest.testable pp_header ( = )
 
-let error = Alcotest.testable Tar.pp_error ( = )
+let error : Tar.error Alcotest.testable = Alcotest.testable Tar.pp_error ( = )
 
 let link = Alcotest.testable (Fmt.of_to_string Tar.Header.Link.to_string) ( = )
 
@@ -104,10 +99,8 @@ let with_tar ?(level:Tar.Header.compatibility option) ?files ?(sector_size = 512
 
 let can_read_tar () =
   with_tar () @@ fun tar_filename files ->
-  let fd = Unix.openfile tar_filename [ O_RDONLY; O_CLOEXEC ] 0 in
-  let files' = List.map (fun t -> t.Tar.Header.file_name) (list fd) in
+  let files' = List.map (fun t -> t.Tar.Header.file_name) (list tar_filename) in
   flush stdout;
-  Unix.close fd;
   let missing = set_difference files files' in
   let missing' = set_difference files' files in
   Alcotest.(check (list string)) "missing" [] missing;
@@ -121,53 +114,45 @@ let can_write_pax () =
   let fd = Unix.openfile filename [ O_CREAT; O_WRONLY; O_CLOEXEC ] 0o0644 in
   Fun.protect
     (fun () ->
-      let hdr = Tar.Header.make ~user_id "test" 0L in
-      match Tar_unix.HeaderWriter.write hdr fd with
+      let header = Tar.Header.make ~user_id "test" 0L in
+      match Tar_unix.write_header header fd with
       | Ok () ->
-        Tar_unix.really_write fd Tar.Header.zero_block;
-        Tar_unix.really_write fd Tar.Header.zero_block;
+        (match Tar_unix.write_end fd with
+         | Ok () -> ()
+         | Error `Msg msg ->
+           Alcotest.failf "error writing end %s" msg)
       | Error `Msg msg ->
         Alcotest.failf "error writing header %s" msg
+      | Error `Unix (e, f, a) ->
+        Alcotest.failf "error writing header - unix error %s %s %s"
+          (Unix.error_message e) f a
     ) ~finally:(fun () -> Unix.close fd);
   (* Read it back and verify the header was read *)
-  let fd = Unix.openfile filename [ O_RDONLY; O_CLOEXEC ] 0 in
-  Fun.protect
-    (fun () ->
-      match list fd with
-      | [ one ] -> Alcotest.(check int) "user_id" user_id one.Tar.Header.user_id
-      | xs -> Alcotest.failf "Headers = %a" (Fmt.list pp_header) xs
-    ) ~finally:(fun () -> Unix.close fd)
-
+  match list filename with
+  | [ one ] -> Alcotest.(check int) "user_id" user_id one.Tar.Header.user_id
+  | xs -> Alcotest.failf "Headers = %a" (Fmt.list pp_header) xs
 
 let can_list_longlink_tar () =
-  let fd = Unix.openfile "lib_test/long.tar" [ O_RDONLY; O_CLOEXEC ] 0o0 in
-  Fun.protect
-    (fun () ->
-      let all = list fd in
-      let filenames = List.map (fun h -> h.Tar.Header.file_name) all in
-      (* List.iteri (fun i x -> Printf.fprintf stderr "%d: %s\n%!" i x) filenames; *)
-      let expected = [
-        "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/";
-        "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/";
-        "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/CDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.txt";
-      ] in
-      Alcotest.(check (list string)) "respects filenames" expected filenames
-    ) ~finally:(fun () -> Unix.close fd)
+  let all = list "lib_test/long.tar" in
+  let filenames = List.map (fun h -> h.Tar.Header.file_name) all in
+  (* List.iteri (fun i x -> Printf.fprintf stderr "%d: %s\n%!" i x) filenames; *)
+  let expected = [
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/";
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/";
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/CDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.txt";
+  ] in
+  Alcotest.(check (list string)) "respects filenames" expected filenames
 
 let can_list_long_pax_tar () =
-  let fd = Unix.openfile "lib_test/long-pax.tar" [ O_RDONLY; O_CLOEXEC ] 0x0 in
-  Fun.protect
-    (fun () ->
-      let all = list fd in
-      let filenames = List.map (fun h -> h.Tar.Header.file_name) all in
-      (* List.iteri (fun i x -> Printf.fprintf stderr "%d: %s\n%!" i x) filenames; *)
-      let expected = [
-        "t/";
-        "t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggname";
-        "t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggglink";
-      ] in
-      Alcotest.(check (list string)) "respects filenames" expected filenames
-    ) ~finally:(fun () -> Unix.close fd)
+  let all = list "lib_test/long-pax.tar" in
+  let filenames = List.map (fun h -> h.Tar.Header.file_name) all in
+  (* List.iteri (fun i x -> Printf.fprintf stderr "%d: %s\n%!" i x) filenames; *)
+  let expected = [
+    "t/";
+    "t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggname";
+    "t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggglink";
+  ] in
+  Alcotest.(check (list string)) "respects filenames" expected filenames
 
 (* "pax-shenanigans.tar" is an archive with a regular file "placeholder" with a
    pax header "path=clearly/a/directory/". The resulting header has normal link
@@ -181,15 +166,16 @@ let can_list_long_pax_tar () =
    - Reynir
 *)
 let can_list_pax_implicit_dir () =
-  let fd = Unix.openfile "lib_test/pax-shenanigans.tar" [ O_RDONLY; O_CLOEXEC ] 0x0 in
-  Fun.protect ~finally:(fun () -> Unix.close fd)
-    (fun () ->
-       match Tar_unix.HeaderReader.read ~global:None fd with
-       | Error `Fatal e -> Alcotest.failf "unexpected error: %a" Tar.pp_error e
-       | Error `Eof -> Alcotest.fail "unexpected end of file"
-       | Ok (hdr, _global) ->
-         Alcotest.(check link) "is directory" Tar.Header.Link.Directory hdr.link_indicator;
-         Alcotest.(check string) "filename is patched" "clearly/a/directory/" hdr.file_name)
+  let f ?global:_ hdr () =
+    Alcotest.(check link) "is directory" Tar.Header.Link.Directory hdr.Tar.Header.link_indicator;
+    Alcotest.(check string) "filename is patched" "clearly/a/directory/" hdr.file_name;
+    let ( let* ) = Tar.( let* ) in
+    let* _pos = Tar.seek (Int64.to_int hdr.file_size) in
+    Tar.return (Ok ())
+  in
+  match Tar_unix.fold f "lib_test/pax-shenanigans.tar" () with
+  | Ok () -> ()
+  | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_error e
 
 (* Sample tar generated with commit 1583f71ea33b2836d3fb996ac7dc35d55abe2777:
   [let buf =
@@ -203,16 +189,16 @@ let can_list_pax_implicit_dir () =
      Tar.Header.marshal ~level (Cstruct.shift buf 1024) hdr;
      buf] *)
 let can_list_longlink_implicit_dir () =
-  let fd = Unix.openfile "lib_test/long-implicit-dir.tar" [ O_RDONLY; O_CLOEXEC ] 0x0 in
-  Fun.protect ~finally:(fun () -> Unix.close fd)
-    (fun () ->
-       match Tar_unix.HeaderReader.read ~global:None fd with
-       | Ok (hdr, _global) ->
-         Alcotest.(check link) "is directory" Tar.Header.Link.Directory hdr.link_indicator;
-         Alcotest.(check string) "filename is patched" "some/long/name/for/a/directory/" hdr.file_name
-       | Error `Fatal e -> Alcotest.failf "unexpected error: %a" Tar.pp_error e
-       | Error `Eof -> Alcotest.fail "unexpected end of file")
-
+  let f ?global:_ hdr () =
+    Alcotest.(check link) "is directory" Tar.Header.Link.Directory hdr.Tar.Header.link_indicator;
+    Alcotest.(check string) "filename is patched" "some/long/name/for/a/directory/" hdr.file_name;
+    let ( let* ) = Tar.( let* ) in
+    let* _pos = Tar.seek (Int64.to_int hdr.file_size) in
+    Tar.return (Ok ())
+  in
+  match Tar_unix.fold f "lib_test/long-implicit-dir.tar" () with
+  | Ok () -> ()
+  | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_error e
 
 let starts_with ~prefix s =
   let len_s = String.length s
@@ -224,25 +210,41 @@ let starts_with ~prefix s =
   in len_s >= len_pre && aux 0
 
 let can_transform_tar () =
-  (*
   let level = Tar.Header.Ustar in
   with_tar ~level () @@ fun tar_in _file_list ->
-  let fd_in = Unix.openfile tar_in [ O_RDONLY; O_CLOEXEC ] 0 in
   let tar_out = Filename.temp_file "tar-transformed" ".tar" in
   let fd_out = Unix.openfile tar_out [ O_WRONLY; O_CREAT; O_CLOEXEC ] 0o644 in
   with_tmpdir @@ fun temp_dir ->
-  Tar_unix.Archive.transform ~level (fun hdr ->
-      {hdr with Tar.Header.file_name = Filename.concat temp_dir hdr.file_name})
-    fd_in fd_out;
-  Unix.close fd_in;
-  Unix.close fd_out;
-  let fd_in = Unix.openfile tar_out [ O_RDONLY; O_CLOEXEC ] 0 in
-  Tar_unix.Archive.with_next_file fd_in ~global:None (fun fd_file _global hdr ->
-      Alcotest.(check string) "Filename was transformed" temp_dir
-        (String.sub hdr.file_name 0 (min (String.length hdr.file_name) (String.length temp_dir)));
-      Tar_unix.skip fd_file (Int64.to_int hdr.file_size));
-  Unix.close fd_in
-     *) ()
+  let f ?global:_ hdr _ =
+    let ( let* ) = Tar.( let* ) in
+    let* _pos = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in
+    let hdr =
+      { hdr with
+        Tar.Header.file_name = Filename.concat temp_dir hdr.file_name;
+        file_size = 0L
+      }
+    in
+    match Tar_unix.write_header ~level hdr fd_out with
+    | Ok () -> Tar.return (Ok ())
+    | Error _ -> Alcotest.fail "error writing header"
+  in
+  match Tar_unix.fold f tar_in () with
+  | Error e -> Alcotest.failf "error folding %a" Tar_unix.pp_error e
+  | Ok () ->
+    match Tar_unix.write_end fd_out with
+    | Error _ -> Alcotest.fail "couldn't write end"
+    | Ok () ->
+      Unix.close fd_out;
+      let f ?global:_ hdr _ =
+        let ( let* ) = Tar.( let* ) in
+        let* _pos = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in
+        Alcotest.(check string) "Filename was transformed" temp_dir
+          (String.sub hdr.file_name 0 (min (String.length hdr.file_name) (String.length temp_dir)));
+        Tar.return (Ok ())
+      in
+      match Tar_unix.fold f tar_out () with
+      | Error e -> Alcotest.failf "error folding2 %a" Tar_unix.pp_error e
+      | Ok () -> ()
 
 module Block4096 = struct
   include Block