From 6f4a26b78386007a01c65be3668c6b09137b1b92 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 15 May 2024 14:46:31 +0200 Subject: [PATCH] Add a way to produce a *.tar.gz archive from the new pure API --- bin/otar.ml | 115 ++++++------- lib/tar.ml | 42 ++++- lib/tar.mli | 15 ++ lib/tar_gz.ml | 208 ++++++++++------------- lib/tar_gz.mli | 74 ++------ lib_test/global_extended_headers_test.ml | 2 +- lib_test/parse_test.ml | 10 +- unix/tar_lwt_unix.ml | 3 + unix/tar_unix.ml | 8 +- unix/tar_unix.mli | 13 +- 10 files changed, 234 insertions(+), 256 deletions(-) diff --git a/bin/otar.ml b/bin/otar.ml index d9a0395..5438a48 100644 --- a/bin/otar.ml +++ b/bin/otar.ml @@ -18,60 +18,64 @@ let () = Printexc.record_backtrace true 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 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 + ~mod_time:(Int64.of_float mtime) (Filename.concat directory "") 0L 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 = List.to_seq entries in + let entries = Seq.to_dispenser entries in + let entries () = Tar.return (Ok (entries ())) in + let t = Tar.out ~level:Tar.Header.Ustar hdr 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" |] @@ -89,46 +93,31 @@ let list filename = 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 *) - 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 open Tar in - let to_skip = Header.(Int64.to_int (to_sectors hdr) * length) in - let* _ = seek to_skip in + let* _ = seek (Int64.to_int hdr.Tar.Header.file_size) in return (Ok ()) in let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0 in - match Tar_unix.run (Tar_gz.gzipped (Tar.fold go ())) fd with + 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 -> + | Error (`Unexpected_end_of_file | `Eof) -> Format.eprintf "Unexpected end of file.\n%!" - | Error `Eof | Error `Gz _ -> - Format.eprintf "Some fatal error occurred.\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 -> list filename - (* | [| _; directory |] when Sys.is_directory directory -> make directory None | [| _; directory; output |] when Sys.is_directory directory -> make directory (Some output) - *) | _ -> let cmd = Filename.basename Sys.argv.(0) in Format.eprintf "%s []\n%s list \n" cmd cmd diff --git a/lib/tar.ml b/lib/tar.ml index 2fa3875..819b60e 100644 --- a/lib/tar.ml +++ b/lib/tar.ml @@ -795,7 +795,7 @@ let encode_unextended_header ?level header = 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" + | `Global -> Header.Link.GlobalExtendedHeader, "pax_global_header" | _ -> assert false in let pax_payload = Header.Extended.marshal hdr in @@ -825,12 +825,14 @@ type ('a, '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 @@ -859,3 +861,41 @@ let fold f init = | 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* () = writev [ 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 hdr entries = + let rec go () = + let* entry = entries () in + match entry with + | None -> + let* () = writev [ Header.zero_block; Header.zero_block ] in + return (Ok ()) + | Some (level, hdr, stream) -> + match encode_header ?level hdr with + | Ok sstr -> + let* () = writev sstr in + let* () = pipe stream in + let* () = writev [ Header.zero_padding hdr ] in + go () + | Error _ as err -> return err in + match encode_header ?level hdr with + | Error _ as err -> return err + | Ok sstr -> + let* () = writev sstr in + let* () = writev [ Header.zero_padding hdr ] in + go () diff --git a/lib/tar.mli b/lib/tar.mli index 49fb2a9..da642ea 100644 --- a/lib/tar.mli +++ b/lib/tar.mli @@ -196,12 +196,14 @@ type ('a, '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 @@ -209,3 +211,16 @@ 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 + -> Header.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 f3ce0c8..56debe1 100644 --- a/lib/tar_gz.ml +++ b/lib/tar_gz.ml @@ -17,27 +17,6 @@ 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 @@ -121,13 +100,17 @@ let really_read_through_gz decoder len = type error = [ `Fatal of Tar.error | `Eof | `Gz of string ] -let seek_through_gz : decoder -> int -> (unit, [> error ], _) Tar.t = fun state len -> +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 gzipped t = - let rec go : type a. decoder -> (a, [> error ] as 'err, 't) Tar.t -> (a, 'err, 't) Tar.t = fun decoder -> function +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 -> assert false (* XXX(dinosaure): actually does not emit [Tar.Read]. *) @@ -135,7 +118,8 @@ let gzipped t = | 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 in + | Tar.High _ as high -> high + | Tar.Write _ -> assert false in let decoder = let oc_buffer = De.bigstring_create 0x1000 in { gz= Gz.Inf.decoder `Manual ~o:oc_buffer @@ -145,95 +129,87 @@ let gzipped t = ; pos= 0 } in go decoder t -(* -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 - - 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 ()) +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:0 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:0 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 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 -*) +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 846b2c3..f7dd4ae 100644 --- a/lib/tar_gz.mli +++ b/lib/tar_gz.mli @@ -16,65 +16,15 @@ type error = [ `Fatal of Tar.error | `Eof | `Gz of string ] -val gzipped : ('a, ([> error ] as 'err), 't) Tar.t -> ('a, 'err, 't) Tar.t - -(* -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 -*) +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/lib_test/global_extended_headers_test.ml b/lib_test/global_extended_headers_test.ml index ff93383..a4ef1ab 100644 --- a/lib_test/global_extended_headers_test.ml +++ b/lib_test/global_extended_headers_test.ml @@ -71,7 +71,7 @@ let use_global_extended_headers _test_ctxt = 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_decode_error e + | 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 d0a6469..30f303b 100644 --- a/lib_test/parse_test.ml +++ b/lib_test/parse_test.ml @@ -40,7 +40,7 @@ let list filename = in match Tar_unix.fold f filename [] with | Ok acc -> List.rev acc - | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_decode_error e + | 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 ( = ) @@ -175,7 +175,7 @@ let can_list_pax_implicit_dir () = in match Tar_unix.fold f "lib_test/pax-shenanigans.tar" () with | Ok () -> () - | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_decode_error e + | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_error e (* Sample tar generated with commit 1583f71ea33b2836d3fb996ac7dc35d55abe2777: [let buf = @@ -198,7 +198,7 @@ let can_list_longlink_implicit_dir () = in match Tar_unix.fold f "lib_test/long-implicit-dir.tar" () with | Ok () -> () - | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_decode_error e + | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_error e let starts_with ~prefix s = let len_s = String.length s @@ -229,7 +229,7 @@ let can_transform_tar () = | 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_decode_error e + | 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" @@ -243,7 +243,7 @@ let can_transform_tar () = Tar.return (Ok ()) in match Tar_unix.fold f tar_out () with - | Error e -> Alcotest.failf "error folding2 %a" Tar_unix.pp_decode_error e + | Error e -> Alcotest.failf "error folding2 %a" Tar_unix.pp_error e | Ok () -> () module Block4096 = struct diff --git a/unix/tar_lwt_unix.ml b/unix/tar_lwt_unix.ml index 7de8215..cb7bcb5 100644 --- a/unix/tar_lwt_unix.ml +++ b/unix/tar_lwt_unix.ml @@ -82,6 +82,9 @@ 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 -> diff --git a/unix/tar_unix.ml b/unix/tar_unix.ml index 2f4c0cd..761f3b9 100644 --- a/unix/tar_unix.ml +++ b/unix/tar_unix.ml @@ -42,13 +42,14 @@ let seek fd n = safe (Unix.lseek fd n) Unix.SEEK_CUR |> Result.map ignore -type decode_error = [ +type error = [ | `Fatal of Tar.error | `Unix of Unix.error * string * string | `Unexpected_end_of_file + | `Msg of string ] -let pp_decode_error ppf = function +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)" @@ -86,6 +87,9 @@ 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 diff --git a/unix/tar_unix.mli b/unix/tar_unix.mli index 122d532..77f1b7c 100644 --- a/unix/tar_unix.mli +++ b/unix/tar_unix.mli @@ -16,17 +16,18 @@ (** Unix I/O for tar-formatted data. *) -type decode_error = [ +type error = [ | `Fatal of Tar.error | `Unix of Unix.error * string * string | `Unexpected_end_of_file + | `Msg of string ] type t -val pp_decode_error : Format.formatter -> decode_error -> unit +val pp_error : Format.formatter -> error -> unit -val run : ('a, [> decode_error ] as 'b, t) Tar.t -> Unix.file_descr -> ('a, 'b) result +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 (** [fold f filename acc] folds over the tar archive. The function [f] is called @@ -34,8 +35,8 @@ val value : ('a, 'err) result -> ('a, 'err, t) Tar.t descriptor by [hdr.Tar.Header.file_size]. *) val fold : (?global:Tar.Header.Extended.t -> Tar.Header.t -> 'a -> - ('a, decode_error, t) Tar.t) -> - string -> 'a -> ('a, decode_error) result + ('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 @@ -44,7 +45,7 @@ val fold : val extract : ?filter:(Tar.Header.t -> bool) -> src:string -> string -> - (unit, [> `Exn of exn | `Msg of string | decode_error ]) result + (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