Repository: mirage/ocaml-tar
Pull request #119 (2023-03-20 15:34:22)

Support for pax global extended headers
~Unfinished work.~
PoC for supporting pax global extended headers. They introduce global state, which needs to be threaded to calls to `HR.read`, breaking the API.
~The change is somewhat important, so I haven't completed the work.~
Any thoughts? :-)


Patch:
diff --git a/CHANGES.md b/CHANGES.md
index 3500efa..190b782 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,3 +1,8 @@
+## unreleased
+
+- `tar`: support pax Global Extended Headers. This adds state to tar parsing.
+  (#119, #120, @MisterDA)
+
 ## v2.4.0 (2023-03-30)
 
 - Switch to alcotest for tests (@MisterDA, review by @reynir, #121)
diff --git a/bin/otar.ml b/bin/otar.ml
index a3fa342..8eb6821 100644
--- a/bin/otar.ml
+++ b/bin/otar.ml
@@ -63,7 +63,7 @@ let create_tarball directory oc =
   let hdr = Tar.Header.make ~file_mode:0o755
     ~mod_time:(Int64.of_float mtime) (Filename.concat directory "") 0L in
   Tar_gz.write_block ~level:Tar.Header.Ustar hdr out_channel (always None) ;
-  Array.iter begin fun filename -> 
+  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
@@ -104,8 +104,8 @@ let bytes_to_size ?(decimals = 2) ppf = function
 let list filename =
   let ic = open_in filename in
   let ic = Tar_gz.of_in_channel ~internal:(Cstruct.create 0x1000) ic in
-  let rec go () = match Tar_gz.get_next_header ic with
-    | hdr ->
+  let rec go global () = match Tar_gz.get_next_header ~global ic with
+    | (hdr, global) ->
       Format.printf "%s (%a)\n%!"
         hdr.Tar.Header.file_name
         (bytes_to_size ~decimals:2) hdr.Tar.Header.file_size ;
@@ -115,9 +115,9 @@ let list filename =
            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 ()
+      go global ()
     | exception Tar.Header.End_of_stream -> () in
-  go ()
+  go None ()
 
 let () = match Sys.argv with
   | [| _; "list"; filename; |] when Sys.file_exists filename ->
diff --git a/lib/tar.ml b/lib/tar.ml
index 80272cd..6d39aac 100644
--- a/lib/tar.ml
+++ b/lib/tar.ml
@@ -327,6 +327,24 @@ module Header = struct
       { access_time; charset; comment; group_id; gname; header_charset;
         link_path; mod_time; path; file_size; user_id; uname }
 
+    (** Pretty-print the header record *)
+    let to_detailed_string (x: t) =
+      let opt f = function None -> "" | Some v -> f v in
+      let table = [ "access_time",    opt Int64.to_string x.access_time;
+                    "charset",        opt Fun.id x.charset;
+                    "comment",        opt Fun.id x.comment;
+                    "group_id",       opt string_of_int x.group_id;
+                    "gname",          opt Fun.id x.gname;
+                    "header_charset", opt Fun.id x.header_charset;
+                    "link_path",      opt Fun.id x.link_path;
+                    "mod_time",       opt Int64.to_string x.mod_time;
+                    "path",           opt Fun.id x.path;
+                    "file_size",      opt Int64.to_string x.file_size;
+                    "user_id",        opt string_of_int x.user_id;
+                    "uname",          opt Fun.id x.uname;
+                  ] in
+      "{\n\t" ^ (String.concat "\n\t" (List.map (fun (k, v) -> k ^ ": " ^ v) table)) ^ "}"
+
     let marshal t =
       let pairs =
         (match t.access_time    with None -> [] | Some x -> [ "atime", Int64.to_string x ])
@@ -347,7 +365,29 @@ module Header = struct
       ) pairs) in
       Cstruct.of_string txt
 
-    let unmarshal (c: Cstruct.t) : t =
+    let merge global extended =
+      match global with
+      | Some g ->
+         let merge g e = match e with None -> g | Some _ ->  e in
+         let access_time = merge g.access_time extended.access_time
+         and charset = merge g.charset extended.charset
+         and comment = merge g.comment extended.comment
+         and group_id = merge g.group_id extended.group_id
+         and gname = merge g.gname extended.gname
+         and header_charset = merge g.header_charset extended.header_charset
+         and link_path = merge g.link_path extended.link_path
+         and mod_time = merge g.mod_time extended.mod_time
+         and path = merge g.path extended.path
+         and file_size = merge g.file_size extended.file_size
+         and user_id = merge g.user_id extended.user_id
+         and uname = merge g.uname extended.uname
+         in
+         { access_time; charset; comment; group_id; gname;
+           header_charset; link_path; mod_time; path; file_size;
+           user_id; uname }
+      | None -> extended
+
+    let unmarshal ~(global: t option) (c: Cstruct.t) : t =
       (* "%d %s=%s\n", <length>, <keyword>, <value> with constraints that
          - the <keyword> cannot contain an equals sign
          - the <length> is the number of octets of the record, including \n
@@ -399,7 +439,7 @@ module Header = struct
       let uname          = option "uname" unmarshal_string in
       { access_time; charset; comment; group_id; gname;
         header_charset; link_path; mod_time; path; file_size;
-        user_id; uname }
+        user_id; uname } |> merge global
 
   end
 
