Skip to content

Commit

Permalink
remove offset nonsense
Browse files Browse the repository at this point in the history
  • Loading branch information
@hannesm
hannesm committed Feb 3, 2024
1 parent d85cb7e commit 16d6905
Show file tree
Hide file tree
Showing 2 changed files with 69 additions and 82 deletions.
129 changes: 59 additions & 70 deletions unix/tar_unix.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,90 +17,85 @@

let ( let* ) = Result.bind

let rec safe ~off f a =
let rec safe f a =
try Ok (f a) with
| Unix.Unix_error (Unix.EINTR, _, _) -> safe ~off f a
| Unix.Unix_error (e, f, s) -> Error (`Unix (off, e, f, s))
| 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 _ -> ()

let read_complete ~off fd buf len =
let read_complete fd buf len =
let rec loop offset =
if offset < len then
let* n = safe ~off (Unix.read fd buf offset) (len - offset) in
let* n = safe (Unix.read fd buf offset) (len - offset) in
if n = 0 then
Error (`Unexpected_end_of_file off)
Error `Unexpected_end_of_file
else
loop (offset + n)
else
Ok ()
in
loop 0

let seek ~off fd n =
safe ~off (Unix.lseek fd n) Unix.SEEK_CUR
let seek fd n =
safe (Unix.lseek fd n) Unix.SEEK_CUR

type decode_error = [
| `Fatal of int * [ `Checksum_mismatch | `Corrupt_pax_header | `Unmarshal of string ]
| `Unix of int * Unix.error * string * string
| `Unexpected_end_of_file of int
| `Msg of int * string
| `Fatal of [ `Checksum_mismatch | `Corrupt_pax_header | `Unmarshal of string ]
| `Unix of Unix.error * string * string
| `Unexpected_end_of_file
| `Msg of string
]

let pp_decode_error ppf = function
| `Fatal (off, err) ->
Format.fprintf ppf "Offset %u, %a" off Tar.pp_error err
| `Unix (off, err, fname, arg) ->
Format.fprintf ppf "Offset %u, Unix error %s (function %s, arg %s)" off
| `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 off ->
Format.fprintf ppf "Offset %u unexpected end of file" off
| `Msg (off, msg) ->
Format.fprintf ppf "Offset %u error %s" off msg
| `Unexpected_end_of_file ->
Format.fprintf ppf "Unexpected end of file"
| `Msg msg ->
Format.fprintf ppf "Error %s" msg

let fold f filename init =
let* fd = safe ~off:0 Unix.(openfile filename [ O_RDONLY ]) 0 in
let rec go ~off t fd ?global ?data acc =
let* fd = safe Unix.(openfile filename [ O_RDONLY ]) 0 in
let rec go t fd ?global ?data acc =
let* data = match data with
| None ->
let buf = Bytes.make Tar.Header.length '\000' in
let* () = read_complete ~off fd buf Tar.Header.length in
let* () = read_complete fd buf Tar.Header.length in
Ok (Bytes.unsafe_to_string buf)
| Some data -> Ok data
in
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
let* acc' =
Result.map_error
(fun (`Msg s) -> `Msg (off, s))
(f fd ?global hdr acc)
in
let* off = seek ~off fd (Tar.Header.compute_zero_padding_length hdr) in
go ~off t fd ?global acc'
let* acc' = f fd ?global hdr acc in
let* _off = seek fd (Tar.Header.compute_zero_padding_length hdr) in
go t fd ?global acc'
| Ok (t, Some `Skip n, g) ->
let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
let* off = seek ~off fd n in
go ~off t fd ?global acc
let* _off = seek fd n in
go t fd ?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
let* () = read_complete ~off fd buf n in
let* () = read_complete fd buf n in
let data = Bytes.unsafe_to_string buf in
go ~off:(off + n) t fd ?global ~data acc
go t fd ?global ~data acc
| Ok (t, None, g) ->
let global = Option.fold ~none:global ~some:(fun g -> Some g) g in
go ~off t fd ?global acc
go t fd ?global acc
| Error `Eof -> Ok acc
| Error `Fatal e -> Error (`Fatal (off, e))
| Error `Fatal _ as e -> e
in
Fun.protect
~finally:(fun () -> safe_close fd)
(fun () -> go ~off:0 (Tar.decode_state ()) fd init)
(fun () -> go (Tar.decode_state ()) fd init)

let map_to_msg = function
| `Unix (_off, e, f, s) ->
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)

Expand All @@ -115,14 +110,14 @@ let copy ~src_fd ~dst_fd len =
let* () =
Result.map_error
(function
| `Unix _ as e -> map_to_msg e
| `Unexpected_end_of_file _off ->
`Msg ("Unexpected end of file"))
(read_complete ~off:0 src_fd buffer l)
| `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 map_to_msg
(safe ~off:0 (Unix.write dst_fd buffer 0) l)
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
Expand All @@ -134,30 +129,27 @@ let extract ?(filter = fun _ -> true) ~src dst =
match hdr.Tar.Header.link_indicator with
| Tar.Header.Link.Normal ->
let* dst =
Result.map_error map_to_msg
(safe ~off:0 Unix.(openfile (Filename.concat dst hdr.Tar.Header.file_name)
[ O_WRONLY ; O_CREAT ]) hdr.Tar.Header.file_mode)
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)
in
Fun.protect ~finally:(fun () -> safe_close dst)
(fun () -> copy ~src_fd:fd ~dst_fd:dst (Int64.to_int hdr.Tar.Header.file_size))
(* TODO set owner / mode / mtime etc. *)
(* TODO set owner / mode / mtime etc. *)
| _ -> Error (`Msg "not yet handled")
else
let* _off =
Result.map_error (fun (`Unix (_off, e, f, s)) ->
`Msg (Format.sprintf "error %s in function %s %s"
(Unix.error_message e) f s))
(seek ~off:0 fd (Int64.to_int hdr.Tar.Header.file_size))
Result.map_error unix_err_to_msg
(seek fd (Int64.to_int hdr.Tar.Header.file_size))
in
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 = safe ~off:0 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
Expand All @@ -181,15 +173,13 @@ let append_file ?level ?header filename fd =
let* _off =
List.fold_left (fun acc d ->
let* _off = acc in
Result.map_error map_to_msg
(safe ~off:0 (Unix.write_substring fd d 0) (String.length d)))
Result.map_error unix_err_to_msg
(safe (Unix.write_substring fd d 0) (String.length d)))
(Ok 0) header_strings
in
let* src =
Result.map_error (fun (`Unix (_off, e, f, s)) ->
`Msg (Format.sprintf "error %s in function %s %s"
(Unix.error_message e) f s))
(safe ~off:0 Unix.(openfile filename [ O_RDONLY ]) 0)
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)
Expand All @@ -201,26 +191,25 @@ let write_global_extended_header ?level header fd =
let* _off =
List.fold_left (fun acc d ->
let* _off = acc in
Result.map_error map_to_msg
(safe ~off:0 (Unix.write_substring fd d 0) (String.length d)))
Result.map_error unix_err_to_msg
(safe (Unix.write_substring fd d 0) (String.length d)))
(Ok 0) header_strings
in
Ok ()
let write_end fd =
let* _written =
Result.map_error map_to_msg
(safe ~off:0
Result.map_error unix_err_to_msg
(safe
(Unix.write_substring fd (Tar.Header.zero_block ^ Tar.Header.zero_block) 0)
(Tar.Header.length + Tar.Header.length))
in
Ok ()
let create ?level ?global ?(filter = fun _ -> true) ~src dst =
let* dst_fd =
Result.map_error map_to_msg
(safe ~off:0 Unix.(openfile dst [ O_WRONLY ; O_CREAT ])
0o644)
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 () ->
Expand All @@ -230,12 +219,12 @@ let create ?level ?global ?(filter = fun _ -> true) ~src dst =
write_global_extended_header ?level hdr dst_fd
in
let rec copy_files directory =
let* dir = safe ~off:0 Unix.opendir directory in
let* dir = safe Unix.opendir directory in
Fun.protect ~finally:(fun () -> try Unix.closedir dir with _ -> ())
(fun () ->
let rec next () =
try
let* name = safe ~off:0 Unix.readdir dir in
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
Expand Down
22 changes: 10 additions & 12 deletions unix/tar_unix.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,13 +16,11 @@

(** Unix I/O for tar-formatted data. *)

(* TODO provide a type error and a pretty-printer *)

type decode_error = [
| `Fatal of int * [ `Checksum_mismatch | `Corrupt_pax_header | `Unmarshal of string ]
| `Unix of int * Unix.error * string * string
| `Unexpected_end_of_file of int
| `Msg of int * string
| `Fatal of [ `Checksum_mismatch | `Corrupt_pax_header | `Unmarshal of string ]
| `Unix of Unix.error * string * string
| `Unexpected_end_of_file
| `Msg of string
]

val pp_decode_error : Format.formatter -> decode_error -> unit
Expand All @@ -31,8 +29,8 @@ val pp_decode_error : Format.formatter -> decode_error -> unit
for each [hdr : Tar.Header.t]. It should forward the position in the file
descriptor by [hdr.Tar.Header.file_size]. *)
val fold :
(Unix.file_descr -> ?global:Tar.Header.Extended.t -> Tar.Header.t ->
'a -> ('a, [ `Msg of string ]) result) ->
(Unix.file_descr -> ?global:Tar.Header.Extended.t -> Tar.Header.t -> 'a ->
('a, decode_error) result) ->
string -> 'a -> ('a, decode_error) result

(** [extract ~filter ~src dst] extracts the tar archive [src] into the
Expand All @@ -52,24 +50,24 @@ 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 (int * Unix.error * string * string) ]) result
(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, [ `Unix of (int * Unix.error * string * string) ]) result
(Tar.Header.t, [ `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 (int * Unix.error * string * string) ]) result
(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 (int * Unix.error * string * string) ]) result
(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

0 comments on commit 16d6905

Please sign in to comment.