Skip to content

Commit 1df6481

Browse files
dinosauredinosaure
authored
Use a rope instead of reversed list (#54)
* Use a rope instead of reversed list * Fix rope * Rename internal sub of rope into unsafe_sub * Delete useless comments (due to the change to rope) * Add some simple tests for rope * Remove the off parameter for Rope.sub and rename it to Rope.chop * Add documentation about rope module
1 parent 829de46 commit 1df6481

File tree

16 files changed

+414
-209
lines changed

16 files changed

+414
-209
lines changed

‎app/single.ml‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -46,12 +46,13 @@ let jump _ src src_port dst dst_port syn fin rst push ack seq window data =
4646
| false, false, false -> None
4747
| _ -> invalid_arg "invalid flag combination"
4848
and ack = match ack with None -> None | Some x -> Some (Sequence.of_int32 (Int32.of_int x))
49-
and payload = match data with None -> Cstruct.empty | Some x -> Cstruct.of_string x
50-
in
49+
and payload = match data with None -> Cstruct.empty | Some x -> Cstruct.of_string x in
50+
let payload_len = Cstruct.length payload in
51+
let payload = [ payload ] in
5152
let s = {
5253
src_port ; dst_port ;
5354
seq = Sequence.of_int32 (Int32.of_int seq) ;
54-
ack ; flag ; push ; window ; options = [] ; payload
55+
ack ; flag ; push ; window ; options = [] ; payload_len ; payload
5556
} in
5657
encode_and_checksum (Mtime_clock.now ()) ~src:Ipaddr.(V4 (V4.Prefix.address cidr)) ~dst s
5758
in

‎mirage/utcp_mirage.ml‎

Lines changed: 23 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -57,36 +57,36 @@ module Make (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.t) = struct
5757

5858
let read (t, flow) =
5959
match Utcp.recv t.tcp (now ()) flow with
60-
| Ok (tcp, data, cond, segs) ->
60+
| Ok (tcp, [], cond, segs) -> (
6161
t.tcp <- tcp ;
6262
output_ign t segs >>= fun () ->
63-
if Cstruct.length data = 0 then (
64-
Lwt_condition.wait cond >>= fun r ->
65-
match r with
63+
Lwt_condition.wait cond >>= fun r ->
64+
match r with
65+
| Error `Eof ->
66+
Lwt.return (Ok `Eof)
67+
| Error `Msg msg ->
68+
Log.err (fun m -> m "%a error %s from condition while recv" Utcp.pp_flow flow msg);
69+
(* TODO better error *)
70+
Lwt.return (Error `Refused)
71+
| Ok () ->
72+
match Utcp.recv t.tcp (now ()) flow with
73+
| Ok (tcp, data, _cond, segs) ->
74+
t.tcp <- tcp ;
75+
output_ign t segs >>= fun () ->
76+
begin match data with
77+
| [] -> Lwt.return (Ok `Eof)
78+
| data -> Lwt.return (Ok (`Data (Cstruct.concat data))) end
6679
| Error `Eof ->
6780
Lwt.return (Ok `Eof)
6881
| Error `Msg msg ->
69-
Log.err (fun m -> m "%a error %s from condition while recv" Utcp.pp_flow flow msg);
82+
Log.err (fun m -> m "%a error while read (second recv) %s" Utcp.pp_flow flow msg);
7083
(* TODO better error *)
7184
Lwt.return (Error `Refused)
72-
| Ok () ->
73-
match Utcp.recv t.tcp (now ()) flow with
74-
| Ok (tcp, data, _cond, segs) ->
75-
t.tcp <- tcp ;
76-
output_ign t segs >>= fun () ->
77-
if Cstruct.length data = 0 then
78-
Lwt.return (Ok `Eof) (* can this happen? *)
79-
else
80-
Lwt.return (Ok (`Data data))
81-
| Error `Eof ->
82-
Lwt.return (Ok `Eof)
83-
| Error `Msg msg ->
84-
Log.err (fun m -> m "%a error while read (second recv) %s" Utcp.pp_flow flow msg);
85-
(* TODO better error *)
86-
Lwt.return (Error `Refused)
87-
| Error `Not_found -> Lwt.return (Error `Refused)
88-
) else (
89-
Lwt.return (Ok (`Data data)))
85+
| Error `Not_found -> Lwt.return (Error `Refused))
86+
| Ok (tcp, data, _cond, segs) ->
87+
t.tcp <- tcp ;
88+
output_ign t segs >>= fun () ->
89+
Lwt.return (Ok (`Data (Cstruct.concat data)))
9090
| Error `Eof ->
9191
Lwt.return (Ok `Eof)
9292
| Error `Msg msg ->

‎src/input.ml‎

Lines changed: 26 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -241,7 +241,7 @@ let in_window cb seg =
241241
let seq = seg.Segment.seq
242242
and max = Sequence.addi cb.rcv_nxt cb.rcv_wnd
243243
in
244-
match Cstruct.length seg.Segment.payload, cb.rcv_wnd with
244+
match seg.Segment.payload_len, cb.rcv_wnd with
245245
| 0, 0 -> Sequence.equal seq cb.rcv_nxt
246246
| 0, _ -> Sequence.less_equal cb.rcv_nxt seq && Sequence.less seq max
247247
| _, 0 -> false
@@ -415,15 +415,15 @@ let di3_newackstuff now id conn ourfinisacked ack =
415415
(*: If this socket has previously emitted a [[FIN]] segment and the
416416
[[FIN]] has now been [[ACK]]ed, decrease [[snd_wnd]] by the length of
417417
the send queue and clear the send queue.:*)
418-
cb.snd_wnd - Cstruct.lenv conn.sndq, []
418+
cb.snd_wnd - Rope.length conn.sndq, Rope.empty
419419
else
420420
(*: Otherwise, reduce the send window by the amound of data acknowledged
421421
as it is now consuming space on the receiver's receive queue. Remove
422422
the acknowledged bytes from the send queue as they will never need to
423423
be retransmitted.:*)
424424
let acked = Sequence.window ack cb.snd_una in
425425
cb.snd_wnd - acked,
426-
List.rev (Cstruct.shiftv (List.rev conn.sndq) acked)
426+
Rope.shift conn.sndq acked
427427
in
428428
(*: Update the control block :*)
429429
let cb' =
@@ -510,7 +510,7 @@ let di3_ackstuff now id conn seg ourfinisacked fin ack =
510510
from the other end, these may all contain the same acknowledgement number
511511
and trigger the retransmit logic erroneously. :*)
512512
let maybe_dup_ack =
513-
Cstruct.length seg.payload = 0 && win = cb.snd_wnd &&
513+
seg.payload_len = 0 && win = cb.snd_wnd &&
514514
match cb.tt_rexmt with Some ((Rexmt, _), _) -> true | _ -> false
515515
in
516516
(* It turns out since some time the first FIN(+ACK) doesn't account for
@@ -636,11 +636,12 @@ let di3_datastuff_really now the_ststuff conn seg _bsd_fast_path ourfinisacked f
636636
urgent data in the segment. :*)
637637
let trim_amt_left =
638638
if Sequence.greater cb.rcv_nxt seg.Segment.seq then
639-
Int.min (Sequence.window cb.rcv_nxt seg.seq) (Cstruct.length seg.payload)
639+
Int.min (Sequence.window cb.rcv_nxt seg.seq) seg.payload_len
640640
else
641641
0
642642
in
643-
let data_trimmed_left = Cstruct.shift seg.payload trim_amt_left in
643+
let data_trimmed_left = Rope.of_css seg.payload in
644+
let data_trimmed_left = Rope.shift data_trimmed_left trim_amt_left in
644645
let seq_trimmed = Sequence.addi seg.seq trim_amt_left in
645646
(*: Trimmed data starts at [[seq_trimmed]] :*)
646647
(*: Trim any data outside the receive window from the right hand edge. If all
@@ -650,10 +651,11 @@ let di3_datastuff_really now the_ststuff conn seg _bsd_fast_path ourfinisacked f
650651
here because there is still urgent data to be received, but now in a future
651652
segment. :*)
652653
let data_trimmed_left_right =
653-
Cstruct.sub data_trimmed_left 0 (Int.min cb.rcv_wnd (Cstruct.length data_trimmed_left))
654+
let len = Int.min cb.rcv_wnd (Rope.length data_trimmed_left) in
655+
Rope.chop data_trimmed_left len
654656
in
655657
let fin_trimmed =
656-
fin && Cstruct.length data_trimmed_left_right == Cstruct.length data_trimmed_left
658+
fin && Rope.length data_trimmed_left_right == Rope.length data_trimmed_left
657659
in
658660
(*: Build trimmed segment to place on reassembly queue. If urgent data is in
659661
this segment and the socket is not doing inline delivery (and hence the
@@ -672,7 +674,7 @@ let di3_datastuff_really now the_ststuff conn seg _bsd_fast_path ourfinisacked f
672674
the conditions below. :*)
673675
let rseq_trimmed =
674676
Sequence.addi seq_trimmed
675-
(Cstruct.length data_trimmed_left_right + (if fin_trimmed then 1 else 0))
677+
(Rope.length data_trimmed_left_right + (if fin_trimmed then 1 else 0))
676678
in
677679
let (conn', fin_reass, out), cont =
678680
if
@@ -683,7 +685,7 @@ let di3_datastuff_really now the_ststuff conn seg _bsd_fast_path ourfinisacked f
683685
(*: Only need to acknowledge the segment if there is new in-window data
684686
(including urgent data) or a valid [[FIN]] :*)
685687
let have_stuff_to_ack =
686-
Cstruct.length data_trimmed_left_right > 0 || fin_trimmed
688+
Rope.length data_trimmed_left_right > 0 || fin_trimmed
687689
in
688690
(*: If the socket is connected, has data to [[ACK]] but no [[FIN]] to
689691
[[ACK]], the reassembly queue is empty, the socket is not currently
@@ -700,10 +702,10 @@ let di3_datastuff_really now the_ststuff conn seg _bsd_fast_path ourfinisacked f
700702
let t_segq, r = Reassembly_queue.maybe_take cb.t_segq rseq_trimmed in
701703
(* Length (in sequence space) of reassembled data, counting a [[FIN]] as
702704
one byte and including any out-of-line urgent data previously removed *)
703-
let data_reass, fin_reass0 = Option.value ~default:(Cstruct.empty, false) r in
704-
let data = Cstruct.append data_trimmed_left_right data_reass in
705+
let data_reass, fin_reass0 = Option.value ~default:(Rope.empty, false) r in
706+
let data = Rope.concat data_trimmed_left_right data_reass in
705707
let fin_reass_trimmed = fin_trimmed || fin_reass0 in
706-
let data_len = Cstruct.length data + if fin_reass_trimmed then 1 else 0 in
708+
let data_len = Rope.length data + if fin_reass_trimmed then 1 else 0 in
707709
(*: Add the reassembled data to the receive queue and increment [[rcv_nxt]]
708710
to mark the sequence number of the byte past the last byte in the
709711
receive queue:*)
@@ -723,7 +725,7 @@ let di3_datastuff_really now the_ststuff conn seg _bsd_fast_path ourfinisacked f
723725
(*: Set if not delaying an [[ACK]] and have stuff to [[ACK]] :*)
724726
not delay_ack && have_stuff_to_ack
725727
and rcv_nxt = Sequence.addi cb.rcv_nxt data_len
726-
and rcv_wnd = cb.rcv_wnd - (Cstruct.length data)
728+
and rcv_wnd = cb.rcv_wnd - (Rope.length data)
727729
in
728730
let control_block = {
729731
cb with
@@ -733,7 +735,7 @@ let di3_datastuff_really now the_ststuff conn seg _bsd_fast_path ourfinisacked f
733735
rcv_nxt ;
734736
rcv_wnd ;
735737
}
736-
and rcvq = data :: conn.rcvq
738+
and rcvq = Rope.concat conn.rcvq data
737739
in
738740
({ conn with control_block ; rcvq }, fin_reass_trimmed, []), true
739741
(*: Case (2) The segment contains new out-of-order in-window data, possibly
@@ -743,7 +745,7 @@ let di3_datastuff_really now the_ststuff conn seg _bsd_fast_path ourfinisacked f
743745
else if
744746
Sequence.greater seq_trimmed cb.rcv_nxt &&
745747
Sequence.less seq_trimmed (Sequence.addi cb.rcv_nxt cb.rcv_wnd) &&
746-
Cstruct.length data_trimmed_left_right + (if fin_trimmed then 1 else 0) > 0 &&
748+
Rope.length data_trimmed_left_right + (if fin_trimmed then 1 else 0) > 0 &&
747749
cb.rcv_wnd > 0
748750
then
749751
(*: Hack: assertion used to share values with later conditions :*)
@@ -762,7 +764,7 @@ let di3_datastuff_really now the_ststuff conn seg _bsd_fast_path ourfinisacked f
762764
segment) is used in the guard to ensure this really was a pure [[ACK]]
763765
segment. :*)
764766
else if Sequence.equal seq_trimmed cb.rcv_nxt &&
765-
Cstruct.length seg.payload + (if fin then 1 else 0) = 0
767+
seg.payload_len + (if fin then 1 else 0) = 0
766768
then
767769
(*: Hack: assertion used to share values with later conditions :*)
768770
let fin_reass = false in (* Have not received a FIN *)
@@ -823,7 +825,7 @@ let di3_datastuff now the_ststuff conn seg ourfinisacked fin ack =
823825
((Sequence.greater ack cb.snd_una && Sequence.less_equal ack cb.snd_max &&
824826
cb.snd_cwnd >= cb.snd_wnd && cb.t_dupacks < 3)
825827
|| (Sequence.equal ack cb.snd_una && Reassembly_queue.is_empty cb.t_segq &&
826-
Cstruct.length seg.payload < conn.rcvbufsize - Cstruct.lenv conn.rcvq))
828+
seg.payload_len < conn.rcvbufsize - Rope.length conn.rcvq))
827829
in
828830
(*: Update the send window using the received segment if the segment will not be processed by
829831
BSD's fast path, has the [[ACK]] flag set, is not to the right of the window, and either:
@@ -846,7 +848,7 @@ let di3_datastuff now the_ststuff conn seg ourfinisacked fin ack =
846848
(Sequence.less cb.snd_wl2 ack || Sequence.equal cb.snd_wl2 ack && win > cb.snd_wnd)))
847849
in
848850
let seq_trimmed =
849-
Sequence.max seg.seq (Sequence.min cb.rcv_nxt (Sequence.addi seg.seq (Cstruct.length seg.payload)))
851+
Sequence.max seg.seq (Sequence.min cb.rcv_nxt (Sequence.addi seg.seq seg.payload_len))
850852
in
851853
(*: Write back the window updates :*)
852854
let control_block =
@@ -923,7 +925,7 @@ let deliver_in_3 m now id conn seg flag ack =
923925
let fin = flag = Some `Fin in
924926
(* PAWS, timers, rcv_wnd may have opened! updates fin_wait_2 timer *)
925927
let cb = conn.control_block in
926-
let wesentafin = Sequence.greater cb.snd_max (Sequence.addi cb.snd_una (Cstruct.lenv conn.sndq)) in
928+
let wesentafin = Sequence.greater cb.snd_max (Sequence.addi cb.snd_una (Rope.length conn.sndq)) in
927929
let ourfinisacked = wesentafin && Sequence.greater_equal ack cb.snd_max in
928930
let control_block = di3_topstuff now conn in
929931
(* ACK processing *)
@@ -1060,7 +1062,7 @@ let handle_conn t now id conn seg =
10601062
let* () =
10611063
guard (in_window conn.control_block seg)
10621064
(`Drop (fun () -> Fmt.str "in_window seq %a seql %u rcv_nxt %a rcv_wnd %u"
1063-
Sequence.pp seg.Segment.seq (Cstruct.length seg.payload)
1065+
Sequence.pp seg.Segment.seq seg.payload_len
10641066
Sequence.pp conn.control_block.rcv_nxt conn.control_block.rcv_wnd))
10651067
in
10661068
(* RFC5961: challenge acks for SYN and (RST where seq != rcv_nxt), keep state *)
@@ -1109,7 +1111,7 @@ let handle_buf t now ~src ~dst data =
11091111
| Ok (seg, id) ->
11101112
Tracing.debug (fun m -> m "%a [%a] handle_buf %u %s"
11111113
Connection.pp id Mtime.pp now
1112-
(Cstruct.length seg.payload)
1114+
seg.payload_len
11131115
(Base64.encode_string (Cstruct.to_string data)));
11141116
(* deliver_in_3a deliver_in_4 are done now! *)
11151117
let t', outs = handle_segment t now id seg in
@@ -1125,8 +1127,8 @@ let handle_buf t now ~src ~dst data =
11251127
| Some s ->
11261128
s.tcp_state = Established,
11271129
true,
1128-
Cstruct.lenv s.rcvq > 0,
1129-
Cstruct.lenv s.sndq < s.sndbufsize,
1130+
Rope.length s.rcvq > 0,
1131+
Rope.length s.sndq < s.sndbufsize,
11301132
Some s.rcv_notify, Some s.snd_notify
11311133
in
11321134
match was_established, is_established, was_present, is_present with

‎src/rope.ml‎

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
type t =
2+
| Str of Cstruct.t * int * int
3+
| App of t * t * int * int
4+
5+
let length = function
6+
| Str (_, _, len)
7+
| App (_, _, len, _) -> len
8+
9+
let empty = Str (Cstruct.empty, 0, 0)
10+
11+
let height = function
12+
| Str _ -> 0
13+
| App (_, _, _, h) -> h
14+
15+
let append = function
16+
| Str (_,_,0), t | t, Str (_,_,0) -> t
17+
| t1, t2 ->
18+
App (t1, t2, length t1 + length t2, 1 + Int.max (height t1) (height t2))
19+
20+
21+
let rec unsafe_sub t start stop =
22+
if start == 0 && stop = length t
23+
then t else match t with
24+
| Str (str, off, _) ->
25+
Str (str, off + start, stop - start)
26+
| App (l, r, _, _) ->
27+
let len = length l in
28+
if stop <= len then unsafe_sub l start stop
29+
else if start >= len then unsafe_sub r (start - len) (stop - len)
30+
else append (unsafe_sub l start len, unsafe_sub r 0 (stop - len))
31+
32+
let chop t len =
33+
if len < 0 || len > length t
34+
then invalid_arg "Rope.chop";
35+
if len == 0 then empty else unsafe_sub t 0 len
36+
37+
let shift t len =
38+
if len < 0 then t
39+
else if len == 0 then t
40+
else
41+
let max = length t in
42+
let len = Int.min max len in
43+
unsafe_sub t len (len + (max - len))
44+
45+
let rec into_bytes buf dst_off = function
46+
| Str (cs, src_off, len) -> Cstruct.blit_to_bytes cs src_off buf dst_off len
47+
| App (l, r, _, _) ->
48+
into_bytes buf dst_off l;
49+
into_bytes buf (dst_off + length l) r
50+
51+
let to_css t =
52+
let rec go acc = function
53+
| Str (_, _, 0) | Str ({ Cstruct.len= 0; _ }, _, _) -> acc
54+
| Str ({ Cstruct.len= rlen; _ } as cs, 0, len) ->
55+
if rlen == len then cs :: acc
56+
else Cstruct.sub cs 0 len :: acc
57+
| Str (cs, off, len) ->
58+
Cstruct.sub cs off len :: acc
59+
| App (l, r, _, _) -> go (go acc r) l in
60+
go [] t
61+
62+
let to_cs t =
63+
let buf = Cstruct.create (length t) in
64+
let rec go dst_off = function
65+
| Str (_, _, 0) | Str ({ Cstruct.len= 0; _ }, _, _) -> ()
66+
| Str (cs, src_off, len) -> Cstruct.blit cs src_off buf dst_off len
67+
| App (l, r, _, _) ->
68+
go dst_off l;
69+
go (dst_off + length l) r in
70+
go 0 t; buf
71+
72+
let to_string t =
73+
let len = length t in
74+
let buf = Bytes.create len in
75+
into_bytes buf 0 t;
76+
Bytes.unsafe_to_string buf
77+
78+
let concat a b = append (a, b)
79+
let prepend ({ Cstruct.len; _ } as cs) t = append (Str (cs, 0, len), t)
80+
81+
let append t ?(off= 0) ?len ({ Cstruct.len= rlen; _ } as cs) =
82+
let len = match len with
83+
| Some len -> len | None -> rlen - off in
84+
append (t, (Str (cs, off, len)))
85+
86+
let of_cs ({ Cstruct.len; _ } as cs) = Str (cs, 0, len)
87+
let of_css css = List.fold_left (fun t cs -> append t cs) empty css
88+
let of_string str = of_cs (Cstruct.of_string str)
89+
90+
let equal a b =
91+
String.equal (to_string a) (to_string b)

0 commit comments

Comments
 (0)