@@ -466,7 +506,7 @@ module Header = struct
                   "mod_time",       Int64.to_string x.mod_time;
                   "link_indicator", Link.to_string x.link_indicator;
                   "link_name",      x.link_name ] in
-    "{\n" ^ (String.concat "\n\t" (List.map (fun (k, v) -> k ^ ": " ^ v) table)) ^ "}"
+    "{\n\t" ^ (String.concat "\n\t" (List.map (fun (k, v) -> k ^ ": " ^ v) table)) ^ "}"
 
   (** Thrown when unmarshalling a header if the checksums don't match *)
   exception Checksum_mismatch
@@ -646,42 +686,47 @@ module HeaderReader(Async: ASYNC)(Reader: READER with type 'a t = 'a Async.t) =
   open Reader
 
 
-  let read ?level (ifd: Reader.in_channel) : (Header.t, [ `Eof ]) result t =
+  let read ?level ~global (ifd: Reader.in_channel) : (Header.t * Header.Extended.t option, [ `Eof ]) result t =
     let level = Header.get_level level in
     (* We might need to read 2 headers at once if we encounter a Pax header *)
     let buffer = Cstruct.create Header.length in
     let real_header_buf = Cstruct.create Header.length in
 
-    let next_block () =
+    let next_block global () =
       really_read ifd buffer
       >>= fun () ->
-      return (Header.unmarshal ~level buffer) in
+      match Header.unmarshal ?extended:global ~level buffer with
+      | None -> return None
+      | Some hdr -> return (Some hdr)
+      in
 
-    (* Skip Pax GlobalExtendedHeaders *)
-    let next () =
-      next_block ()
+    let rec get_hdr global () : (Header.t * Header.Extended.t option, [> `Eof ]) result t =
+      next_block global ()
       >>= function
       | Some x when x.Header.link_indicator = Header.Link.GlobalExtendedHeader ->
-        skip ifd (Int64.to_int x.file_size + Header.compute_zero_padding_length x) >>= next_block
-      | x -> return x in
-
-    let get_hdr () =
-      next ()
-      >>= function
+        let extra_header_buf = Cstruct.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 () ->
+        (* unmarshal merges the previous global (if any) with the
+           discovered global (if any) and returns the new global. *)
+        let global = Header.Extended.unmarshal ~global extra_header_buf in
+        get_hdr (Some global) ()
       | Some x when x.Header.link_indicator = Header.Link.PerFileExtendedHeader ->
         let extra_header_buf = Cstruct.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 extended = Header.Extended.unmarshal extra_header_buf in
+        let extended = Header.Extended.unmarshal ~global extra_header_buf in
         really_read ifd real_header_buf
         >>= fun () ->
         begin match Header.unmarshal ~level ~extended real_header_buf with
         | None ->
           (* Corrupt pax headers *)
           return (Error `Eof)
-        | Some x -> return (Ok x)
+        | Some x -> return (Ok (x, global))
         end
       | Some x when x.Header.link_indicator = Header.Link.LongLink && x.Header.file_name = longlink ->
         let extra_header_buf = Cstruct.create (Int64.to_int x.Header.file_size) in
@@ -690,21 +735,21 @@ module HeaderReader(Async: ASYNC)(Reader: READER with type 'a t = 'a Async.t) =
         skip ifd (Header.compute_zero_padding_length x)
         >>= fun () ->
         let file_name = Cstruct.(to_string @@ sub extra_header_buf 0 (length extra_header_buf - 1)) in
-        begin next ()
+        begin next_block global ()
         >>= function
         | None -> return (Error `Eof)
-        | Some x -> return (Ok { x with file_name })
+        | Some x -> return (Ok ({ x with file_name }, global))
         end
-      | Some x -> return (Ok x)
+      | Some x -> return (Ok (x, global))
       | None ->
         begin
-          next ()
+          next_block global ()
           >>= function
-          | Some x -> return (Ok x)
+          | Some x -> return (Ok (x, global))
           | None -> return (Error `Eof)
         end in
 
-    let rec read_header (file_name, link_name, hdr) : (Header.t, [`Eof]) result Async.t =
+    let rec read_header global (file_name, link_name, hdr) : (Header.t * Header.Extended.t option, [`Eof]) result Async.t =
       let raw_link_indicator = Header.get_hdr_link_indicator buffer in
       if (raw_link_indicator = 'K' || raw_link_indicator = 'L') && level = Header.GNU then
         let data = Cstruct.create (Int64.to_int hdr.Header.file_size) in
@@ -714,23 +759,24 @@ module HeaderReader(Async: ASYNC)(Reader: READER with type 'a t = 'a Async.t) =
         really_read ifd pad
         >>= fun () ->
         let data = Header.unmarshal_string (Cstruct.to_string data) in
-        get_hdr ()
+        get_hdr global ()
         >>= function
         | Error `Eof -> return (Error `Eof)
-        | Ok hdr ->
+        | Ok (hdr, global) ->
           if raw_link_indicator = 'K'
-          then read_header (file_name, data, hdr)
-          else read_header (data, link_name, hdr)
+          then read_header global (file_name, data, hdr)
+          else read_header global (data, link_name, hdr)
       else begin
         let link_name = if link_name = "" then hdr.Header.link_name else link_name in
         let file_name = if file_name = "" then hdr.Header.file_name else file_name in
-        return (Ok {hdr with Header.link_name; file_name })
+        return (Ok ({hdr with Header.link_name; file_name }, global))
       end in
-    get_hdr ()
+
+    get_hdr global ()
     >>= function
     | Error `Eof -> return (Error `Eof)
