Licklider Transmission Protocol (CCSDS 734.1-B) for reliable DTN links
Squashed 'ocaml-ltp/' content from commit 088e26d7 git-subtree-split: 088e26d7b96204b8a699715248672af20058127d
+1228
+11
.gitignore
+11
.gitignore
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version=0.28.1
+15
LICENSE.md
+15
LICENSE.md
···
1
+
ISC License
2
+
3
+
Copyright (c) 2025 Thomas Gazagnaire
4
+
5
+
Permission to use, copy, modify, and/or distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
10
+
REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
11
+
AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
12
+
INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
13
+
LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
14
+
OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
15
+
PERFORMANCE OF THIS SOFTWARE.
+26
dune-project
+26
dune-project
···
1
+
(lang dune 3.0)
2
+
3
+
(name ltp)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(license ISC)
8
+
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
9
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
10
+
11
+
(source
12
+
(uri https://tangled.org/gazagnaire.org/ocaml-ltp))
13
+
14
+
(package
15
+
(name ltp)
16
+
(synopsis "Licklider Transmission Protocol (RFC 5326)")
17
+
(description
18
+
"LTP is a reliable data delivery protocol designed for high-delay and
19
+
disruption-prone communication links, such as deep-space communications.
20
+
It provides selective acknowledgment and retransmission with support for
21
+
both reliable (red) and unreliable (green) data segments.")
22
+
(depends
23
+
(ocaml (>= 4.14))
24
+
(fmt (>= 0.9))
25
+
(alcotest :with-test)
26
+
(crowbar :with-test)))
+18
fuzz/dune
+18
fuzz/dune
···
1
+
(executable
2
+
(name fuzz_ltp)
3
+
(modules fuzz_ltp)
4
+
(libraries ltp crowbar))
5
+
6
+
(rule
7
+
(alias fuzz)
8
+
(deps fuzz_ltp.exe)
9
+
(action
10
+
(run %{exe:fuzz_ltp.exe})))
11
+
12
+
(rule
13
+
(alias fuzz-afl)
14
+
(deps
15
+
(source_tree input)
16
+
fuzz_ltp.exe)
17
+
(action
18
+
(echo "AFL fuzzer built: %{exe:fuzz_ltp.exe}\n")))
+121
fuzz/fuzz_ltp.ml
+121
fuzz/fuzz_ltp.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Crowbar
7
+
8
+
let truncate s = if String.length s > 1024 then String.sub s 0 1024 else s
9
+
10
+
(** SDNV decode - must not crash. *)
11
+
let test_sdnv_decode buf =
12
+
let buf = truncate buf in
13
+
let _ = Ltp.decode_sdnv buf 0 in
14
+
()
15
+
16
+
(** SDNV roundtrip. *)
17
+
let test_sdnv_roundtrip n =
18
+
if n < 0L then ()
19
+
else
20
+
let encoded = Ltp.encode_sdnv n in
21
+
match Ltp.decode_sdnv encoded 0 with
22
+
| Ok (decoded, _) -> if decoded <> n then fail "SDNV roundtrip mismatch"
23
+
| Error _ -> fail "SDNV decode failed after encode"
24
+
25
+
(** Segment decode - must not crash. *)
26
+
let test_segment_decode buf =
27
+
let buf = truncate buf in
28
+
let _ = Ltp.decode_segment buf in
29
+
()
30
+
31
+
(** Green data segment roundtrip. *)
32
+
let test_green_roundtrip orig_n sess_n svc_id offset data =
33
+
let data = truncate data in
34
+
if String.length data = 0 then ()
35
+
else
36
+
let session_id = Ltp.{ originator = Int64.of_int orig_n; number = Int64.of_int sess_n } in
37
+
let seg =
38
+
Ltp.make_data_segment ~session_id
39
+
~client_service_id:(Int64.of_int svc_id)
40
+
~block_offset:(Int64.of_int offset) data
41
+
in
42
+
let encoded = Ltp.encode_segment seg in
43
+
match Ltp.decode_segment encoded with
44
+
| Ok decoded -> (
45
+
match decoded.content with
46
+
| Ltp.Data ds -> if ds.data <> data then fail "green data mismatch"
47
+
| _ -> fail "wrong content type")
48
+
| Error _ -> fail "green segment decode failed"
49
+
50
+
(** Red checkpoint roundtrip. *)
51
+
let test_red_roundtrip orig_n sess_n cp_serial data =
52
+
let data = truncate data in
53
+
if String.length data = 0 then ()
54
+
else
55
+
let session_id = Ltp.{ originator = Int64.of_int orig_n; number = Int64.of_int sess_n } in
56
+
let seg =
57
+
Ltp.make_data_segment ~session_id ~client_service_id:1L ~block_offset:0L
58
+
~checkpoint_serial:(Int64.of_int cp_serial) ~report_serial:0L data
59
+
in
60
+
let encoded = Ltp.encode_segment seg in
61
+
match Ltp.decode_segment encoded with
62
+
| Ok decoded -> (
63
+
match decoded.content with
64
+
| Ltp.Data ds ->
65
+
if ds.data <> data then fail "red data mismatch";
66
+
if ds.checkpoint_serial <> Some (Int64.of_int cp_serial) then
67
+
fail "checkpoint serial mismatch"
68
+
| _ -> fail "wrong content type")
69
+
| Error _ -> fail "red segment decode failed"
70
+
71
+
(** Report segment roundtrip. *)
72
+
let test_report_roundtrip orig_n sess_n rpt_serial cp_serial upper =
73
+
let session_id = Ltp.{ originator = Int64.of_int orig_n; number = Int64.of_int sess_n } in
74
+
let claims = [ Ltp.{ offset = 0L; length = Int64.of_int upper } ] in
75
+
let seg =
76
+
Ltp.make_report_segment ~session_id
77
+
~report_serial:(Int64.of_int rpt_serial)
78
+
~checkpoint_serial:(Int64.of_int cp_serial)
79
+
~upper_bound:(Int64.of_int upper) claims
80
+
in
81
+
let encoded = Ltp.encode_segment seg in
82
+
match Ltp.decode_segment encoded with
83
+
| Ok decoded -> (
84
+
match decoded.content with
85
+
| Ltp.Report rs ->
86
+
if rs.report_serial <> Int64.of_int rpt_serial then
87
+
fail "report serial mismatch"
88
+
| _ -> fail "wrong content type")
89
+
| Error _ -> fail "report segment decode failed"
90
+
91
+
(** Cancel segment roundtrip. *)
92
+
let test_cancel_roundtrip orig_n sess_n reason_code from_sender =
93
+
let session_id = Ltp.{ originator = Int64.of_int orig_n; number = Int64.of_int sess_n } in
94
+
let reason = Ltp.cancel_reason_of_int (reason_code mod 6) in
95
+
let seg = Ltp.make_cancel ~session_id ~from_sender reason in
96
+
let encoded = Ltp.encode_segment seg in
97
+
match Ltp.decode_segment encoded with
98
+
| Ok decoded -> (
99
+
match decoded.content with
100
+
| Ltp.Cancel cs ->
101
+
if Ltp.cancel_reason_to_int cs.reason <> reason_code mod 6 then
102
+
fail "cancel reason mismatch"
103
+
| _ -> fail "wrong content type")
104
+
| Error _ -> fail "cancel segment decode failed"
105
+
106
+
let () =
107
+
add_test ~name:"ltp: SDNV decode no crash" [ bytes ] test_sdnv_decode;
108
+
add_test ~name:"ltp: SDNV roundtrip" [ int64 ] test_sdnv_roundtrip;
109
+
add_test ~name:"ltp: segment decode no crash" [ bytes ] test_segment_decode;
110
+
add_test ~name:"ltp: green segment roundtrip"
111
+
[ range 1000; range 1000; range 100; range 1000; bytes ]
112
+
test_green_roundtrip;
113
+
add_test ~name:"ltp: red segment roundtrip"
114
+
[ range 1000; range 1000; range 1000; bytes ]
115
+
test_red_roundtrip;
116
+
add_test ~name:"ltp: report segment roundtrip"
117
+
[ range 1000; range 1000; range 1000; range 1000; range 10000 ]
118
+
test_report_roundtrip;
119
+
add_test ~name:"ltp: cancel segment roundtrip"
120
+
[ range 1000; range 1000; range 256; bool ]
121
+
test_cancel_roundtrip
fuzz/input/empty
fuzz/input/empty
This is a binary file and will not be displayed.
+539
lib/ltp.ml
+539
lib/ltp.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Licklider Transmission Protocol (RFC 5326). *)
7
+
8
+
(* {1 SDNV Encoding} *)
9
+
10
+
let encode_sdnv n =
11
+
if n = 0L then "\x00"
12
+
else
13
+
let rec collect acc n =
14
+
if n = 0L then acc
15
+
else
16
+
let byte = Int64.to_int (Int64.logand n 0x7FL) in
17
+
collect (byte :: acc) (Int64.shift_right_logical n 7)
18
+
in
19
+
let bytes = collect [] n in
20
+
let len = List.length bytes in
21
+
let buf = Bytes.create len in
22
+
List.iteri
23
+
(fun i byte ->
24
+
let byte = if i < len - 1 then byte lor 0x80 else byte in
25
+
Bytes.set buf i (Char.chr byte))
26
+
bytes;
27
+
Bytes.to_string buf
28
+
29
+
let decode_sdnv buf off =
30
+
let len = String.length buf in
31
+
if off >= len then Error "truncated SDNV"
32
+
else
33
+
let rec loop acc i =
34
+
if i >= len then Error "truncated SDNV"
35
+
else
36
+
let byte = Char.code (String.get buf i) in
37
+
let value = Int64.logor (Int64.shift_left acc 7) (Int64.of_int (byte land 0x7F)) in
38
+
if byte land 0x80 = 0 then Ok (value, i + 1)
39
+
else loop value (i + 1)
40
+
in
41
+
loop 0L off
42
+
43
+
(* {1 Engine and Session IDs} *)
44
+
45
+
type engine_id = int64
46
+
type session_number = int64
47
+
type session_id = { originator : engine_id; number : session_number }
48
+
49
+
let pp_session_id fmt s =
50
+
Format.fprintf fmt "%Ld:%Ld" s.originator s.number
51
+
52
+
(* {1 Segment Types} *)
53
+
54
+
type segment_type =
55
+
| Red_data
56
+
| Red_checkpoint
57
+
| Red_checkpoint_eorp
58
+
| Red_checkpoint_eorp_eob
59
+
| Green_data
60
+
| Green_eob
61
+
| Report
62
+
| Report_ack
63
+
| Cancel_from_sender
64
+
| Cancel_ack_to_sender
65
+
| Cancel_from_receiver
66
+
| Cancel_ack_to_receiver
67
+
68
+
let pp_segment_type fmt = function
69
+
| Red_data -> Format.fprintf fmt "Red_data"
70
+
| Red_checkpoint -> Format.fprintf fmt "Red_checkpoint"
71
+
| Red_checkpoint_eorp -> Format.fprintf fmt "Red_checkpoint_eorp"
72
+
| Red_checkpoint_eorp_eob -> Format.fprintf fmt "Red_checkpoint_eorp_eob"
73
+
| Green_data -> Format.fprintf fmt "Green_data"
74
+
| Green_eob -> Format.fprintf fmt "Green_eob"
75
+
| Report -> Format.fprintf fmt "Report"
76
+
| Report_ack -> Format.fprintf fmt "Report_ack"
77
+
| Cancel_from_sender -> Format.fprintf fmt "Cancel_from_sender"
78
+
| Cancel_ack_to_sender -> Format.fprintf fmt "Cancel_ack_to_sender"
79
+
| Cancel_from_receiver -> Format.fprintf fmt "Cancel_from_receiver"
80
+
| Cancel_ack_to_receiver -> Format.fprintf fmt "Cancel_ack_to_receiver"
81
+
82
+
let segment_type_to_int = function
83
+
| Red_data -> 0
84
+
| Red_checkpoint -> 1
85
+
| Red_checkpoint_eorp -> 2
86
+
| Red_checkpoint_eorp_eob -> 3
87
+
| Green_data -> 4
88
+
| Green_eob -> 7
89
+
| Report -> 8
90
+
| Report_ack -> 9
91
+
| Cancel_from_sender -> 12
92
+
| Cancel_ack_to_sender -> 13
93
+
| Cancel_from_receiver -> 14
94
+
| Cancel_ack_to_receiver -> 15
95
+
96
+
let segment_type_of_int = function
97
+
| 0 -> Some Red_data
98
+
| 1 -> Some Red_checkpoint
99
+
| 2 -> Some Red_checkpoint_eorp
100
+
| 3 -> Some Red_checkpoint_eorp_eob
101
+
| 4 -> Some Green_data
102
+
| 5 -> Some Green_data (* type 5-6 treated as green *)
103
+
| 6 -> Some Green_data
104
+
| 7 -> Some Green_eob
105
+
| 8 -> Some Report
106
+
| 9 -> Some Report_ack
107
+
| 12 -> Some Cancel_from_sender
108
+
| 13 -> Some Cancel_ack_to_sender
109
+
| 14 -> Some Cancel_from_receiver
110
+
| 15 -> Some Cancel_ack_to_receiver
111
+
| _ -> None
112
+
113
+
(* {1 Cancel Reasons} *)
114
+
115
+
type cancel_reason =
116
+
| User_cancelled
117
+
| Unreachable
118
+
| Rlexc
119
+
| Miscolored
120
+
| System_cancelled
121
+
| Rxmtcycexc
122
+
| Reserved of int
123
+
124
+
let pp_cancel_reason fmt = function
125
+
| User_cancelled -> Format.fprintf fmt "User_cancelled"
126
+
| Unreachable -> Format.fprintf fmt "Unreachable"
127
+
| Rlexc -> Format.fprintf fmt "Rlexc"
128
+
| Miscolored -> Format.fprintf fmt "Miscolored"
129
+
| System_cancelled -> Format.fprintf fmt "System_cancelled"
130
+
| Rxmtcycexc -> Format.fprintf fmt "Rxmtcycexc"
131
+
| Reserved n -> Format.fprintf fmt "Reserved(%d)" n
132
+
133
+
let cancel_reason_to_int = function
134
+
| User_cancelled -> 0
135
+
| Unreachable -> 1
136
+
| Rlexc -> 2
137
+
| Miscolored -> 3
138
+
| System_cancelled -> 4
139
+
| Rxmtcycexc -> 5
140
+
| Reserved n -> n
141
+
142
+
let cancel_reason_of_int = function
143
+
| 0 -> User_cancelled
144
+
| 1 -> Unreachable
145
+
| 2 -> Rlexc
146
+
| 3 -> Miscolored
147
+
| 4 -> System_cancelled
148
+
| 5 -> Rxmtcycexc
149
+
| n -> Reserved n
150
+
151
+
(* {1 Extensions} *)
152
+
153
+
type extension_tag = Auth | Cookie | Unknown of int
154
+
155
+
type extension = { tag : extension_tag; value : string }
156
+
157
+
let pp_extension fmt ext =
158
+
let tag_str =
159
+
match ext.tag with
160
+
| Auth -> "Auth"
161
+
| Cookie -> "Cookie"
162
+
| Unknown n -> Format.sprintf "Unknown(%d)" n
163
+
in
164
+
Format.fprintf fmt "%s(%d bytes)" tag_str (String.length ext.value)
165
+
166
+
let extension_tag_to_int = function
167
+
| Auth -> 0x00
168
+
| Cookie -> 0x01
169
+
| Unknown n -> n
170
+
171
+
let extension_tag_of_int = function
172
+
| 0x00 -> Auth
173
+
| 0x01 -> Cookie
174
+
| n -> Unknown n
175
+
176
+
(* {1 Reception Claims} *)
177
+
178
+
type reception_claim = { offset : int64; length : int64 }
179
+
180
+
let pp_reception_claim fmt c =
181
+
Format.fprintf fmt "[%Ld+%Ld]" c.offset c.length
182
+
183
+
(* {1 Segment Content} *)
184
+
185
+
type data_segment = {
186
+
client_service_id : int64;
187
+
block_offset : int64;
188
+
data : string;
189
+
checkpoint_serial : int64 option;
190
+
report_serial : int64 option;
191
+
}
192
+
193
+
type report_segment = {
194
+
report_serial : int64;
195
+
checkpoint_serial : int64;
196
+
upper_bound : int64;
197
+
lower_bound : int64;
198
+
claims : reception_claim list;
199
+
}
200
+
201
+
type cancel_segment = { reason : cancel_reason }
202
+
type report_ack = { report_serial : int64 }
203
+
type cancel_ack = unit
204
+
205
+
type segment_content =
206
+
| Data of data_segment
207
+
| Report of report_segment
208
+
| Report_ack of report_ack
209
+
| Cancel of cancel_segment
210
+
| Cancel_ack of cancel_ack
211
+
212
+
type segment = {
213
+
session_id : session_id;
214
+
segment_type : segment_type;
215
+
header_extensions : extension list;
216
+
trailer_extensions : extension list;
217
+
content : segment_content;
218
+
}
219
+
220
+
let pp_segment fmt seg =
221
+
Format.fprintf fmt "@[<v 2>LTP segment {@ session=%a@ type=%a@ content=%s@ }@]"
222
+
pp_session_id seg.session_id pp_segment_type seg.segment_type
223
+
(match seg.content with
224
+
| Data d -> Format.sprintf "Data(%Ld bytes at %Ld)" (Int64.of_int (String.length d.data)) d.block_offset
225
+
| Report r -> Format.sprintf "Report(serial=%Ld, %d claims)" r.report_serial (List.length r.claims)
226
+
| Report_ack r -> Format.sprintf "Report_ack(%Ld)" r.report_serial
227
+
| Cancel c -> Format.asprintf "Cancel(%a)" pp_cancel_reason c.reason
228
+
| Cancel_ack () -> "Cancel_ack")
229
+
230
+
(* {1 Errors} *)
231
+
232
+
type error =
233
+
| Truncated of { expected : int; got : int }
234
+
| Invalid_version of int
235
+
| Invalid_segment_type of int
236
+
| Invalid_sdnv
237
+
| Extension_error of string
238
+
| Content_error of string
239
+
240
+
let pp_error fmt = function
241
+
| Truncated { expected; got } ->
242
+
Format.fprintf fmt "truncated: expected %d bytes, got %d" expected got
243
+
| Invalid_version v -> Format.fprintf fmt "invalid version: %d" v
244
+
| Invalid_segment_type t -> Format.fprintf fmt "invalid segment type: %d" t
245
+
| Invalid_sdnv -> Format.fprintf fmt "invalid SDNV"
246
+
| Extension_error msg -> Format.fprintf fmt "extension error: %s" msg
247
+
| Content_error msg -> Format.fprintf fmt "content error: %s" msg
248
+
249
+
(* {1 Encoding} *)
250
+
251
+
let encode_extension ext =
252
+
let tag = Char.chr (extension_tag_to_int ext.tag) in
253
+
let len_sdnv = encode_sdnv (Int64.of_int (String.length ext.value)) in
254
+
String.make 1 tag ^ len_sdnv ^ ext.value
255
+
256
+
let encode_extensions exts =
257
+
String.concat "" (List.map encode_extension exts)
258
+
259
+
let encode_data_segment seg_type ds =
260
+
let buf = Buffer.create 64 in
261
+
Buffer.add_string buf (encode_sdnv ds.client_service_id);
262
+
Buffer.add_string buf (encode_sdnv ds.block_offset);
263
+
Buffer.add_string buf (encode_sdnv (Int64.of_int (String.length ds.data)));
264
+
(* Add checkpoint/report serial if this is a checkpoint *)
265
+
(match (seg_type, ds.checkpoint_serial, ds.report_serial) with
266
+
| (Red_checkpoint | Red_checkpoint_eorp | Red_checkpoint_eorp_eob), Some cp, Some rp ->
267
+
Buffer.add_string buf (encode_sdnv cp);
268
+
Buffer.add_string buf (encode_sdnv rp)
269
+
| _ -> ());
270
+
Buffer.add_string buf ds.data;
271
+
Buffer.contents buf
272
+
273
+
let encode_report_segment (rs : report_segment) =
274
+
let buf = Buffer.create 64 in
275
+
Buffer.add_string buf (encode_sdnv rs.report_serial);
276
+
Buffer.add_string buf (encode_sdnv rs.checkpoint_serial);
277
+
Buffer.add_string buf (encode_sdnv rs.upper_bound);
278
+
Buffer.add_string buf (encode_sdnv rs.lower_bound);
279
+
Buffer.add_string buf (encode_sdnv (Int64.of_int (List.length rs.claims)));
280
+
List.iter
281
+
(fun c ->
282
+
Buffer.add_string buf (encode_sdnv c.offset);
283
+
Buffer.add_string buf (encode_sdnv c.length))
284
+
rs.claims;
285
+
Buffer.contents buf
286
+
287
+
let encode_segment seg =
288
+
let buf = Buffer.create 128 in
289
+
(* Control byte: version (4 bits) + type flags (4 bits) *)
290
+
let type_code = segment_type_to_int seg.segment_type in
291
+
let control_byte = type_code in (* version 0 *)
292
+
Buffer.add_char buf (Char.chr control_byte);
293
+
(* Session ID *)
294
+
Buffer.add_string buf (encode_sdnv seg.session_id.originator);
295
+
Buffer.add_string buf (encode_sdnv seg.session_id.number);
296
+
(* Extension counts *)
297
+
let hdr_count = List.length seg.header_extensions land 0x0F in
298
+
let trl_count = List.length seg.trailer_extensions land 0x0F in
299
+
Buffer.add_char buf (Char.chr ((hdr_count lsl 4) lor trl_count));
300
+
(* Header extensions *)
301
+
Buffer.add_string buf (encode_extensions seg.header_extensions);
302
+
(* Content *)
303
+
(match seg.content with
304
+
| Data ds -> Buffer.add_string buf (encode_data_segment seg.segment_type ds)
305
+
| Report rs -> Buffer.add_string buf (encode_report_segment rs)
306
+
| Report_ack ra -> Buffer.add_string buf (encode_sdnv ra.report_serial)
307
+
| Cancel cs -> Buffer.add_char buf (Char.chr (cancel_reason_to_int cs.reason))
308
+
| Cancel_ack () -> ());
309
+
(* Trailer extensions *)
310
+
Buffer.add_string buf (encode_extensions seg.trailer_extensions);
311
+
Buffer.contents buf
312
+
313
+
(* {1 Decoding} *)
314
+
315
+
let ( let* ) = Result.bind
316
+
317
+
let decode_extensions buf off count =
318
+
let rec loop acc off remaining =
319
+
if remaining = 0 then Ok (List.rev acc, off)
320
+
else if off >= String.length buf then Error (Extension_error "truncated")
321
+
else
322
+
let tag = extension_tag_of_int (Char.code (String.get buf off)) in
323
+
let* len, off = decode_sdnv buf (off + 1) |> Result.map_error (fun _ -> Invalid_sdnv) in
324
+
let len = Int64.to_int len in
325
+
if off + len > String.length buf then Error (Extension_error "truncated value")
326
+
else
327
+
let value = String.sub buf off len in
328
+
loop ({ tag; value } :: acc) (off + len) (remaining - 1)
329
+
in
330
+
loop [] off count
331
+
332
+
let is_checkpoint_type = function
333
+
| Red_checkpoint | Red_checkpoint_eorp | Red_checkpoint_eorp_eob -> true
334
+
| _ -> false
335
+
336
+
let decode_data_segment buf off seg_type =
337
+
let* client_service_id, off =
338
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
339
+
in
340
+
let* block_offset, off =
341
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
342
+
in
343
+
let* data_len, off =
344
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
345
+
in
346
+
let* checkpoint_serial, report_serial, off =
347
+
if is_checkpoint_type seg_type then
348
+
let* cp, off = decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv) in
349
+
let* rp, off = decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv) in
350
+
Ok (Some cp, Some rp, off)
351
+
else Ok (None, None, off)
352
+
in
353
+
let data_len = Int64.to_int data_len in
354
+
if off + data_len > String.length buf then
355
+
Error (Truncated { expected = off + data_len; got = String.length buf })
356
+
else
357
+
let data = String.sub buf off data_len in
358
+
Ok
359
+
( Data { client_service_id; block_offset; data; checkpoint_serial; report_serial },
360
+
off + data_len )
361
+
362
+
let decode_report_segment buf off =
363
+
let* report_serial, off =
364
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
365
+
in
366
+
let* checkpoint_serial, off =
367
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
368
+
in
369
+
let* upper_bound, off =
370
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
371
+
in
372
+
let* lower_bound, off =
373
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
374
+
in
375
+
let* claim_count, off =
376
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
377
+
in
378
+
let rec decode_claims acc off remaining =
379
+
if remaining = 0L then Ok (List.rev acc, off)
380
+
else
381
+
let* claim_offset, off =
382
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
383
+
in
384
+
let* claim_length, off =
385
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
386
+
in
387
+
decode_claims ({ offset = claim_offset; length = claim_length } :: acc) off
388
+
(Int64.sub remaining 1L)
389
+
in
390
+
let* claims, off = decode_claims [] off claim_count in
391
+
Ok
392
+
( Report { report_serial; checkpoint_serial; upper_bound; lower_bound; claims },
393
+
off )
394
+
395
+
let decode_segment buf =
396
+
let len = String.length buf in
397
+
if len < 3 then Error (Truncated { expected = 3; got = len })
398
+
else
399
+
let control = Char.code (String.get buf 0) in
400
+
let version = (control lsr 4) land 0x0F in
401
+
if version <> 0 then Error (Invalid_version version)
402
+
else
403
+
let type_code = control land 0x0F in
404
+
match segment_type_of_int type_code with
405
+
| None -> Error (Invalid_segment_type type_code)
406
+
| Some segment_type ->
407
+
let* originator, off =
408
+
decode_sdnv buf 1 |> Result.map_error (fun _ -> Invalid_sdnv)
409
+
in
410
+
let* number, off =
411
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
412
+
in
413
+
let session_id = { originator; number } in
414
+
if off >= len then Error (Truncated { expected = off + 1; got = len })
415
+
else
416
+
let ext_byte = Char.code (String.get buf off) in
417
+
let hdr_count = (ext_byte lsr 4) land 0x0F in
418
+
let trl_count = ext_byte land 0x0F in
419
+
let off = off + 1 in
420
+
let* header_extensions, off = decode_extensions buf off hdr_count in
421
+
let* content, off =
422
+
match segment_type with
423
+
| Red_data | Red_checkpoint | Red_checkpoint_eorp
424
+
| Red_checkpoint_eorp_eob | Green_data | Green_eob ->
425
+
decode_data_segment buf off segment_type
426
+
| Report -> decode_report_segment buf off
427
+
| Report_ack ->
428
+
let* serial, off =
429
+
decode_sdnv buf off |> Result.map_error (fun _ -> Invalid_sdnv)
430
+
in
431
+
Ok (Report_ack { report_serial = serial }, off)
432
+
| Cancel_from_sender | Cancel_from_receiver ->
433
+
if off >= len then Error (Content_error "missing cancel reason")
434
+
else
435
+
let reason = cancel_reason_of_int (Char.code (String.get buf off)) in
436
+
Ok (Cancel { reason }, off + 1)
437
+
| Cancel_ack_to_sender | Cancel_ack_to_receiver ->
438
+
Ok (Cancel_ack (), off)
439
+
in
440
+
let* trailer_extensions, _off = decode_extensions buf off trl_count in
441
+
Ok
442
+
{
443
+
session_id;
444
+
segment_type;
445
+
header_extensions;
446
+
trailer_extensions;
447
+
content;
448
+
}
449
+
450
+
(* {1 Segment Constructors} *)
451
+
452
+
let make_data_segment ~session_id ~client_service_id ~block_offset ?checkpoint_serial
453
+
?report_serial ?(is_eorp = false) ?(is_eob = false) data =
454
+
let segment_type =
455
+
match checkpoint_serial with
456
+
| None -> if is_eob then Green_eob else Green_data
457
+
| Some _ ->
458
+
if is_eorp && is_eob then Red_checkpoint_eorp_eob
459
+
else if is_eorp then Red_checkpoint_eorp
460
+
else Red_checkpoint
461
+
in
462
+
{
463
+
session_id;
464
+
segment_type;
465
+
header_extensions = [];
466
+
trailer_extensions = [];
467
+
content =
468
+
Data { client_service_id; block_offset; data; checkpoint_serial; report_serial };
469
+
}
470
+
471
+
let make_report_segment ~session_id ~report_serial ~checkpoint_serial ~upper_bound
472
+
?(lower_bound = 0L) claims =
473
+
{
474
+
session_id;
475
+
segment_type = Report;
476
+
header_extensions = [];
477
+
trailer_extensions = [];
478
+
content =
479
+
Report { report_serial; checkpoint_serial; upper_bound; lower_bound; claims };
480
+
}
481
+
482
+
let make_report_ack ~session_id ~report_serial =
483
+
{
484
+
session_id;
485
+
segment_type = Report_ack;
486
+
header_extensions = [];
487
+
trailer_extensions = [];
488
+
content = Report_ack { report_serial };
489
+
}
490
+
491
+
let make_cancel ~session_id ~from_sender reason =
492
+
{
493
+
session_id;
494
+
segment_type = (if from_sender then Cancel_from_sender else Cancel_from_receiver);
495
+
header_extensions = [];
496
+
trailer_extensions = [];
497
+
content = Cancel { reason };
498
+
}
499
+
500
+
let make_cancel_ack ~session_id ~to_sender =
501
+
{
502
+
session_id;
503
+
segment_type = (if to_sender then Cancel_ack_to_sender else Cancel_ack_to_receiver);
504
+
header_extensions = [];
505
+
trailer_extensions = [];
506
+
content = Cancel_ack ();
507
+
}
508
+
509
+
(* {1 Predicates} *)
510
+
511
+
let is_data_segment seg =
512
+
match seg.segment_type with
513
+
| Red_data | Red_checkpoint | Red_checkpoint_eorp | Red_checkpoint_eorp_eob
514
+
| Green_data | Green_eob ->
515
+
true
516
+
| _ -> false
517
+
518
+
let is_red_segment seg =
519
+
match seg.segment_type with
520
+
| Red_data | Red_checkpoint | Red_checkpoint_eorp | Red_checkpoint_eorp_eob -> true
521
+
| _ -> false
522
+
523
+
let is_green_segment seg =
524
+
match seg.segment_type with Green_data | Green_eob -> true | _ -> false
525
+
526
+
let is_checkpoint seg =
527
+
match seg.segment_type with
528
+
| Red_checkpoint | Red_checkpoint_eorp | Red_checkpoint_eorp_eob -> true
529
+
| _ -> false
530
+
531
+
let is_eorp seg =
532
+
match seg.segment_type with
533
+
| Red_checkpoint_eorp | Red_checkpoint_eorp_eob -> true
534
+
| _ -> false
535
+
536
+
let is_eob seg =
537
+
match seg.segment_type with
538
+
| Red_checkpoint_eorp_eob | Green_eob -> true
539
+
| _ -> false
+255
lib/ltp.mli
+255
lib/ltp.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Licklider Transmission Protocol (RFC 5326).
7
+
8
+
LTP is a reliable data delivery protocol designed for high-delay and
9
+
disruption-prone links such as deep-space communications.
10
+
11
+
{b Data segments}
12
+
13
+
LTP transmits blocks of data as sequences of segments. Segments are
14
+
classified as:
15
+
- {b Red segments} - require acknowledgment and retransmission
16
+
- {b Green segments} - best-effort delivery without acknowledgment
17
+
18
+
{b Control segments}
19
+
20
+
Control segments manage reliability:
21
+
- {b Report segments} - acknowledge received data ranges
22
+
- {b Report-ack segments} - acknowledge reception reports
23
+
- {b Cancel segments} - abort transmission
24
+
25
+
{b Sessions}
26
+
27
+
Each transmission is identified by a session ID comprising the sender's
28
+
engine ID and a session number.
29
+
30
+
{b References}
31
+
- {{:https://datatracker.ietf.org/doc/html/rfc5326}RFC 5326} - Licklider
32
+
Transmission Protocol - Specification *)
33
+
34
+
(** {1 SDNV Encoding}
35
+
36
+
Self-Delimiting Numeric Values provide variable-length integer encoding
37
+
where MSB=1 indicates continuation. *)
38
+
39
+
val encode_sdnv : int64 -> string
40
+
(** [encode_sdnv n] encodes [n] as an SDNV. *)
41
+
42
+
val decode_sdnv : string -> int -> (int64 * int, string) result
43
+
(** [decode_sdnv buf off] decodes an SDNV from [buf] starting at [off].
44
+
Returns [(value, new_offset)] on success. *)
45
+
46
+
(** {1 Engine and Session IDs} *)
47
+
48
+
type engine_id = int64
49
+
(** LTP engine identifier. *)
50
+
51
+
type session_number = int64
52
+
(** Session number within an engine. *)
53
+
54
+
type session_id = { originator : engine_id; number : session_number }
55
+
(** Session identifier (RFC 5326 Section 3.1.1). *)
56
+
57
+
val pp_session_id : session_id Fmt.t
58
+
59
+
(** {1 Segment Types} *)
60
+
61
+
type segment_type =
62
+
| Red_data
63
+
(** Type 0: Red data segment, no checkpoint. *)
64
+
| Red_checkpoint
65
+
(** Type 1: Red data checkpoint. *)
66
+
| Red_checkpoint_eorp
67
+
(** Type 2: Red data checkpoint at end of red-part. *)
68
+
| Red_checkpoint_eorp_eob
69
+
(** Type 3: Red data checkpoint at end of red-part and block. *)
70
+
| Green_data
71
+
(** Type 4: Green data segment. *)
72
+
| Green_eob
73
+
(** Type 7: Green data segment at end of block. *)
74
+
| Report
75
+
(** Type 8: Report segment. *)
76
+
| Report_ack
77
+
(** Type 9: Report acknowledgment. *)
78
+
| Cancel_from_sender
79
+
(** Type 12: Session canceled by sender. *)
80
+
| Cancel_ack_to_sender
81
+
(** Type 13: Cancel acknowledgment (to sender). *)
82
+
| Cancel_from_receiver
83
+
(** Type 14: Session canceled by receiver. *)
84
+
| Cancel_ack_to_receiver
85
+
(** Type 15: Cancel acknowledgment (to receiver). *)
86
+
87
+
val pp_segment_type : segment_type Fmt.t
88
+
val segment_type_to_int : segment_type -> int
89
+
val segment_type_of_int : int -> segment_type option
90
+
91
+
(** {1 Cancel Reasons} *)
92
+
93
+
type cancel_reason =
94
+
| User_cancelled
95
+
(** 0x00: Client service canceled session. *)
96
+
| Unreachable
97
+
(** 0x01: Unreachable client service. *)
98
+
| Rlexc
99
+
(** 0x02: Retransmission limit exceeded. *)
100
+
| Miscolored
101
+
(** 0x03: Received miscolored segment. *)
102
+
| System_cancelled
103
+
(** 0x04: System error. *)
104
+
| Rxmtcycexc
105
+
(** 0x05: Exceeded retransmission cycles limit. *)
106
+
| Reserved of int
107
+
(** Reserved reason code. *)
108
+
109
+
val pp_cancel_reason : cancel_reason Fmt.t
110
+
val cancel_reason_to_int : cancel_reason -> int
111
+
val cancel_reason_of_int : int -> cancel_reason
112
+
113
+
(** {1 Extensions} *)
114
+
115
+
type extension_tag =
116
+
| Auth
117
+
(** 0x00: LTP authentication extension. *)
118
+
| Cookie
119
+
(** 0x01: LTP cookie extension. *)
120
+
| Unknown of int
121
+
(** Unknown or private extension tag. *)
122
+
123
+
type extension = { tag : extension_tag; value : string }
124
+
(** Extension TLV (RFC 5326 Section 3.3). *)
125
+
126
+
val pp_extension : extension Fmt.t
127
+
128
+
(** {1 Reception Claims} *)
129
+
130
+
type reception_claim = { offset : int64; length : int64 }
131
+
(** A range of successfully received data (RFC 5326 Section 3.2.4). *)
132
+
133
+
val pp_reception_claim : reception_claim Fmt.t
134
+
135
+
(** {1 Segment Content} *)
136
+
137
+
type data_segment = {
138
+
client_service_id : int64;
139
+
(** Identifies the destination service. *)
140
+
block_offset : int64;
141
+
(** Position within the transmitted block. *)
142
+
data : string;
143
+
(** Payload data. *)
144
+
checkpoint_serial : int64 option;
145
+
(** Present if segment is a checkpoint. *)
146
+
report_serial : int64 option;
147
+
(** Present if checkpoint; 0 if asynchronous. *)
148
+
}
149
+
(** Data segment content (RFC 5326 Section 3.2.1). *)
150
+
151
+
type report_segment = {
152
+
report_serial : int64;
153
+
(** Report serial number. *)
154
+
checkpoint_serial : int64;
155
+
(** Checkpoint being acknowledged (0 if async). *)
156
+
upper_bound : int64;
157
+
(** Block prefix size to which claims apply. *)
158
+
lower_bound : int64;
159
+
(** Interior prefix not covered by claims. *)
160
+
claims : reception_claim list;
161
+
(** Successfully received data ranges. *)
162
+
}
163
+
(** Report segment content (RFC 5326 Section 3.2.4). *)
164
+
165
+
type cancel_segment = { reason : cancel_reason }
166
+
(** Cancel segment content. *)
167
+
168
+
type report_ack = { report_serial : int64 }
169
+
(** Report acknowledgment content. *)
170
+
171
+
type cancel_ack = unit
172
+
(** Cancel acknowledgment (no additional content). *)
173
+
174
+
(** {1 LTP Segment} *)
175
+
176
+
type segment_content =
177
+
| Data of data_segment
178
+
| Report of report_segment
179
+
| Report_ack of report_ack
180
+
| Cancel of cancel_segment
181
+
| Cancel_ack of cancel_ack
182
+
183
+
type segment = {
184
+
session_id : session_id;
185
+
segment_type : segment_type;
186
+
header_extensions : extension list;
187
+
trailer_extensions : extension list;
188
+
content : segment_content;
189
+
}
190
+
(** Complete LTP segment (RFC 5326 Section 3). *)
191
+
192
+
val pp_segment : segment Fmt.t
193
+
194
+
(** {1 Encoding/Decoding} *)
195
+
196
+
type error =
197
+
| Truncated of { expected : int; got : int }
198
+
| Invalid_version of int
199
+
| Invalid_segment_type of int
200
+
| Invalid_sdnv
201
+
| Extension_error of string
202
+
| Content_error of string
203
+
204
+
val pp_error : error Fmt.t
205
+
206
+
val encode_segment : segment -> string
207
+
(** [encode_segment seg] serializes a segment to wire format. *)
208
+
209
+
val decode_segment : string -> (segment, error) result
210
+
(** [decode_segment buf] parses a segment from wire format. *)
211
+
212
+
(** {1 Segment Constructors} *)
213
+
214
+
val make_data_segment :
215
+
session_id:session_id ->
216
+
client_service_id:int64 ->
217
+
block_offset:int64 ->
218
+
?checkpoint_serial:int64 ->
219
+
?report_serial:int64 ->
220
+
?is_eorp:bool ->
221
+
?is_eob:bool ->
222
+
string ->
223
+
segment
224
+
(** [make_data_segment ~session_id ~client_service_id ~block_offset data]
225
+
creates a data segment. Red segments have [checkpoint_serial] set. *)
226
+
227
+
val make_report_segment :
228
+
session_id:session_id ->
229
+
report_serial:int64 ->
230
+
checkpoint_serial:int64 ->
231
+
upper_bound:int64 ->
232
+
?lower_bound:int64 ->
233
+
reception_claim list ->
234
+
segment
235
+
(** [make_report_segment ~session_id ~report_serial ~checkpoint_serial
236
+
~upper_bound claims] creates a report segment. *)
237
+
238
+
val make_report_ack :
239
+
session_id:session_id -> report_serial:int64 -> segment
240
+
(** [make_report_ack ~session_id ~report_serial] acknowledges a report. *)
241
+
242
+
val make_cancel : session_id:session_id -> from_sender:bool -> cancel_reason -> segment
243
+
(** [make_cancel ~session_id ~from_sender reason] creates a cancel segment. *)
244
+
245
+
val make_cancel_ack : session_id:session_id -> to_sender:bool -> segment
246
+
(** [make_cancel_ack ~session_id ~to_sender] acknowledges a cancel. *)
247
+
248
+
(** {1 Predicates} *)
249
+
250
+
val is_data_segment : segment -> bool
251
+
val is_red_segment : segment -> bool
252
+
val is_green_segment : segment -> bool
253
+
val is_checkpoint : segment -> bool
254
+
val is_eorp : segment -> bool
255
+
val is_eob : segment -> bool
+34
ltp.opam
+34
ltp.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Licklider Transmission Protocol (RFC 5326)"
4
+
description: """
5
+
LTP is a reliable data delivery protocol designed for high-delay and
6
+
disruption-prone communication links, such as deep-space communications.
7
+
It provides selective acknowledgment and retransmission with support for
8
+
both reliable (red) and unreliable (green) data segments."""
9
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
10
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
11
+
license: "ISC"
12
+
depends: [
13
+
"dune" {>= "3.0"}
14
+
"ocaml" {>= "4.14"}
15
+
"fmt" {>= "0.9"}
16
+
"alcotest" {with-test}
17
+
"crowbar" {with-test}
18
+
"odoc" {with-doc}
19
+
]
20
+
build: [
21
+
["dune" "subst"] {dev}
22
+
[
23
+
"dune"
24
+
"build"
25
+
"-p"
26
+
name
27
+
"-j"
28
+
jobs
29
+
"@install"
30
+
"@runtest" {with-test}
31
+
"@doc" {with-doc}
32
+
]
33
+
]
34
+
dev-repo: "https://tangled.org/gazagnaire.org/ocaml-ltp"
+201
test/test.ml
+201
test/test.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for LTP (Licklider Transmission Protocol). *)
7
+
8
+
let session_id = Ltp.{ originator = 1L; number = 100L }
9
+
10
+
(* {1 SDNV Tests} *)
11
+
12
+
let test_sdnv_zero () =
13
+
let encoded = Ltp.encode_sdnv 0L in
14
+
Alcotest.(check string) "zero" "\x00" encoded;
15
+
match Ltp.decode_sdnv encoded 0 with
16
+
| Ok (v, off) ->
17
+
Alcotest.(check int64) "decoded" 0L v;
18
+
Alcotest.(check int) "offset" 1 off
19
+
| Error e -> Alcotest.fail e
20
+
21
+
let test_sdnv_small () =
22
+
let encoded = Ltp.encode_sdnv 127L in
23
+
Alcotest.(check string) "127" "\x7f" encoded;
24
+
match Ltp.decode_sdnv encoded 0 with
25
+
| Ok (v, _) -> Alcotest.(check int64) "decoded" 127L v
26
+
| Error e -> Alcotest.fail e
27
+
28
+
let test_sdnv_multi_byte () =
29
+
let encoded = Ltp.encode_sdnv 128L in
30
+
Alcotest.(check int) "length" 2 (String.length encoded);
31
+
match Ltp.decode_sdnv encoded 0 with
32
+
| Ok (v, _) -> Alcotest.(check int64) "decoded" 128L v
33
+
| Error e -> Alcotest.fail e
34
+
35
+
let test_sdnv_large () =
36
+
let value = 0x1234567890L in
37
+
let encoded = Ltp.encode_sdnv value in
38
+
match Ltp.decode_sdnv encoded 0 with
39
+
| Ok (v, _) -> Alcotest.(check int64) "decoded" value v
40
+
| Error e -> Alcotest.fail e
41
+
42
+
(* {1 Segment Type Tests} *)
43
+
44
+
let test_segment_type_roundtrip () =
45
+
let types =
46
+
[
47
+
Ltp.Red_data;
48
+
Ltp.Red_checkpoint;
49
+
Ltp.Red_checkpoint_eorp;
50
+
Ltp.Red_checkpoint_eorp_eob;
51
+
Ltp.Green_data;
52
+
Ltp.Green_eob;
53
+
Ltp.Report;
54
+
Ltp.Report_ack;
55
+
Ltp.Cancel_from_sender;
56
+
Ltp.Cancel_ack_to_sender;
57
+
Ltp.Cancel_from_receiver;
58
+
Ltp.Cancel_ack_to_receiver;
59
+
]
60
+
in
61
+
List.iter
62
+
(fun t ->
63
+
let code = Ltp.segment_type_to_int t in
64
+
match Ltp.segment_type_of_int code with
65
+
| Some t' ->
66
+
Alcotest.(check int) (Format.asprintf "%a" Ltp.pp_segment_type t) code
67
+
(Ltp.segment_type_to_int t')
68
+
| None -> Alcotest.fail "roundtrip failed")
69
+
types
70
+
71
+
(* {1 Data Segment Tests} *)
72
+
73
+
let test_green_data_roundtrip () =
74
+
let data = "Hello, LTP!" in
75
+
let seg =
76
+
Ltp.make_data_segment ~session_id ~client_service_id:1L ~block_offset:0L data
77
+
in
78
+
Alcotest.(check bool) "is green" true (Ltp.is_green_segment seg);
79
+
let encoded = Ltp.encode_segment seg in
80
+
match Ltp.decode_segment encoded with
81
+
| Ok decoded ->
82
+
Alcotest.(check bool) "decoded is green" true (Ltp.is_green_segment decoded);
83
+
(match decoded.content with
84
+
| Ltp.Data ds -> Alcotest.(check string) "data" data ds.data
85
+
| _ -> Alcotest.fail "wrong content type")
86
+
| Error e -> Alcotest.failf "decode failed: %a" Ltp.pp_error e
87
+
88
+
let test_red_checkpoint_roundtrip () =
89
+
let data = "Checkpoint data" in
90
+
let seg =
91
+
Ltp.make_data_segment ~session_id ~client_service_id:2L ~block_offset:100L
92
+
~checkpoint_serial:1L ~report_serial:0L ~is_eorp:true ~is_eob:true data
93
+
in
94
+
Alcotest.(check bool) "is red" true (Ltp.is_red_segment seg);
95
+
Alcotest.(check bool) "is checkpoint" true (Ltp.is_checkpoint seg);
96
+
Alcotest.(check bool) "is eorp" true (Ltp.is_eorp seg);
97
+
Alcotest.(check bool) "is eob" true (Ltp.is_eob seg);
98
+
let encoded = Ltp.encode_segment seg in
99
+
match Ltp.decode_segment encoded with
100
+
| Ok decoded ->
101
+
Alcotest.(check bool) "decoded is red" true (Ltp.is_red_segment decoded);
102
+
(match decoded.content with
103
+
| Ltp.Data ds ->
104
+
Alcotest.(check string) "data" data ds.data;
105
+
Alcotest.(check (option int64)) "checkpoint" (Some 1L) ds.checkpoint_serial
106
+
| _ -> Alcotest.fail "wrong content type")
107
+
| Error e -> Alcotest.failf "decode failed: %a" Ltp.pp_error e
108
+
109
+
(* {1 Report Segment Tests} *)
110
+
111
+
let test_report_roundtrip () =
112
+
let claims =
113
+
[ Ltp.{ offset = 0L; length = 100L }; Ltp.{ offset = 200L; length = 50L } ]
114
+
in
115
+
let seg =
116
+
Ltp.make_report_segment ~session_id ~report_serial:5L ~checkpoint_serial:1L
117
+
~upper_bound:300L ~lower_bound:0L claims
118
+
in
119
+
let encoded = Ltp.encode_segment seg in
120
+
match Ltp.decode_segment encoded with
121
+
| Ok decoded -> (
122
+
match decoded.content with
123
+
| Ltp.Report rs ->
124
+
Alcotest.(check int64) "report serial" 5L rs.report_serial;
125
+
Alcotest.(check int64) "checkpoint serial" 1L rs.checkpoint_serial;
126
+
Alcotest.(check int64) "upper bound" 300L rs.upper_bound;
127
+
Alcotest.(check int) "claims count" 2 (List.length rs.claims)
128
+
| _ -> Alcotest.fail "wrong content type")
129
+
| Error e -> Alcotest.failf "decode failed: %a" Ltp.pp_error e
130
+
131
+
(* {1 Report Ack Tests} *)
132
+
133
+
let test_report_ack_roundtrip () =
134
+
let seg = Ltp.make_report_ack ~session_id ~report_serial:42L in
135
+
let encoded = Ltp.encode_segment seg in
136
+
match Ltp.decode_segment encoded with
137
+
| Ok decoded -> (
138
+
match decoded.content with
139
+
| Ltp.Report_ack ra -> Alcotest.(check int64) "serial" 42L ra.report_serial
140
+
| _ -> Alcotest.fail "wrong content type")
141
+
| Error e -> Alcotest.failf "decode failed: %a" Ltp.pp_error e
142
+
143
+
(* {1 Cancel Tests} *)
144
+
145
+
let test_cancel_roundtrip () =
146
+
let seg = Ltp.make_cancel ~session_id ~from_sender:true Ltp.Rlexc in
147
+
Alcotest.(check bool)
148
+
"is cancel from sender" true
149
+
(seg.segment_type = Ltp.Cancel_from_sender);
150
+
let encoded = Ltp.encode_segment seg in
151
+
match Ltp.decode_segment encoded with
152
+
| Ok decoded -> (
153
+
match decoded.content with
154
+
| Ltp.Cancel cs ->
155
+
Alcotest.(check int) "reason" 2 (Ltp.cancel_reason_to_int cs.reason)
156
+
| _ -> Alcotest.fail "wrong content type")
157
+
| Error e -> Alcotest.failf "decode failed: %a" Ltp.pp_error e
158
+
159
+
let test_cancel_ack_roundtrip () =
160
+
let seg = Ltp.make_cancel_ack ~session_id ~to_sender:false in
161
+
Alcotest.(check bool)
162
+
"is cancel ack to receiver" true
163
+
(seg.segment_type = Ltp.Cancel_ack_to_receiver);
164
+
let encoded = Ltp.encode_segment seg in
165
+
match Ltp.decode_segment encoded with
166
+
| Ok decoded -> (
167
+
match decoded.content with
168
+
| Ltp.Cancel_ack () -> ()
169
+
| _ -> Alcotest.fail "wrong content type")
170
+
| Error e -> Alcotest.failf "decode failed: %a" Ltp.pp_error e
171
+
172
+
(* {1 Test Suites} *)
173
+
174
+
let () =
175
+
Alcotest.run "ltp"
176
+
[
177
+
( "SDNV",
178
+
[
179
+
Alcotest.test_case "zero" `Quick test_sdnv_zero;
180
+
Alcotest.test_case "small" `Quick test_sdnv_small;
181
+
Alcotest.test_case "multi-byte" `Quick test_sdnv_multi_byte;
182
+
Alcotest.test_case "large" `Quick test_sdnv_large;
183
+
] );
184
+
( "segment_type",
185
+
[ Alcotest.test_case "roundtrip" `Quick test_segment_type_roundtrip ] );
186
+
( "data",
187
+
[
188
+
Alcotest.test_case "green roundtrip" `Quick test_green_data_roundtrip;
189
+
Alcotest.test_case "red checkpoint roundtrip" `Quick
190
+
test_red_checkpoint_roundtrip;
191
+
] );
192
+
( "report",
193
+
[ Alcotest.test_case "roundtrip" `Quick test_report_roundtrip ] );
194
+
( "report_ack",
195
+
[ Alcotest.test_case "roundtrip" `Quick test_report_ack_roundtrip ] );
196
+
( "cancel",
197
+
[
198
+
Alcotest.test_case "roundtrip" `Quick test_cancel_roundtrip;
199
+
Alcotest.test_case "ack roundtrip" `Quick test_cancel_ack_roundtrip;
200
+
] );
201
+
]