Source file flux_tar.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
module Buf = struct
type t = { mutable buf: bytes; mutable pos: int; mutable len: int }
let create len = { buf= Bytes.create len; pos= 0; len= 0 }
let max t = t.len
let get t len =
if len > t.len then Error `Not_enough
else begin
let str = Bytes.sub_string t.buf t.pos len in
t.pos <- t.pos + len;
t.len <- t.len - len;
if t.len = 0 then t.pos <- 0;
Ok str
end
let compress t =
if t.pos > 0 then begin
Bytes.blit t.buf t.pos t.buf 0 t.len;
t.pos <- 0
end
let extend t more =
assert (t.pos = 0);
let len = ref t.len in
while t.len + more > !len do
len := 2 * !len
done;
if !len > Sys.max_string_length then begin
if t.len + more <= Sys.max_string_length then len := Sys.max_string_length
else failwith "Buf.extend: cannot grow buffer"
end;
let buf = Bytes.create !len in
Bytes.blit t.buf 0 buf 0 t.len;
t.buf <- buf
let rem t = Bytes.length t.buf - (t.pos + t.len)
let put t str =
let len = String.length str in
if rem t < len then compress t;
if rem t < len then extend t len;
Bytes.blit_string str 0 t.buf (t.pos + t.len) len;
t.len <- t.len + len
let skip t len =
if t.len < len then invalid_arg "Buf.skip";
t.pos <- t.pos + len;
t.len <- t.len - len;
if t.len = 0 then t.pos <- 0
end
let is_enough buf hdr =
let len = Int64.to_int hdr.Tar.Header.file_size in
Buf.max buf >= len
let _pp ppf = function
| Ok _ -> Format.fprintf ppf "<Ok>"
| Error `Eof -> Format.fprintf ppf "<Eof>"
| Error (`Fatal _) -> Format.fprintf ppf "<Fatal>"
let untar =
let open Flux in
let flow (Sink k) =
let rec unfold acc buf = function
| Ok (tar, Some (`Read req), _) when Buf.max buf >= req ->
let data = Result.get_ok (Buf.get buf req) in
unfold acc buf (Tar.decode tar data)
| Ok (tar, Some (`Skip rem), _) when Buf.max buf >= rem ->
Buf.skip buf rem;
unfold acc buf (Ok (tar, None, None))
| Ok (tar, Some (`Header hdr), _) when is_enough buf hdr ->
let len = Int64.to_int hdr.Tar.Header.file_size in
let contents = Result.get_ok (Buf.get buf len) in
let acc = k.push acc (hdr, contents) in
if k.full acc then (acc, buf, Error `Eof)
else
let rem = Tar.Header.compute_zero_padding_length hdr in
unfold acc buf (Ok (tar, Some (`Skip rem), None))
| Ok (tar, None, _) when Buf.max buf >= Tar.Header.length ->
let data = Result.get_ok (Buf.get buf Tar.Header.length) in
unfold acc buf (Tar.decode tar data)
| state ->
(acc, buf, state)
in
let rec finalise acc buf = function
| Ok (tar, Some (`Read req), _) when Buf.max buf >= req ->
let data = Result.get_ok (Buf.get buf req) in
finalise acc buf (Tar.decode tar data)
| Ok (tar, Some (`Skip rem), _) when Buf.max buf >= rem ->
Buf.skip buf rem;
finalise acc buf (Ok (tar, None, None))
| Ok (tar, Some (`Header hdr), _) when is_enough buf hdr ->
let len = Int64.to_int hdr.Tar.Header.file_size in
let contents = Result.get_ok (Buf.get buf len) in
let acc = k.push acc (hdr, contents) in
if k.full acc then k.stop acc
else
let rem = Tar.Header.compute_zero_padding_length hdr in
finalise acc buf (Ok (tar, Some (`Skip rem), None))
| Ok (tar, None, _) when Buf.max buf >= Tar.Header.length ->
let data = Result.get_ok (Buf.get buf Tar.Header.length) in
finalise acc buf (Tar.decode tar data)
| _ -> k.stop acc
in
let init () =
let tar = Tar.decode_state ()
and buf = Buf.create 0x7ff
and acc = k.init () in
(acc, buf, Ok (tar, None, None))
and push (acc, buf, state) str = Buf.put buf str; unfold acc buf state
and full (acc, _, state) =
match state with Error (`Eof | `Fatal _) -> true | _ -> k.full acc
and stop (acc, buf, state) =
if k.full acc then k.stop acc else finalise acc buf state
in
Sink { init; push; full; stop }
in
{ flow }