-    | Ok hdr ->
-      read_header ("", "", hdr)
+    | Ok (hdr, global) ->
+      read_header global ("", "", hdr)
 
 end
 
@@ -773,18 +819,31 @@ module HeaderWriter(Async: ASYNC)(Writer: WRITER with type 'a t = 'a Async.t) =
     Header.marshal ~level buffer header;
     really_write fd buffer
 
-  let write ?level header fd =
+  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
+    in
+    let pax_payload = Header.Extended.marshal hdr in
+    let pax = Header.make ~link_indicator link_indicator_name
+                (Int64.of_int @@ Cstruct.length pax_payload) in
+    write_unextended ?level pax fd
+    >>= fun () ->
+    really_write fd pax_payload
+    >>= fun () ->
+    really_write fd (Header.zero_padding pax)
+
+  let write ?level ?global header fd =
+    ( match global with
+     | None -> return ()
+     | Some g ->
+       write_extended ?level ~link_indicator:Header.Link.GlobalExtendedHeader g fd )
+    >>= fun () ->
     ( match header.Header.extended with
       | None -> return ()
       | Some e ->
-        let pax_payload = Header.Extended.marshal e in
-        let pax = Header.make ~link_indicator:Header.Link.PerFileExtendedHeader
-          "paxheader" (Int64.of_int @@ Cstruct.length pax_payload) in
-        write_unextended ?level pax fd
-        >>= fun () ->
-        really_write fd pax_payload
-        >>= fun () ->
-        really_write fd (Header.zero_padding pax) )
+        write_extended ?level ~link_indicator:Header.Link.PerFileExtendedHeader e fd )
     >>= fun () ->
     write_unextended ?level header fd
 end
@@ -833,8 +892,8 @@ module Make (IO : IO) = struct
 
   module HW = HeaderWriter(Direct)(Writer)
 
-  let write_block ?level (header: Header.t) (body: IO.out_channel -> unit) (fd : IO.out_channel) =
-    HW.write ?level header fd;
+  let write_block ?level ?global (header: Header.t) (body: IO.out_channel -> unit) (fd : IO.out_channel) =
+    HW.write ?level ?global header fd;
     body fd;
     really_write fd (Header.zero_padding header)
 
@@ -844,8 +903,8 @@ module Make (IO : IO) = struct
 
   module HR = HeaderReader(Direct)(Reader)
 
-  let get_next_header ?level ic = match HR.read ?level ic with
-    | Ok hdr -> hdr
+  let get_next_header ?level ~global ic = match HR.read ?level ~global ic with
+    | Ok hdrs -> hdrs
     | Error `Eof -> raise Header.End_of_stream
 
   (** Utility functions for operating over whole tar archives *)
@@ -853,25 +912,28 @@ module Make (IO : IO) = struct
 
     let skip = Reader.skip
 
-    (** Read the next header, apply the function 'f' to the fd and the header. The function
-        should leave the fd positioned immediately after the datablock. Finally the function
-        skips past the zero padding to the next header *)
-    let with_next_file (fd: IO.in_channel) (f: IO.in_channel -> Header.t -> 'a) =
-      match HR.read fd with
-      | Ok hdr ->
+    (** Read the next header, apply the function [f] to the fd, the global pax extended
+        header (if any), and the current header. The function should leave the fd positioned
+        immediately after the datablock. Finally the function skips past the zero padding to
+        the next header *)
+    let with_next_file (fd: IO.in_channel) ~(global: Header.Extended.t option) (f: IO.in_channel -> Header.Extended.t option -> Header.t -> 'a) =
+      match HR.read ~global fd with
+      | Ok (hdr, global) ->
         (* NB if the function 'f' fails we're boned *)
-        Fun.protect (fun () -> f fd hdr)
+        Fun.protect (fun () -> f fd global hdr)
           ~finally:(fun () -> Reader.skip fd (Header.compute_zero_padding_length hdr))
       | Error `Eof -> raise Header.End_of_stream
 
     (** List the contents of a tar *)
     let list ?level fd =
       let level = Header.get_level level in
+      let global = ref None in
       let list = ref [] in
       try
         while true do
-          match HR.read ~level fd with
-          | Ok hdr ->
+          match HR.read ~level ~global:!global fd with
+          | Ok (hdr, global') ->
+            global := global';
             list := hdr :: !list;
             Reader.skip fd (Int64.to_int hdr.Header.file_size);
             Reader.skip fd (Header.compute_zero_padding_length hdr)
@@ -901,10 +963,12 @@ module Make (IO : IO) = struct
     (** [extract_gen dest] extract the contents of a tar.
         Apply 'dest' on each header to get a handle to the file to write to *)
     let extract_gen dest ifd =
+      let global = ref None in
       try
         while true do
-          match HR.read ifd with
-          | Ok hdr ->
+          match HR.read ~global:!global ifd with
+          | Ok (hdr, global') ->
+            global := global';
             let size = hdr.Header.file_size in
             let padding = Header.compute_zero_padding_length hdr in
             let ofd = dest hdr in
diff --git a/lib/tar.mli b/lib/tar.mli
index 0144a7f..3a07911 100644
--- a/lib/tar.mli
+++ b/lib/tar.mli
@@ -66,7 +66,16 @@ module Header : sig
     }
     (** Represents a "Pax" extended header. *)
 
-    val unmarshal : Cstruct.t -> t
+    (** [make ()] creates an extended header. *)
+    val make : ?access_time:int64 -> ?charset:string -> ?comment:string -> ?group_id:int -> ?gname:string -> ?header_charset:string -> ?link_path:string -> ?mod_time:int64 -> ?path:string -> ?file_size:int64 -> ?user_id:int -> ?uname:string -> unit -> t
+
+    (** Pretty-print the extended header record. *)
+    val to_detailed_string : t -> string
+
+    (** Unmarshal a pax Extended Header block. This header block may
+        be preceded by [global] blocks which will override some
+        fields. *)
+    val unmarshal : global:t option -> Cstruct.t -> t
   end
 
   (** Represents a standard archive (note checksum not stored). *)
@@ -92,7 +101,7 @@ module Header : sig
       [file_mode] defaults to [0o400], [user_id], [group_id] default to [0],
       [mod_time] defaults to [0L] (epoch), [link_indicator] defaults to [Normal],
       [link_name], [uname] and [gname] default to [""], and [devmajor] and
-      [devminor] default to [0].*)
+      [devminor] default to [0]. *)
   val make : ?file_mode:int -> ?user_id:int -> ?group_id:int -> ?mod_time:int64 -> ?link_indicator:Link.t -> ?link_name:string -> ?uname:string -> ?gname:string -> ?devmajor:int -> ?devminor:int -> string -> int64 -> t
 
   (** Length of a header block. *)
@@ -156,12 +165,14 @@ module HeaderReader(Async: ASYNC)(Reader: READER with type 'a t = 'a Async.t) :
   (** Returns the next header block or throws {!Header.End_of_stream} 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].
       @raise Header.End_of_stream if the stream unexpectedly fails. *)
-  val read : ?level:Header.compatibility -> Reader.in_channel -> (Header.t, [`Eof]) result Async.t
+  val read : ?level:Header.compatibility -> global:Header.Extended.t option -> Reader.in_channel -> (Header.t * Header.Extended.t option, [`Eof]) result Async.t
 end
 
 module HeaderWriter(Async: ASYNC)(Writer: WRITER with type 'a t = 'a Async.t) : sig
-  val write : ?level:Header.compatibility -> Header.t -> Writer.out_channel -> unit Async.t
+  val write : ?level:Header.compatibility -> ?global:Header.Extended.t -> Header.t -> Writer.out_channel -> unit Async.t
 end
 
 module type IO = sig
@@ -187,9 +198,9 @@ module Make (IO : IO) : sig
       zero-filled blocks are discovered. Assumes stream is positioned at the
       possible start of a header block.
       @raise Stdlib.End_of_file if the stream unexpectedly fails. *)
-  val get_next_header : ?level:Header.compatibility -> IO.in_channel -> Header.t
+  val get_next_header : ?level:Header.compatibility -> global:Header.Extended.t option -> IO.in_channel -> Header.t * Header.Extended.t option
 
-  val write_block: ?level:Header.compatibility -> Header.t -> (IO.out_channel -> unit) -> IO.out_channel -> unit
+  val write_block: ?level:Header.compatibility -> ?global:Header.Extended.t -> Header.t -> (IO.out_channel -> unit) -> IO.out_channel -> unit
     [@@ocaml.deprecated "Deprecated: use Tar.HeaderWriter"]
   (** Write [hdr], then call [write_body fd] to write the body,
       then zero-pads so the stream is positioned for the next block. *)
@@ -201,10 +212,12 @@ module Make (IO : IO) : sig
   module Archive : sig
     (** Utility functions for operating over whole tar archives. *)
 
-    (** Read the next header, apply the function 'f' to the fd and the header. The function
-        should leave the fd positioned immediately after the datablock. Finally the function
-        skips past the zero padding to the next header. *)
-    val with_next_file : IO.in_channel -> (IO.in_channel -> Header.t -> 'a) -> 'a
+    (** Read the next header, apply the function [f] to the fd, the global pax extended
+        header (if any), and the current header. The function should leave the fd positioned
+        immediately after the datablock. Finally the function skips past the zero padding to
+        the next header *)
+    val with_next_file : IO.in_channel -> global:Header.Extended.t option ->
+                         (IO.in_channel -> Header.Extended.t option -> Header.t -> 'a) -> 'a
 
     (** List the contents of a tar. *)
     val list : ?level:Header.compatibility -> IO.in_channel -> Header.t list
diff --git a/lib/tar_cstruct.mli b/lib/tar_cstruct.mli
index 7aad850..93fd3e0 100644
--- a/lib/tar_cstruct.mli
+++ b/lib/tar_cstruct.mli
@@ -23,14 +23,16 @@ val really_write : out_channel -> Cstruct.t -> unit
 (** [really_write oc buf] writes the full contents of [buf] to [oc]
     or raises {!Stdlib.End_of_file}. *)
 
-val get_next_header : ?level:Tar.Header.compatibility -> in_channel -> Tar.Header.t
+val get_next_header : ?level:Tar.Header.compatibility -> global:Tar.Header.Extended.t option -> in_channel ->
+                      Tar.Header.t * Tar.Header.Extended.t option
 (** [get_next_header ?level ic] returns the next header block or fails with
     [`Eof] if two consecutive zero-filled blocks are discovered. Assumes [ic]
     is positioned at the possible start of a header block.
     @raise Stdlib.End_of_file if the stream unexpectedly fails. *)
 
 module Archive : sig
-  val with_next_file : in_channel -> (in_channel -> Tar.Header.t -> 'a) -> 'a
+  val with_next_file : in_channel -> global:Tar.Header.Extended.t option ->
+                       (in_channel -> Tar.Header.Extended.t option -> Tar.Header.t -> 'a) -> 'a
   (** [with_next_file ic f] Read the next header, apply the function [f] to
       [ic] and the header.  The function should leave [ic] positioned
       immediately after the datablock. {!really_read} can be used for this
diff --git a/lib/tar_gz.ml b/lib/tar_gz.ml
index 009fa74..c6c496b 100644
--- a/lib/tar_gz.ml
+++ b/lib/tar_gz.ml
@@ -99,7 +99,7 @@ module Make
         if len < max
         then ( state.pos <- state.pos + len
              ; Async.return () )
-        else ( let res = Cstruct.shift res len in 
+        else ( let res = Cstruct.shift res len in
                until_full_or_end (Gz.Inf.flush state.gz) res )
 
     let skip
@@ -123,9 +123,9 @@ module Make
     ; in_channel
     ; pos= 0 }
 
-  let get_next_header ?level ic =
-    TarGzHeaderReader.read ?level ic >>= function
-    | Ok hdr -> Async.return hdr
+  let get_next_header ?level ~global ic =
+    TarGzHeaderReader.read ?level ~global ic >>= function
+    | Ok hdrs -> Async.return hdrs
     | Error `Eof -> raise Tar.Header.End_of_stream
 
   let really_read = Gz_reader.really_read
@@ -144,8 +144,8 @@ module Make
     let gz = Gz.Def.dst gz buffer off len 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 =
-    TarGzHeaderWriter.write ?level hdr state >>= fun () ->
+  let write_block ?level ?global hdr ({ Gz_writer.ic_buffer= buf; oc_buffer; out_channel; _ } as state) block =
+    TarGzHeaderWriter.write ?level ?global hdr state >>= fun () ->
     (* XXX(dinosaure): we can refactor this code with [Gz_writer.really_write]
        but this loop saves and uses [ic_buffer]/[buf] to avoid extra
        allocations on the case between [string] and [Cstruct.t]. *)
diff --git a/lib/tar_gz.mli b/lib/tar_gz.mli
index c78406a..1b039dc 100644
--- a/lib/tar_gz.mli
+++ b/lib/tar_gz.mli
@@ -34,7 +34,8 @@ module Make
       positioned at the possible start of a header block.
 
       @raise Stdlib.End_of_file if the stream unexpectedly fails. *)
-  val get_next_header : ?level:Tar.Header.compatibility -> in_channel -> Tar.Header.t Async.t
+  val get_next_header : ?level:Tar.Header.compatibility -> global:Tar.Header.Extended.t option
+    -> in_channel -> (Tar.Header.t * Tar.Header.Extended.t option) Async.t
 
   val really_read : in_channel -> Cstruct.t -> unit Async.t
   (** [really_read fd buf] fills [buf] with data from [fd] or raises
@@ -47,8 +48,8 @@ module Make
   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 Async.t
+  val write_block : ?level:Tar.Header.compatibility -> ?global:Tar.Header.Extended.t ->
+    Tar.Header.t -> out_channel -> (unit -> string option Async.t) -> unit 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.
diff --git a/mirage/tar_mirage.ml b/mirage/tar_mirage.ml
index 756d48c..746768e 100644
--- a/mirage/tar_mirage.ml
+++ b/mirage/tar_mirage.ml
@@ -255,10 +255,10 @@ module Make_KV_RO (BLOCK : Mirage_block.S) = struct
     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 map =
-      HR.read in_channel >>= function
+    let rec loop ~global map =
+      HR.read ~global in_channel >>= function
       | Error `Eof -> Lwt.return map
-      | Ok tar ->
+      | Ok (tar, global) ->
         let filename = trim_slash tar.Tar.Header.file_name in
         let map =
           if filename = "" then
@@ -270,10 +270,10 @@ module Make_KV_RO (BLOCK : Mirage_block.S) = struct
         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 map
+        loop ~global map
     in
     let root = StringMap.empty in
-    loop root >>= fun map ->
+    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
diff --git a/unix/tar_lwt_unix.ml b/unix/tar_lwt_unix.ml
index 72eb90d..38623e2 100644
--- a/unix/tar_lwt_unix.ml
+++ b/unix/tar_lwt_unix.ml
@@ -57,11 +57,11 @@ let copy_n ifd ofd n =
 module HR = Tar.HeaderReader(Lwt)(Reader)
 module HW = Tar.HeaderWriter(Lwt)(Writer)
 
-let get_next_header ?level ic =
-  HR.read ?level ic
+let get_next_header ?level ~global ic =
+  HR.read ?level ~global ic
   >>= function
   | Error `Eof -> Lwt.return None
-  | Ok hdr -> Lwt.return (Some hdr)
+  | Ok hdrs -> Lwt.return (Some hdrs)
 
 (** Return the header needed for a particular file on disk *)
 let header_of_file ?level (file: string) : Tar.Header.t Lwt.t =
@@ -83,8 +83,8 @@ let header_of_file ?level (file: string) : Tar.Header.t Lwt.t =
   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 write_block ?level (header: Tar.Header.t) (body: Lwt_unix.file_descr -> unit Lwt.t) (fd : Lwt_unix.file_descr) =
-  HW.write ?level header fd
+let write_block ?level ?global (header: Tar.Header.t) (body: Lwt_unix.file_descr -> unit Lwt.t) (fd : Lwt_unix.file_descr) =
+  HW.write ?level ?global header fd
   >>= fun () ->
   body fd >>= fun () ->
   really_write fd (Tar.Header.zero_padding header)
@@ -103,10 +103,11 @@ module Archive = struct
   (** Read the next header, apply the function 'f' to the fd and the header. The function
       should leave the fd positioned immediately after the datablock. Finally the function
       skips past the zero padding to the next header *)
-  let with_next_file (fd: Lwt_unix.file_descr) (f: Lwt_unix.file_descr -> Tar.Header.t -> 'a Lwt.t) =
-    get_next_header fd >>= function
-    | Some hdr ->
-      f fd hdr >>= fun result ->
+  let with_next_file (fd: Lwt_unix.file_descr) ~(global: Tar.Header.Extended.t option)
+        (f: Lwt_unix.file_descr -> Tar.Header.Extended.t option -> Tar.Header.t -> 'a Lwt.t) =
+    get_next_header ~global fd >>= function
+    | Some (hdr, global) ->
+      f fd global hdr >>= fun result ->
       Reader.skip fd (Tar.Header.compute_zero_padding_length hdr) >>= fun () ->
       Lwt.return (Some result)
     | None ->
@@ -114,36 +115,36 @@ module Archive = struct
 
   (** List the contents of a tar *)
   let list ?level fd =
-    let rec loop acc = get_next_header ?level fd >>= function
+    let rec loop global acc = get_next_header ?level ~global fd >>= function
       | None -> Lwt.return (List.rev acc)
-      | Some hdr ->
+      | Some (hdr, global) ->
         Reader.skip fd (Int64.to_int hdr.Tar.Header.file_size) >>= fun () ->
         Reader.skip fd (Tar.Header.compute_zero_padding_length hdr) >>= fun () ->
-        loop (hdr :: acc) in
-    loop []
+        loop global (hdr :: acc) in
+    loop None []
 
   (** Extract the contents of a tar to directory 'dest' *)
   let extract dest ifd =
-    let rec loop () = get_next_header ifd >>= function
+    let rec loop global () = get_next_header ~global ifd >>= function
       | None -> Lwt.return_unit
-      | Some hdr ->
+      | Some (hdr, global) ->
         let filename = dest hdr.Tar.Header.file_name in
         with_file filename [Unix.O_WRONLY; O_CLOEXEC] 0 @@ fun ofd ->
         copy_n ifd ofd hdr.Tar.Header.file_size >>= fun () ->
         Reader.skip ifd (Tar.Header.compute_zero_padding_length hdr) >>= fun () ->
-        loop () in
-    loop ()
+        loop global () in
+    loop None ()
 
   let transform ?level f ifd ofd =
-    let rec loop () = get_next_header ifd >>= function
+    let rec loop global () = get_next_header ~global ifd >>= function
       | None -> Lwt.return_unit
-      | Some header' ->
+      | Some (header', global') ->
         let header = f header' in
         let body = fun _ -> copy_n ifd ofd header.Tar.Header.file_size in
-        write_block ?level header body ofd >>= fun () ->
+        write_block ?level ?global:(if global <> global' then global' else None) header body ofd >>= fun () ->
         Reader.skip ifd (Tar.Header.compute_zero_padding_length header') >>= fun () ->
-        loop () in
-    loop () >>= fun () ->
+        loop global' () in
+    loop None () >>= fun () ->
     write_end ofd
 
   (** Create a tar on file descriptor fd from the filename list
diff --git a/unix/tar_lwt_unix.mli b/unix/tar_lwt_unix.mli
index a547e96..6c8417d 100644
--- a/unix/tar_lwt_unix.mli
+++ b/unix/tar_lwt_unix.mli
@@ -28,7 +28,8 @@ val really_write: Lwt_unix.file_descr -> Cstruct.t -> unit Lwt.t
     zero-filled blocks are discovered. Assumes stream is positioned at the
     possible start of a header block.
     @raise Stdlib.End_of_file if the stream unexpectedly fails. *)
-val get_next_header : ?level:Tar.Header.compatibility -> Lwt_unix.file_descr -> Tar.Header.t option Lwt.t
+val get_next_header : ?level:Tar.Header.compatibility -> global:Tar.Header.Extended.t option -> Lwt_unix.file_descr ->
+                      (Tar.Header.t * Tar.Header.Extended.t option) option Lwt.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
@@ -39,7 +40,8 @@ module Archive : sig
   (** Read the next header, apply the function 'f' to the fd and the header. The function
       should leave the fd positioned immediately after the datablock. Finally the function
       skips past the zero padding to the next header. *)
-  val with_next_file : Lwt_unix.file_descr -> (Lwt_unix.file_descr -> Tar.Header.t -> 'a Lwt.t) -> 'a option Lwt.t
+  val with_next_file : Lwt_unix.file_descr -> global:Tar.Header.Extended.t option ->
+                       (Lwt_unix.file_descr -> Tar.Header.Extended.t option -> Tar.Header.t -> 'a Lwt.t) -> 'a option Lwt.t
 
   (** List the contents of a tar to stdout. *)
   val list : ?level:Tar.Header.compatibility -> Lwt_unix.file_descr -> Tar.Header.t list Lwt.t
diff --git a/unix/tar_unix.ml b/unix/tar_unix.ml
index c8714ea..1938323 100644
--- a/unix/tar_unix.ml
+++ b/unix/tar_unix.ml
@@ -92,16 +92,16 @@ module Archive = struct
     extract_gen dest ifd
 
   let transform ?level f ifd ofd =
-    let rec loop () =
-      match get_next_header ifd with
+    let rec loop global () =
+      match get_next_header ~global ifd with
       | exception Tar.Header.End_of_stream -> ()
-      | header' ->
+      | (header', global') ->
         let header = f header' in
         let body = fun _ -> copy_n ifd ofd header.Tar.Header.file_size in
-        write_block ?level header body ofd;
+        write_block ?level ?global:(if global <> global' then global' else None) header body ofd;
         skip ifd (Tar.Header.compute_zero_padding_length header');
-        loop () in
-    loop ();
+        loop global' () in
+    loop None ();
     write_end ofd
 
   (** Create a tar on file descriptor fd from the filename list
diff --git a/unix/tar_unix.mli b/unix/tar_unix.mli
index d656ee2..44651e8 100644
--- a/unix/tar_unix.mli
+++ b/unix/tar_unix.mli
@@ -28,12 +28,14 @@ val really_write: Unix.file_descr -> Cstruct.t -> unit
     zero-filled blocks are discovered. Assumes stream is positioned at the
     possible start of a header block.
     @raise Stdlib.End_of_file if the stream unexpectedly fails. *)
-val get_next_header : ?level:Tar.Header.compatibility -> Unix.file_descr -> Tar.Header.t
+val get_next_header : ?level:Tar.Header.compatibility -> global:Tar.Header.Extended.t option ->
+  Unix.file_descr -> Tar.Header.t * Tar.Header.Extended.t option
 
 (** Return the header needed for a particular file on disk. *)
 val header_of_file : ?level:Tar.Header.compatibility -> string -> Tar.Header.t
 
-val write_block: ?level:Tar.Header.compatibility -> Tar.Header.t -> (Unix.file_descr -> unit) -> Unix.file_descr -> unit
+val write_block: ?level:Tar.Header.compatibility -> ?global:Tar.Header.Extended.t ->
+  Tar.Header.t -> (Unix.file_descr -> unit) -> Unix.file_descr -> unit
   [@@ocaml.deprecated "Deprecated in favor of Tar.HeaderWriter"]
   (** Write [hdr], then call [write_body fd] to write the body,
       then zero-pads so the stream is positioned for the next block. *)
@@ -48,7 +50,7 @@ module Archive : sig
   (** Read the next header, apply the function 'f' to the fd and the header. The function
       should leave the fd positioned immediately after the datablock. Finally the function
       skips past the zero padding to the next header. *)
-  val with_next_file : Unix.file_descr -> (Unix.file_descr -> Tar.Header.t -> 'a) -> 'a
+  val with_next_file : Unix.file_descr -> global:Tar.Header.Extended.t option -> (Unix.file_descr -> Tar.Header.Extended.t option -> Tar.Header.t -> 'a) -> 'a
 
   (** List the contents of a tar. *)
   val list : ?level:Tar.Header.compatibility -> Unix.file_descr -> Tar.Header.t list


Test patch:
diff --git a/lib_test/dune b/lib_test/dune
index dfbcbf8..e355bb1 100644
--- a/lib_test/dune
+++ b/lib_test/dune
@@ -1,5 +1,5 @@
 (tests
- (names parse_test write_test allocate_set_partial_test)
+ (names parse_test write_test allocate_set_partial_test global_extended_headers_test)
  (package tar-mirage)
  (libraries
   mirage-block-unix
diff --git a/lib_test/global_extended_headers_test.ml b/lib_test/global_extended_headers_test.ml
new file mode 100644
index 0000000..70e37c2
--- /dev/null
+++ b/lib_test/global_extended_headers_test.ml
@@ -0,0 +1,126 @@
+let level = Tar.Header.Ustar
+
+module Writer = struct
+  type out_channel = Stdlib.out_channel
+  type 'a t = 'a
+  let really_write oc cs =
+    let str = Cstruct.to_string cs in
+    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 t = 'a
+  let really_read ic cs =
+    let len = Cstruct.length cs in
+    let buf = Bytes.create len in
+    really_input ic buf 0 len ;
+    Cstruct.blit_from_bytes buf 0 cs 0 len
+  let skip ic len = really_read ic (Cstruct.create len)
+  let read ic cs =
+    let max = Cstruct.length cs in
+    let buf = Bytes.create max in
+    let len = input ic buf 0 max in
+    Cstruct.blit_from_bytes buf 0 cs 0 len ; len
+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 ()
+
+let make_file =
+  let gen = ref 0 in
+  fun () ->
+  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
+       |> Cstruct.to_string
+       |> output_string cout
+
+(* 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 g0 = make_extended 1000 in
+  let hdr, f = make_file () in
+  HW.write ~level ~global:g0 hdr cout;
+  f cout;
+  let hdr, f = make_file () in
+  let hdr = { hdr with Tar.Header.extended = Some (make_extended 2000) } in
+  HW.write ~level hdr cout;
+  f cout;
+  let hdr, f = make_file () in
+  HW.write ~level hdr cout;
+  f cout;
+  let g1 = make_extended 3000 in
+  let hdr, f = make_file () in
+  HW.write ~level ~global:g1 hdr cout;
+  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 ~level ~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" );
+  ( match HR.read ~level ~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 `Eof -> failwith "Couldn't read header" );
+  ( match HR.read ~level ~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" );
+  ( match HR.read ~level ~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 `Eof -> failwith "Couldn't read header" );
+  ( match HR.read ~level ~global:!global cin with
+    | Ok _ -> failwith "Should have found EOF"
+    | Error `Eof -> () );
+  ()
+
+let () =
+  let suite = "tar - pax global extended headers", [
+      Alcotest.test_case "can use pax global extended headers" `Quick use_global_extended_headers;
+    ]
+  in
+  Alcotest.run "global extended headers" [suite]
diff --git a/lib_test/parse_test.ml b/lib_test/parse_test.ml
index 2420869..f9546db 100644
--- a/lib_test/parse_test.ml
+++ b/lib_test/parse_test.ml
@@ -156,7 +156,7 @@ let can_transform_tar () =
   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 (fun fd_file hdr ->
+  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.Archive.skip fd_file (Int64.to_int hdr.file_size));