CCSDS File Delivery Protocol (CCSDS 727.0-B-5) for space file transfer
Squashed 'ocaml-cfdp/' content from commit 6d4d5c98 git-subtree-split: 6d4d5c987a83ace732046d52585550eb3f4f75c5
+3747
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version = 0.27.0
+13
LICENSE.md
+13
LICENSE.md
···
1
+
Copyright (c) 2025 Thomas Gazagnaire
2
+
3
+
Permission to use, copy, modify, and/or distribute this software for any
4
+
purpose with or without fee is hereby granted, provided that the above
5
+
copyright notice and this permission notice appear in all copies.
6
+
7
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+32
cfdp.opam
+32
cfdp.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "CCSDS File Delivery Protocol (CCSDS 727.0-B-5)"
4
+
description:
5
+
"Pure OCaml implementation of CFDP for reliable file transfer in space communications. Supports Class 1 (unacknowledged) and Class 2 (acknowledged) transfers with NAK-based retransmission."
6
+
maintainer: ["Thomas Gazagnaire"]
7
+
authors: ["Thomas Gazagnaire"]
8
+
license: "ISC"
9
+
depends: [
10
+
"dune" {>= "3.0"}
11
+
"ocaml" {>= "5.1"}
12
+
"checkseum" {>= "0.5"}
13
+
"fmt" {>= "0.9"}
14
+
"alcotest" {with-test & >= "1.7"}
15
+
"crowbar" {with-test & >= "0.2"}
16
+
"odoc" {with-doc}
17
+
]
18
+
build: [
19
+
["dune" "subst"] {dev}
20
+
[
21
+
"dune"
22
+
"build"
23
+
"-p"
24
+
name
25
+
"-j"
26
+
jobs
27
+
"@install"
28
+
"@runtest" {with-test}
29
+
"@doc" {with-doc}
30
+
]
31
+
]
32
+
dev-repo: "https://tangled.org/samoht.github.io/ocaml-cfdp"
+26
dune-project
+26
dune-project
···
1
+
(lang dune 3.0)
2
+
3
+
(name cfdp)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(source
8
+
(uri https://tangled.org/samoht.github.io/ocaml-cfdp))
9
+
10
+
(authors "Thomas Gazagnaire")
11
+
12
+
(maintainers "Thomas Gazagnaire")
13
+
14
+
(license ISC)
15
+
16
+
(package
17
+
(name cfdp)
18
+
(synopsis "CCSDS File Delivery Protocol (CCSDS 727.0-B-5)")
19
+
(description
20
+
"Pure OCaml implementation of CFDP for reliable file transfer in space communications. Supports Class 1 (unacknowledged) and Class 2 (acknowledged) transfers with NAK-based retransmission.")
21
+
(depends
22
+
(ocaml (>= 5.1))
23
+
(checkseum (>= 0.5))
24
+
(fmt (>= 0.9))
25
+
(alcotest (and :with-test (>= 1.7)))
26
+
(crowbar (and :with-test (>= 0.2)))))
+288
fuzz/fuzz_cfdp.ml
+288
fuzz/fuzz_cfdp.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Fuzz tests for CFDP (CCSDS 727.0-B-5). *)
7
+
8
+
open Crowbar
9
+
10
+
let small_bytes = map [ bytes ] (fun s -> Bytes.of_string s)
11
+
12
+
(* {1 Checksum Computation} *)
13
+
14
+
let () =
15
+
add_test ~name:"cfdp: checksum_modular no crash" [ small_bytes ] @@ fun data ->
16
+
let _ = Cfdp.compute_checksum Cfdp.Checksum_modular data in
17
+
check true
18
+
19
+
let () =
20
+
add_test ~name:"cfdp: checksum_crc32 no crash" [ small_bytes ] @@ fun data ->
21
+
let _ = Cfdp.compute_checksum Cfdp.Checksum_crc32 data in
22
+
check true
23
+
24
+
let () =
25
+
add_test ~name:"cfdp: checksum_crc32c no crash" [ small_bytes ] @@ fun data ->
26
+
let _ = Cfdp.compute_checksum Cfdp.Checksum_crc32c data in
27
+
check true
28
+
29
+
let () =
30
+
add_test ~name:"cfdp: checksum_null zero" [ small_bytes ] @@ fun data ->
31
+
let csum = Cfdp.compute_checksum Cfdp.Checksum_null data in
32
+
if csum <> 0l then fail "null checksum not zero" else check true
33
+
34
+
let () =
35
+
add_test ~name:"cfdp: checksum deterministic" [ uint8; bytes ]
36
+
@@ fun typ_byte buf ->
37
+
let data = Bytes.of_string buf in
38
+
let typ =
39
+
match typ_byte mod 4 with
40
+
| 0 -> Cfdp.Checksum_modular
41
+
| 1 -> Cfdp.Checksum_crc32
42
+
| 2 -> Cfdp.Checksum_crc32c
43
+
| _ -> Cfdp.Checksum_null
44
+
in
45
+
let c1 = Cfdp.compute_checksum typ data in
46
+
let c2 = Cfdp.compute_checksum typ data in
47
+
if c1 <> c2 then fail "checksum not deterministic" else check true
48
+
49
+
let () =
50
+
add_test ~name:"cfdp: verify_checksum consistency" [ uint8; bytes ]
51
+
@@ fun typ_byte buf ->
52
+
let data = Bytes.of_string buf in
53
+
let typ =
54
+
match typ_byte mod 4 with
55
+
| 0 -> Cfdp.Checksum_modular
56
+
| 1 -> Cfdp.Checksum_crc32
57
+
| 2 -> Cfdp.Checksum_crc32c
58
+
| _ -> Cfdp.Checksum_null
59
+
in
60
+
let computed = Cfdp.compute_checksum typ data in
61
+
if not (Cfdp.verify_checksum typ data computed) then
62
+
fail "verify_checksum failed for computed checksum"
63
+
else check true
64
+
65
+
(* {1 NAK Segment Request Validation} *)
66
+
67
+
let () =
68
+
add_test ~name:"cfdp: segment_request" [ int64; int64 ] @@ fun s e ->
69
+
let start_offset = Int64.abs s in
70
+
let end_offset = Int64.abs e in
71
+
let seg = Cfdp.segment_request start_offset end_offset in
72
+
if seg.start_offset <> start_offset then fail "start_offset mismatch"
73
+
else if seg.end_offset <> end_offset then fail "end_offset mismatch"
74
+
else check true
75
+
76
+
let () =
77
+
add_test ~name:"cfdp: nak crafted segments" [ list (pair int64 int64) ]
78
+
@@ fun pairs ->
79
+
let segments =
80
+
List.map
81
+
(fun (s, e) ->
82
+
let s = Int64.abs s in
83
+
let e = Int64.abs e in
84
+
Cfdp.segment_request s e)
85
+
pairs
86
+
in
87
+
let _nak = Cfdp.nak ~start_scope:0L ~end_scope:1000000L segments in
88
+
check true
89
+
90
+
(* {1 Sender1 State Machine} *)
91
+
92
+
let sender1_event =
93
+
choose
94
+
[
95
+
const Cfdp.Sender1.Ev_cancel;
96
+
map [ uint8 ] (fun c ->
97
+
Cfdp.Sender1.Ev_fault
98
+
(match c mod 5 with
99
+
| 0 -> Cfdp.No_error
100
+
| 1 -> Cfdp.Inactivity_detected
101
+
| 2 -> Cfdp.File_checksum_failure
102
+
| 3 -> Cfdp.Cancel_received
103
+
| _ -> Cfdp.Nak_limit_reached));
104
+
map [ int64 ] (fun p ->
105
+
Cfdp.Sender1.Ev_segment_sent (Int64.abs p));
106
+
const Cfdp.Sender1.Ev_eof_sent;
107
+
]
108
+
109
+
let () =
110
+
add_test ~name:"cfdp: sender1 step" [ sender1_event ] @@ fun event ->
111
+
let eid = Cfdp.Entity_id.of_int64_exn 1L in
112
+
let sender = Cfdp.Sender1.initial eid in
113
+
let _sender', _actions = Cfdp.Sender1.step sender event in
114
+
check true
115
+
116
+
let () =
117
+
add_test ~name:"cfdp: sender1 multi" [ list sender1_event ] @@ fun events ->
118
+
let eid = Cfdp.Entity_id.of_int64_exn 1L in
119
+
let rec run sender = function
120
+
| [] -> ()
121
+
| event :: rest ->
122
+
let sender', _actions = Cfdp.Sender1.step sender event in
123
+
run sender' rest
124
+
in
125
+
run (Cfdp.Sender1.initial eid) events;
126
+
check true
127
+
128
+
(* {1 Sender2 State Machine} *)
129
+
130
+
let sender2_event =
131
+
choose
132
+
[
133
+
const Cfdp.Sender2.Ev_cancel;
134
+
map [ uint8 ] (fun c ->
135
+
Cfdp.Sender2.Ev_fault
136
+
(match c mod 5 with
137
+
| 0 -> Cfdp.No_error
138
+
| 1 -> Cfdp.Inactivity_detected
139
+
| 2 -> Cfdp.File_checksum_failure
140
+
| 3 -> Cfdp.Cancel_received
141
+
| _ -> Cfdp.Nak_limit_reached));
142
+
map [ int64 ] (fun p ->
143
+
Cfdp.Sender2.Ev_segment_sent (Int64.abs p));
144
+
const Cfdp.Sender2.Ev_eof_sent;
145
+
map [ uint8 ] (fun c ->
146
+
Cfdp.Sender2.Ev_timer_expired
147
+
(match c mod 5 with
148
+
| 0 -> Cfdp.Timer_nak
149
+
| 1 -> Cfdp.Timer_eof
150
+
| 2 -> Cfdp.Timer_finished
151
+
| 3 -> Cfdp.Timer_inactivity
152
+
| _ -> Cfdp.Timer_keep_alive));
153
+
]
154
+
155
+
let () =
156
+
add_test ~name:"cfdp: sender2 step" [ sender2_event ] @@ fun event ->
157
+
let eid = Cfdp.Entity_id.of_int64_exn 1L in
158
+
let sender = Cfdp.Sender2.initial eid in
159
+
let _sender', _actions = Cfdp.Sender2.step sender event in
160
+
check true
161
+
162
+
let () =
163
+
add_test ~name:"cfdp: sender2 multi" [ list sender2_event ] @@ fun events ->
164
+
let eid = Cfdp.Entity_id.of_int64_exn 1L in
165
+
let rec run sender = function
166
+
| [] -> ()
167
+
| event :: rest ->
168
+
let sender', _actions = Cfdp.Sender2.step sender event in
169
+
run sender' rest
170
+
in
171
+
run (Cfdp.Sender2.initial eid) events;
172
+
check true
173
+
174
+
(* {1 Receiver1 State Machine} *)
175
+
176
+
let () =
177
+
add_test ~name:"cfdp: receiver1 step" [ bool ] @@ fun is_cancel ->
178
+
let eid = Cfdp.Entity_id.of_int64_exn 2L in
179
+
let receiver = Cfdp.Receiver1.initial eid in
180
+
let event =
181
+
if is_cancel then Cfdp.Receiver1.Ev_cancel
182
+
else Cfdp.Receiver1.Ev_inactivity_timeout
183
+
in
184
+
let _receiver', _actions = Cfdp.Receiver1.step receiver event in
185
+
check true
186
+
187
+
(* {1 Receiver2 State Machine} *)
188
+
189
+
let receiver2_event =
190
+
choose
191
+
[
192
+
const Cfdp.Receiver2.Ev_cancel;
193
+
const Cfdp.Receiver2.Ev_inactivity_timeout;
194
+
map [ uint8 ] (fun c ->
195
+
Cfdp.Receiver2.Ev_timer_expired
196
+
(match c mod 5 with
197
+
| 0 -> Cfdp.Timer_nak
198
+
| 1 -> Cfdp.Timer_eof
199
+
| 2 -> Cfdp.Timer_finished
200
+
| 3 -> Cfdp.Timer_inactivity
201
+
| _ -> Cfdp.Timer_keep_alive));
202
+
]
203
+
204
+
let () =
205
+
add_test ~name:"cfdp: receiver2 step" [ receiver2_event ] @@ fun event ->
206
+
let eid = Cfdp.Entity_id.of_int64_exn 2L in
207
+
let receiver = Cfdp.Receiver2.initial eid in
208
+
let _receiver', _actions = Cfdp.Receiver2.step receiver event in
209
+
check true
210
+
211
+
let () =
212
+
add_test ~name:"cfdp: receiver2 multi" [ list receiver2_event ]
213
+
@@ fun events ->
214
+
let eid = Cfdp.Entity_id.of_int64_exn 2L in
215
+
let rec run receiver = function
216
+
| [] -> ()
217
+
| event :: rest ->
218
+
let receiver', _actions = Cfdp.Receiver2.step receiver event in
219
+
run receiver' rest
220
+
in
221
+
run (Cfdp.Receiver2.initial eid) events;
222
+
check true
223
+
224
+
(* {1 PDU Header Parsing} *)
225
+
226
+
let () =
227
+
add_test ~name:"cfdp: header parse no crash" [ bytes ] @@ fun buf ->
228
+
(match Cfdp.decode_header buf with Ok _ -> () | Error _ -> ());
229
+
check true
230
+
231
+
(* {1 Condition Code Conversion} *)
232
+
233
+
let () =
234
+
add_test ~name:"cfdp: condition roundtrip" [ uint8 ] @@ fun n ->
235
+
match Cfdp.condition_of_int n with
236
+
| Some cond ->
237
+
let n' = Cfdp.int_of_condition cond in
238
+
if n <> n' then fail "condition roundtrip mismatch" else check true
239
+
| None -> check true
240
+
241
+
(* {1 Checksum Type Conversion} *)
242
+
243
+
let () =
244
+
add_test ~name:"cfdp: checksum_type roundtrip" [ uint8 ] @@ fun n ->
245
+
match Cfdp.checksum_type_of_int n with
246
+
| Some typ ->
247
+
let n' = Cfdp.int_of_checksum_type typ in
248
+
if n <> n' then fail "checksum_type roundtrip mismatch" else check true
249
+
| None -> check true
250
+
251
+
(* {1 Directive Code Conversion} *)
252
+
253
+
let () =
254
+
add_test ~name:"cfdp: directive_code roundtrip" [ uint8 ] @@ fun n ->
255
+
match Cfdp.directive_code_of_int n with
256
+
| Some code ->
257
+
let n' = Cfdp.int_of_directive_code code in
258
+
if n <> n' then fail "directive_code roundtrip mismatch" else check true
259
+
| None -> check true
260
+
261
+
(* {1 Entity ID} *)
262
+
263
+
let () =
264
+
add_test ~name:"cfdp: entity_id of_int negative" [ int ] @@ fun n ->
265
+
if n < 0 then
266
+
match Cfdp.Entity_id.of_int n with
267
+
| Some _ -> fail "negative entity_id accepted"
268
+
| None -> check true
269
+
else check true
270
+
271
+
let () =
272
+
add_test ~name:"cfdp: entity_id of_int64 negative" [ int64 ] @@ fun n ->
273
+
if n < 0L then
274
+
match Cfdp.Entity_id.of_int64 n with
275
+
| Some _ -> fail "negative entity_id accepted"
276
+
| None -> check true
277
+
else check true
278
+
279
+
let () =
280
+
add_test ~name:"cfdp: entity_id roundtrip" [ int64 ] @@ fun n ->
281
+
let n = Int64.abs n in
282
+
if n < 0L then check true
283
+
else
284
+
match Cfdp.Entity_id.of_int64 n with
285
+
| Some eid ->
286
+
let n' = Cfdp.Entity_id.to_int64 eid in
287
+
if n <> n' then fail "entity_id roundtrip mismatch" else check true
288
+
| None -> fail "valid entity_id rejected"
+1989
lib/cfdp.ml
+1989
lib/cfdp.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** CCSDS File Delivery Protocol (CCSDS 727.0-B-5).
7
+
8
+
{b PDU Header Format}
9
+
10
+
{v
11
+
Fixed Header (4 bytes minimum):
12
+
+-------+------+-----+------+-----+-------+--------+
13
+
| Ver | Type | Dir | Mode | CRC | Large | PDULen |
14
+
| 3b | 1b | 1b | 1b | 1b | 1b | 16b |
15
+
+-------+------+-----+------+-----+-------+--------+
16
+
| SegCtl| EIDLen| SMF | SeqLen|
17
+
| 1b | 3b | 1b | 3b |
18
+
+-------+-------+-----+-------+
19
+
| Source Entity ID | Variable (1-8 octets) |
20
+
| Transaction Seq Nr | Variable (1-8 octets) |
21
+
| Dest Entity ID | Variable (1-8 octets) |
22
+
+---------------------+---------------------------+
23
+
v}
24
+
25
+
Header size: [4 + 2 * entity_id_len + seq_nr_len] bytes *)
26
+
27
+
(* {1 Binary Helpers} *)
28
+
29
+
let get_u16_be buf off = (Char.code buf.[off] lsl 8) lor Char.code buf.[off + 1]
30
+
31
+
let get_u32_be buf off =
32
+
(Char.code buf.[off] lsl 24)
33
+
lor (Char.code buf.[off + 1] lsl 16)
34
+
lor (Char.code buf.[off + 2] lsl 8)
35
+
lor Char.code buf.[off + 3]
36
+
37
+
let get_u64_be buf off =
38
+
let rec loop acc i =
39
+
if i >= 8 then acc
40
+
else
41
+
let byte = Int64.of_int (Char.code buf.[off + i]) in
42
+
loop (Int64.logor (Int64.shift_left acc 8) byte) (i + 1)
43
+
in
44
+
loop 0L 0
45
+
46
+
let get_var_uint_be buf off len =
47
+
let rec loop acc i =
48
+
if i >= len then acc
49
+
else
50
+
let byte = Int64.of_int (Char.code buf.[off + i]) in
51
+
loop (Int64.logor (Int64.shift_left acc 8) byte) (i + 1)
52
+
in
53
+
loop 0L 0
54
+
55
+
let put_u16_be buf off v =
56
+
Bytes.set buf off (Char.chr ((v lsr 8) land 0xFF));
57
+
Bytes.set buf (off + 1) (Char.chr (v land 0xFF))
58
+
59
+
let put_u32_be buf off v =
60
+
Bytes.set buf off (Char.chr ((v lsr 24) land 0xFF));
61
+
Bytes.set buf (off + 1) (Char.chr ((v lsr 16) land 0xFF));
62
+
Bytes.set buf (off + 2) (Char.chr ((v lsr 8) land 0xFF));
63
+
Bytes.set buf (off + 3) (Char.chr (v land 0xFF))
64
+
65
+
let put_u64_be buf off v =
66
+
for i = 0 to 7 do
67
+
let byte =
68
+
Int64.to_int (Int64.shift_right_logical v ((7 - i) * 8)) land 0xFF
69
+
in
70
+
Bytes.set buf (off + i) (Char.chr byte)
71
+
done
72
+
73
+
let put_var_uint_be buf off len v =
74
+
for i = 0 to len - 1 do
75
+
let shift = (len - 1 - i) * 8 in
76
+
let byte =
77
+
Int64.to_int (Int64.logand (Int64.shift_right_logical v shift) 0xFFL)
78
+
in
79
+
Bytes.set buf (off + i) (Char.chr byte)
80
+
done
81
+
82
+
(* CRC-16-CCITT table *)
83
+
let crc16_table =
84
+
let tbl = Array.make 256 0 in
85
+
for i = 0 to 255 do
86
+
let crc = ref (i lsl 8) in
87
+
for _ = 0 to 7 do
88
+
if !crc land 0x8000 <> 0 then crc := (!crc lsl 1) lxor 0x1021
89
+
else crc := !crc lsl 1
90
+
done;
91
+
tbl.(i) <- !crc land 0xFFFF
92
+
done;
93
+
tbl
94
+
95
+
let crc16_ccitt_sub buf off len =
96
+
let crc = ref 0xFFFF in
97
+
for i = off to off + len - 1 do
98
+
let idx = ((!crc lsr 8) lxor Char.code (Bytes.get buf i)) land 0xFF in
99
+
crc := ((!crc lsl 8) lxor crc16_table.(idx)) land 0xFFFF
100
+
done;
101
+
!crc
102
+
103
+
(* {1 Duration} *)
104
+
105
+
module Duration = struct
106
+
type t = float
107
+
108
+
let of_sec s = s
109
+
end
110
+
111
+
(* {1 Entity ID}
112
+
113
+
CCSDS 727.0-B-5 section 5.1.4 specifies entity IDs as unsigned binary
114
+
integers of 1-8 bytes. We use OCaml's signed int64 which limits us to
115
+
values in [0, 2^63-1]. Entity IDs >= 2^63 cannot be represented and
116
+
will be rejected during parsing. This covers most practical use cases
117
+
since missions typically use 1-4 byte entity IDs. *)
118
+
119
+
module Entity_id = struct
120
+
type t = int64
121
+
122
+
let of_int n = if n < 0 then None else Some (Int64.of_int n)
123
+
124
+
let of_int_exn n =
125
+
if n < 0 then invalid_arg "Cfdp.Entity_id.of_int_exn: negative"
126
+
else Int64.of_int n
127
+
128
+
let of_int64 n = if n < 0L then None else Some n
129
+
130
+
let of_int64_exn n =
131
+
if n < 0L then invalid_arg "Cfdp.Entity_id.of_int64_exn: negative" else n
132
+
133
+
let of_int64_unsigned n =
134
+
(* Bytes.get_int64_be returns signed int64, so values >= 2^63 appear
135
+
negative. We detect this and return an error instead of silently
136
+
wrapping or rejecting as "negative". *)
137
+
if n < 0L then `Overflow else `Ok n
138
+
139
+
let to_int64 eid = eid
140
+
let equal = Int64.equal
141
+
let compare = Int64.compare
142
+
let pp fmt eid = Format.fprintf fmt "0x%Lx" eid
143
+
end
144
+
145
+
type entity_id = Entity_id.t
146
+
147
+
(* {1 Transaction ID} *)
148
+
149
+
type transaction_id = { source : entity_id; seq_nr : int64 }
150
+
151
+
let pp_transaction_id fmt tid =
152
+
Format.fprintf fmt "{source=%a; seq=%Ld}" Entity_id.pp tid.source tid.seq_nr
153
+
154
+
(* {1 PDU Configuration} *)
155
+
156
+
type pdu_config = { entity_id_len : int; seq_nr_len : int }
157
+
158
+
let pdu_config ~entity_id_len ~seq_nr_len =
159
+
if
160
+
entity_id_len >= 1 && entity_id_len <= 8 && seq_nr_len >= 1
161
+
&& seq_nr_len <= 8
162
+
then Some { entity_id_len; seq_nr_len }
163
+
else None
164
+
165
+
let default_config = { entity_id_len = 2; seq_nr_len = 4 }
166
+
167
+
(* {1 Enumerations} *)
168
+
169
+
type pdu_type = File_directive | File_data
170
+
type direction = Toward_receiver | Toward_sender
171
+
type transmission_mode = Acknowledged | Unacknowledged
172
+
173
+
type condition =
174
+
| No_error
175
+
| Positive_ack_limit
176
+
| Keep_alive_limit
177
+
| Invalid_transmission_mode
178
+
| Filestore_rejection
179
+
| File_checksum_failure
180
+
| File_size_error
181
+
| Nak_limit_reached
182
+
| Inactivity_detected
183
+
| Invalid_file_structure
184
+
| Check_limit_reached
185
+
| Unsupported_checksum_type
186
+
| Suspend_received
187
+
| Cancel_received
188
+
189
+
let int_of_condition = function
190
+
| No_error -> 0x0
191
+
| Positive_ack_limit -> 0x1
192
+
| Keep_alive_limit -> 0x2
193
+
| Invalid_transmission_mode -> 0x3
194
+
| Filestore_rejection -> 0x4
195
+
| File_checksum_failure -> 0x5
196
+
| File_size_error -> 0x6
197
+
| Nak_limit_reached -> 0x7
198
+
| Inactivity_detected -> 0x8
199
+
| Invalid_file_structure -> 0x9
200
+
| Check_limit_reached -> 0xA
201
+
| Unsupported_checksum_type -> 0xB
202
+
| Suspend_received -> 0xE
203
+
| Cancel_received -> 0xF
204
+
205
+
let condition_of_int = function
206
+
| 0x0 -> Some No_error
207
+
| 0x1 -> Some Positive_ack_limit
208
+
| 0x2 -> Some Keep_alive_limit
209
+
| 0x3 -> Some Invalid_transmission_mode
210
+
| 0x4 -> Some Filestore_rejection
211
+
| 0x5 -> Some File_checksum_failure
212
+
| 0x6 -> Some File_size_error
213
+
| 0x7 -> Some Nak_limit_reached
214
+
| 0x8 -> Some Inactivity_detected
215
+
| 0x9 -> Some Invalid_file_structure
216
+
| 0xA -> Some Check_limit_reached
217
+
| 0xB -> Some Unsupported_checksum_type
218
+
| 0xE -> Some Suspend_received
219
+
| 0xF -> Some Cancel_received
220
+
| _ -> None
221
+
222
+
let pp_condition fmt c =
223
+
Format.fprintf fmt "%s"
224
+
(match c with
225
+
| No_error -> "No_error"
226
+
| Positive_ack_limit -> "Positive_ack_limit"
227
+
| Keep_alive_limit -> "Keep_alive_limit"
228
+
| Invalid_transmission_mode -> "Invalid_transmission_mode"
229
+
| Filestore_rejection -> "Filestore_rejection"
230
+
| File_checksum_failure -> "File_checksum_failure"
231
+
| File_size_error -> "File_size_error"
232
+
| Nak_limit_reached -> "Nak_limit_reached"
233
+
| Inactivity_detected -> "Inactivity_detected"
234
+
| Invalid_file_structure -> "Invalid_file_structure"
235
+
| Check_limit_reached -> "Check_limit_reached"
236
+
| Unsupported_checksum_type -> "Unsupported_checksum_type"
237
+
| Suspend_received -> "Suspend_received"
238
+
| Cancel_received -> "Cancel_received")
239
+
240
+
type delivery_code = Data_complete | Data_incomplete
241
+
242
+
type file_status =
243
+
| Discarded_deliberately
244
+
| Discarded_filestore_rejection
245
+
| Retained_successfully
246
+
| Status_unreported
247
+
248
+
type transaction_status =
249
+
| Tx_undefined
250
+
| Tx_active
251
+
| Tx_terminated
252
+
| Tx_unrecognized
253
+
254
+
type record_continuation =
255
+
| No_record_boundary
256
+
| Record_start
257
+
| Record_end
258
+
| Complete_record
259
+
260
+
(* {1 Checksum Types} *)
261
+
262
+
type checksum_type =
263
+
| Checksum_modular
264
+
| Checksum_crc32
265
+
| Checksum_crc32c
266
+
| Checksum_null
267
+
268
+
let int_of_checksum_type = function
269
+
| Checksum_modular -> 0
270
+
| Checksum_crc32 -> 1
271
+
| Checksum_crc32c -> 2
272
+
| Checksum_null -> 15
273
+
274
+
let checksum_type_of_int = function
275
+
| 0 -> Some Checksum_modular
276
+
| 1 -> Some Checksum_crc32
277
+
| 2 -> Some Checksum_crc32c
278
+
| 15 -> Some Checksum_null
279
+
| _ -> None
280
+
281
+
let pp_checksum_type fmt t =
282
+
Format.fprintf fmt "%s"
283
+
(match t with
284
+
| Checksum_modular -> "Modular"
285
+
| Checksum_crc32 -> "CRC-32"
286
+
| Checksum_crc32c -> "CRC-32C"
287
+
| Checksum_null -> "Null")
288
+
289
+
let compute_checksum_modular data =
290
+
let sum = ref 0L in
291
+
let len = Bytes.length data in
292
+
let i = ref 0 in
293
+
while !i + 4 <= len do
294
+
let word = Int64.of_int32 (Bytes.get_int32_be data !i) in
295
+
sum := Int64.add !sum (Int64.logand word 0xFFFFFFFFL);
296
+
i := !i + 4
297
+
done;
298
+
(* Handle remaining bytes *)
299
+
let remaining = len - !i in
300
+
if remaining > 0 then begin
301
+
let word = ref 0l in
302
+
for j = 0 to remaining - 1 do
303
+
let byte = Int32.of_int (Bytes.get_uint8 data (!i + j)) in
304
+
word := Int32.logor !word (Int32.shift_left byte ((3 - j) * 8))
305
+
done;
306
+
sum := Int64.add !sum (Int64.logand (Int64.of_int32 !word) 0xFFFFFFFFL)
307
+
end;
308
+
(* Fold carries *)
309
+
let result = Int64.logand !sum 0xFFFFFFFFL in
310
+
Int64.to_int32 result
311
+
312
+
(* CRC-32 (ISO 3309) - use checkseum library *)
313
+
let compute_checksum_crc32 data =
314
+
Checkseum.Crc32.digest_string
315
+
(Bytes.unsafe_to_string data)
316
+
0 (Bytes.length data) Checkseum.Crc32.default
317
+
|> Optint.to_int32
318
+
319
+
(* CRC-32C (Castagnoli) - use checkseum library *)
320
+
let compute_checksum_crc32c data =
321
+
let crc =
322
+
Checkseum.Crc32c.digest_bytes data 0 (Bytes.length data)
323
+
Checkseum.Crc32c.default
324
+
in
325
+
Optint.to_int32 crc
326
+
327
+
let compute_checksum typ data =
328
+
match typ with
329
+
| Checksum_modular -> compute_checksum_modular data
330
+
| Checksum_crc32 -> compute_checksum_crc32 data
331
+
| Checksum_crc32c -> compute_checksum_crc32c data
332
+
| Checksum_null -> 0l
333
+
334
+
let verify_checksum typ data expected =
335
+
Int32.equal (compute_checksum typ data) expected
336
+
337
+
(* {1 Directive Codes} *)
338
+
339
+
type directive_code =
340
+
| Dir_eof
341
+
| Dir_finished
342
+
| Dir_ack
343
+
| Dir_metadata
344
+
| Dir_nak
345
+
| Dir_prompt
346
+
| Dir_keep_alive
347
+
348
+
let int_of_directive_code = function
349
+
| Dir_eof -> 0x04
350
+
| Dir_finished -> 0x05
351
+
| Dir_ack -> 0x06
352
+
| Dir_metadata -> 0x07
353
+
| Dir_nak -> 0x08
354
+
| Dir_prompt -> 0x09
355
+
| Dir_keep_alive -> 0x0C
356
+
357
+
let directive_code_of_int = function
358
+
| 0x04 -> Some Dir_eof
359
+
| 0x05 -> Some Dir_finished
360
+
| 0x06 -> Some Dir_ack
361
+
| 0x07 -> Some Dir_metadata
362
+
| 0x08 -> Some Dir_nak
363
+
| 0x09 -> Some Dir_prompt
364
+
| 0x0C -> Some Dir_keep_alive
365
+
| _ -> None
366
+
367
+
let pp_directive_code fmt c =
368
+
Format.fprintf fmt "%s"
369
+
(match c with
370
+
| Dir_eof -> "EOF"
371
+
| Dir_finished -> "Finished"
372
+
| Dir_ack -> "ACK"
373
+
| Dir_metadata -> "Metadata"
374
+
| Dir_nak -> "NAK"
375
+
| Dir_prompt -> "Prompt"
376
+
| Dir_keep_alive -> "Keep_alive")
377
+
378
+
(* {1 PDU Header} *)
379
+
380
+
type header = {
381
+
version : int;
382
+
pdu_type : pdu_type;
383
+
direction : direction;
384
+
transmission_mode : transmission_mode;
385
+
crc_present : bool;
386
+
large_file : bool;
387
+
segment_ctrl : bool;
388
+
segment_metadata : bool;
389
+
source_entity : entity_id;
390
+
transaction_seq : int64;
391
+
dest_entity : entity_id;
392
+
data_len : int;
393
+
}
394
+
395
+
let pp_header fmt h =
396
+
Format.fprintf fmt
397
+
"{ver=%d; type=%s; dir=%s; mode=%s; crc=%b; large=%b; src=%a; seq=%Ld; \
398
+
dst=%a; len=%d}"
399
+
h.version
400
+
(match h.pdu_type with File_directive -> "Dir" | File_data -> "Data")
401
+
(match h.direction with
402
+
| Toward_receiver -> "->Rx"
403
+
| Toward_sender -> "->Tx")
404
+
(match h.transmission_mode with
405
+
| Acknowledged -> "Ack"
406
+
| Unacknowledged -> "Unack")
407
+
h.crc_present h.large_file Entity_id.pp h.source_entity h.transaction_seq
408
+
Entity_id.pp h.dest_entity h.data_len
409
+
410
+
(* {1 File Directive PDUs} *)
411
+
412
+
type eof = {
413
+
condition : condition;
414
+
checksum : int32;
415
+
file_size : int64;
416
+
fault_location : entity_id option;
417
+
}
418
+
419
+
let eof ?fault_location ~condition ~checksum ~file_size () =
420
+
{ condition; checksum; file_size; fault_location }
421
+
422
+
let pp_eof fmt e =
423
+
Format.fprintf fmt "{cond=%a; checksum=0x%lx; size=%Ld}" pp_condition
424
+
e.condition e.checksum e.file_size
425
+
426
+
type filestore_response = {
427
+
action_code : int;
428
+
status_code : int;
429
+
first_filename : string;
430
+
second_filename : string;
431
+
message : string;
432
+
}
433
+
434
+
type finished = {
435
+
condition : condition;
436
+
delivery_code : delivery_code;
437
+
file_status : file_status;
438
+
filestore_responses : filestore_response list;
439
+
fault_location : entity_id option;
440
+
}
441
+
442
+
let finished ?(filestore_responses = []) ?fault_location ~condition
443
+
~delivery_code ~file_status () =
444
+
{ condition; delivery_code; file_status; filestore_responses; fault_location }
445
+
446
+
let pp_finished fmt f =
447
+
Format.fprintf fmt "{cond=%a; delivery=%s; status=%s}" pp_condition
448
+
f.condition
449
+
(match f.delivery_code with
450
+
| Data_complete -> "Complete"
451
+
| Data_incomplete -> "Incomplete")
452
+
(match f.file_status with
453
+
| Discarded_deliberately -> "Discarded"
454
+
| Discarded_filestore_rejection -> "Rejected"
455
+
| Retained_successfully -> "Retained"
456
+
| Status_unreported -> "Unreported")
457
+
458
+
type ack = {
459
+
directive : directive_code;
460
+
subtype : int;
461
+
condition : condition;
462
+
transaction_status : transaction_status;
463
+
}
464
+
465
+
let ack ~directive ~subtype ~condition ~transaction_status =
466
+
{ directive; subtype; condition; transaction_status }
467
+
468
+
let pp_ack fmt a =
469
+
Format.fprintf fmt "{dir=%a; subtype=%d; cond=%a}" pp_directive_code
470
+
a.directive a.subtype pp_condition a.condition
471
+
472
+
type filestore_request = {
473
+
action_code : int;
474
+
first_filename : string;
475
+
second_filename : string;
476
+
}
477
+
478
+
type metadata = {
479
+
closure_requested : bool;
480
+
checksum_type : checksum_type;
481
+
file_size : int64;
482
+
source_filename : string;
483
+
dest_filename : string;
484
+
filestore_requests : filestore_request list;
485
+
messages_to_user : bytes list;
486
+
}
487
+
488
+
let metadata ?(closure_requested = false) ?(checksum_type = Checksum_modular)
489
+
?(filestore_requests = []) ?(messages_to_user = []) ~file_size
490
+
~source_filename ~dest_filename () =
491
+
{
492
+
closure_requested;
493
+
checksum_type;
494
+
file_size;
495
+
source_filename;
496
+
dest_filename;
497
+
filestore_requests;
498
+
messages_to_user;
499
+
}
500
+
501
+
let pp_metadata fmt m =
502
+
Format.fprintf fmt "{closure=%b; checksum=%a; size=%Ld; src=%S; dst=%S}"
503
+
m.closure_requested pp_checksum_type m.checksum_type m.file_size
504
+
m.source_filename m.dest_filename
505
+
506
+
type segment_request = { start_offset : int64; end_offset : int64 }
507
+
508
+
let segment_request start_offset end_offset = { start_offset; end_offset }
509
+
510
+
type nak = {
511
+
start_scope : int64;
512
+
end_scope : int64;
513
+
segments : segment_request list;
514
+
}
515
+
516
+
let nak ~start_scope ~end_scope segments = { start_scope; end_scope; segments }
517
+
518
+
let pp_nak fmt n =
519
+
Format.fprintf fmt "{scope=[%Ld,%Ld]; reqs=%d}" n.start_scope n.end_scope
520
+
(List.length n.segments)
521
+
522
+
type prompt_response = Prompt_nak | Prompt_keep_alive
523
+
type prompt = { response : prompt_response }
524
+
525
+
let prompt response = { response }
526
+
527
+
let pp_prompt fmt p =
528
+
Format.fprintf fmt "{resp=%s}"
529
+
(match p.response with
530
+
| Prompt_nak -> "NAK"
531
+
| Prompt_keep_alive -> "Keep_alive")
532
+
533
+
type keep_alive = { progress : int64 }
534
+
535
+
let keep_alive progress = { progress }
536
+
let pp_keep_alive fmt k = Format.fprintf fmt "{progress=%Ld}" k.progress
537
+
538
+
(* {1 File Data PDU} *)
539
+
540
+
type file_data = {
541
+
continuation : record_continuation option;
542
+
segment_metadata : bytes option;
543
+
offset : int64;
544
+
data : bytes;
545
+
}
546
+
547
+
let file_data ?continuation ?segment_metadata ~offset data =
548
+
{ continuation; segment_metadata; offset; data }
549
+
550
+
let pp_file_data fmt fd =
551
+
Format.fprintf fmt "{offset=%Ld; len=%d}" fd.offset (Bytes.length fd.data)
552
+
553
+
(* {1 Complete PDU} *)
554
+
555
+
type directive =
556
+
| Eof of eof
557
+
| Finished of finished
558
+
| Ack of ack
559
+
| Metadata of metadata
560
+
| Nak of nak
561
+
| Prompt of prompt
562
+
| Keep_alive of keep_alive
563
+
564
+
let pp_directive fmt = function
565
+
| Eof e -> Format.fprintf fmt "EOF %a" pp_eof e
566
+
| Finished f -> Format.fprintf fmt "Finished %a" pp_finished f
567
+
| Ack a -> Format.fprintf fmt "ACK %a" pp_ack a
568
+
| Metadata m -> Format.fprintf fmt "Metadata %a" pp_metadata m
569
+
| Nak n -> Format.fprintf fmt "NAK %a" pp_nak n
570
+
| Prompt p -> Format.fprintf fmt "Prompt %a" pp_prompt p
571
+
| Keep_alive k -> Format.fprintf fmt "Keep_alive %a" pp_keep_alive k
572
+
573
+
type pdu =
574
+
| Pdu_directive of header * directive
575
+
| Pdu_file_data of header * file_data
576
+
577
+
let pp_pdu fmt = function
578
+
| Pdu_directive (h, d) ->
579
+
Format.fprintf fmt "Directive[%a] %a" pp_header h pp_directive d
580
+
| Pdu_file_data (h, fd) ->
581
+
Format.fprintf fmt "FileData[%a] %a" pp_header h pp_file_data fd
582
+
583
+
(* {1 Errors} *)
584
+
585
+
type error =
586
+
| Truncated of { need : int; have : int }
587
+
| Invalid_version of int
588
+
| Invalid_pdu_type of int
589
+
| Invalid_directive_code of int
590
+
| Invalid_condition_code of int
591
+
| Invalid_checksum_type of int
592
+
| Crc_mismatch of { expected : int; actual : int }
593
+
| Invalid_format of string
594
+
| Entity_id_overflow
595
+
596
+
let pp_error fmt = function
597
+
| Truncated { need; have } ->
598
+
Format.fprintf fmt "Truncated: need %d bytes, have %d" need have
599
+
| Invalid_version v -> Format.fprintf fmt "Invalid version: %d (expected 1)" v
600
+
| Invalid_pdu_type t -> Format.fprintf fmt "Invalid PDU type: %d" t
601
+
| Invalid_directive_code c ->
602
+
Format.fprintf fmt "Invalid directive code: 0x%02x" c
603
+
| Invalid_condition_code c ->
604
+
Format.fprintf fmt "Invalid condition code: 0x%x" c
605
+
| Invalid_checksum_type t -> Format.fprintf fmt "Invalid checksum type: %d" t
606
+
| Crc_mismatch { expected; actual } ->
607
+
Format.fprintf fmt "CRC mismatch: expected 0x%04x, got 0x%04x" expected
608
+
actual
609
+
| Invalid_format s -> Format.fprintf fmt "Invalid format: %s" s
610
+
| Entity_id_overflow ->
611
+
Format.fprintf fmt "Entity ID >= 2^63 exceeds int64 representation"
612
+
613
+
(* {1 Encoding} *)
614
+
615
+
let header_len config = 4 + (2 * config.entity_id_len) + config.seq_nr_len
616
+
617
+
let encode_header config hdr =
618
+
let len = header_len config in
619
+
let buf = Bytes.create len in
620
+
(* Byte 0: version(3) | type(1) | direction(1) | mode(1) | crc(1) | large(1) *)
621
+
let b0 =
622
+
((hdr.version land 0x7) lsl 5)
623
+
lor ((match hdr.pdu_type with File_directive -> 0 | File_data -> 1) lsl 4)
624
+
lor (match hdr.direction with Toward_receiver -> 0 | Toward_sender -> 1)
625
+
lsl 3
626
+
lor (match hdr.transmission_mode with
627
+
| Acknowledged -> 0
628
+
| Unacknowledged -> 1)
629
+
lsl 2
630
+
lor ((if hdr.crc_present then 1 else 0) lsl 1)
631
+
lor if hdr.large_file then 1 else 0
632
+
in
633
+
Bytes.set buf 0 (Char.chr b0);
634
+
(* Bytes 1-2: PDU data field length *)
635
+
put_u16_be buf 1 hdr.data_len;
636
+
(* Byte 3: seg_ctrl(1) | eid_len(3) | seg_meta(1) | seq_len(3) *)
637
+
let b3 =
638
+
((if hdr.segment_ctrl then 1 else 0) lsl 7)
639
+
lor (((config.entity_id_len - 1) land 0x7) lsl 4)
640
+
lor ((if hdr.segment_metadata then 1 else 0) lsl 3)
641
+
lor ((config.seq_nr_len - 1) land 0x7)
642
+
in
643
+
Bytes.set buf 3 (Char.chr b3);
644
+
(* Variable fields *)
645
+
put_var_uint_be buf 4 config.entity_id_len hdr.source_entity;
646
+
put_var_uint_be buf (4 + config.entity_id_len) config.seq_nr_len
647
+
hdr.transaction_seq;
648
+
put_var_uint_be buf
649
+
(4 + config.entity_id_len + config.seq_nr_len)
650
+
config.entity_id_len hdr.dest_entity;
651
+
Bytes.to_string buf
652
+
653
+
let encode_lv s =
654
+
let len = String.length s in
655
+
let buf = Bytes.create (1 + len) in
656
+
Bytes.set buf 0 (Char.chr len);
657
+
Bytes.blit_string s 0 buf 1 len;
658
+
Bytes.to_string buf
659
+
660
+
let encode_fss ~large_file value =
661
+
if large_file then
662
+
let buf = Bytes.create 8 in
663
+
put_u64_be buf 0 value;
664
+
Bytes.to_string buf
665
+
else
666
+
let buf = Bytes.create 4 in
667
+
put_u32_be buf 0 (Int64.to_int value);
668
+
Bytes.to_string buf
669
+
670
+
let encode_directive ~large_file dir =
671
+
match dir with
672
+
| Eof eof_pdu ->
673
+
let fss = encode_fss ~large_file eof_pdu.file_size in
674
+
let fault_tlv =
675
+
match eof_pdu.fault_location with
676
+
| None -> ""
677
+
| Some eid ->
678
+
let buf = Bytes.create 10 in
679
+
Bytes.set buf 0 (Char.chr 0x06);
680
+
Bytes.set buf 1 (Char.chr 8);
681
+
put_u64_be buf 2 (Entity_id.to_int64 eid);
682
+
Bytes.to_string buf
683
+
in
684
+
let buf = Bytes.create 6 in
685
+
Bytes.set buf 0 (Char.chr (int_of_directive_code Dir_eof));
686
+
Bytes.set buf 1 (Char.chr (int_of_condition eof_pdu.condition lsl 4));
687
+
put_u32_be buf 2 (Int32.to_int eof_pdu.checksum);
688
+
Bytes.to_string buf ^ fss ^ fault_tlv
689
+
| Finished fin ->
690
+
let buf = Bytes.create 2 in
691
+
Bytes.set buf 0 (Char.chr (int_of_directive_code Dir_finished));
692
+
let b1 =
693
+
(int_of_condition fin.condition lsl 4)
694
+
lor (match fin.delivery_code with
695
+
| Data_complete -> 0
696
+
| Data_incomplete -> 1)
697
+
lsl 2
698
+
lor
699
+
match fin.file_status with
700
+
| Discarded_deliberately -> 0
701
+
| Discarded_filestore_rejection -> 1
702
+
| Retained_successfully -> 2
703
+
| Status_unreported -> 3
704
+
in
705
+
Bytes.set buf 1 (Char.chr b1);
706
+
Bytes.to_string buf
707
+
| Ack ack_pdu ->
708
+
let buf = Bytes.create 3 in
709
+
Bytes.set buf 0 (Char.chr (int_of_directive_code Dir_ack));
710
+
let b1 =
711
+
(int_of_directive_code ack_pdu.directive lsl 4)
712
+
lor (ack_pdu.subtype land 0xF)
713
+
in
714
+
Bytes.set buf 1 (Char.chr b1);
715
+
let b2 =
716
+
(int_of_condition ack_pdu.condition lsl 4)
717
+
lor
718
+
match ack_pdu.transaction_status with
719
+
| Tx_undefined -> 0
720
+
| Tx_active -> 1
721
+
| Tx_terminated -> 2
722
+
| Tx_unrecognized -> 3
723
+
in
724
+
Bytes.set buf 2 (Char.chr b2);
725
+
Bytes.to_string buf
726
+
| Metadata meta ->
727
+
let buf = Bytes.create 2 in
728
+
Bytes.set buf 0 (Char.chr (int_of_directive_code Dir_metadata));
729
+
let b1 =
730
+
((if meta.closure_requested then 1 else 0) lsl 6)
731
+
lor int_of_checksum_type meta.checksum_type
732
+
in
733
+
Bytes.set buf 1 (Char.chr b1);
734
+
let fss = encode_fss ~large_file meta.file_size in
735
+
let src_lv = encode_lv meta.source_filename in
736
+
let dst_lv = encode_lv meta.dest_filename in
737
+
Bytes.to_string buf ^ fss ^ src_lv ^ dst_lv
738
+
| Nak nak_pdu ->
739
+
let code = Bytes.make 1 (Char.chr (int_of_directive_code Dir_nak)) in
740
+
let start_fss = encode_fss ~large_file nak_pdu.start_scope in
741
+
let end_fss = encode_fss ~large_file nak_pdu.end_scope in
742
+
let segs =
743
+
List.map
744
+
(fun seg ->
745
+
encode_fss ~large_file seg.start_offset
746
+
^ encode_fss ~large_file seg.end_offset)
747
+
nak_pdu.segments
748
+
in
749
+
String.concat ""
750
+
([ Bytes.to_string code; start_fss; end_fss ] @ segs)
751
+
| Prompt pmt ->
752
+
let buf = Bytes.create 2 in
753
+
Bytes.set buf 0 (Char.chr (int_of_directive_code Dir_prompt));
754
+
let b1 =
755
+
match pmt.response with Prompt_nak -> 0 | Prompt_keep_alive -> 0x80
756
+
in
757
+
Bytes.set buf 1 (Char.chr b1);
758
+
Bytes.to_string buf
759
+
| Keep_alive ka ->
760
+
let code = Bytes.make 1 (Char.chr (int_of_directive_code Dir_keep_alive)) in
761
+
let fss = encode_fss ~large_file ka.progress in
762
+
Bytes.to_string code ^ fss
763
+
764
+
let encode_file_data ~large_file ~segment_metadata:seg_meta_flag fd =
765
+
let seg_meta_bytes =
766
+
if seg_meta_flag then begin
767
+
let cont_len =
768
+
match (fd.continuation, fd.segment_metadata) with
769
+
| Some c, Some m ->
770
+
let cont =
771
+
match c with
772
+
| No_record_boundary -> 0
773
+
| Record_start -> 1
774
+
| Record_end -> 2
775
+
| Complete_record -> 3
776
+
in
777
+
(cont lsl 6) lor (Bytes.length m land 0x3F)
778
+
| Some c, None ->
779
+
let cont =
780
+
match c with
781
+
| No_record_boundary -> 0
782
+
| Record_start -> 1
783
+
| Record_end -> 2
784
+
| Complete_record -> 3
785
+
in
786
+
cont lsl 6
787
+
| None, _ -> 0
788
+
in
789
+
let meta =
790
+
match fd.segment_metadata with Some m -> Bytes.to_string m | None -> ""
791
+
in
792
+
String.make 1 (Char.chr cont_len) ^ meta
793
+
end
794
+
else ""
795
+
in
796
+
let fss = encode_fss ~large_file fd.offset in
797
+
seg_meta_bytes ^ fss ^ Bytes.to_string fd.data
798
+
799
+
let encode config pdu =
800
+
let hdr, data =
801
+
match pdu with
802
+
| Pdu_directive (h, d) ->
803
+
let data = encode_directive ~large_file:h.large_file d in
804
+
({ h with data_len = String.length data }, data)
805
+
| Pdu_file_data (h, fd) ->
806
+
let data =
807
+
encode_file_data ~large_file:h.large_file
808
+
~segment_metadata:h.segment_metadata fd
809
+
in
810
+
({ h with data_len = String.length data }, data)
811
+
in
812
+
let hdr_bytes = encode_header config hdr in
813
+
if hdr.crc_present then begin
814
+
let full = Bytes.of_string (hdr_bytes ^ data) in
815
+
let crc = crc16_ccitt_sub full 0 (Bytes.length full) in
816
+
let crc_bytes = Bytes.create 2 in
817
+
put_u16_be crc_bytes 0 crc;
818
+
Bytes.to_string full ^ Bytes.to_string crc_bytes
819
+
end
820
+
else hdr_bytes ^ data
821
+
822
+
(* {1 Decoding} *)
823
+
824
+
let ( let* ) = Result.bind
825
+
826
+
let truncated ~need ~have = Error (Truncated { need; have })
827
+
828
+
let decode_header buf =
829
+
let len = String.length buf in
830
+
if len < 4 then truncated ~need:4 ~have:len
831
+
else
832
+
let b0 = Char.code buf.[0] in
833
+
let version = (b0 lsr 5) land 0x7 in
834
+
if version <> 1 then Error (Invalid_version version)
835
+
else
836
+
let pdu_type_bit = (b0 lsr 4) land 0x1 in
837
+
let direction_bit = (b0 lsr 3) land 0x1 in
838
+
let mode_bit = (b0 lsr 2) land 0x1 in
839
+
let crc_bit = (b0 lsr 1) land 0x1 in
840
+
let large_bit = b0 land 0x1 in
841
+
let data_len = get_u16_be buf 1 in
842
+
let b3 = Char.code buf.[3] in
843
+
let seg_ctrl_bit = (b3 lsr 7) land 0x1 in
844
+
let eid_len = ((b3 lsr 4) land 0x7) + 1 in
845
+
let seg_meta_bit = (b3 lsr 3) land 0x1 in
846
+
let seq_len = (b3 land 0x7) + 1 in
847
+
let config = { entity_id_len = eid_len; seq_nr_len = seq_len } in
848
+
let var_len = (2 * eid_len) + seq_len in
849
+
if len < 4 + var_len then truncated ~need:(4 + var_len) ~have:len
850
+
else
851
+
let source_raw = get_var_uint_be buf 4 eid_len in
852
+
let* source_entity =
853
+
match Entity_id.of_int64_unsigned source_raw with
854
+
| `Ok eid -> Ok eid
855
+
| `Overflow -> Error Entity_id_overflow
856
+
in
857
+
let transaction_seq = get_var_uint_be buf (4 + eid_len) seq_len in
858
+
let dest_raw = get_var_uint_be buf (4 + eid_len + seq_len) eid_len in
859
+
let* dest_entity =
860
+
match Entity_id.of_int64_unsigned dest_raw with
861
+
| `Ok eid -> Ok eid
862
+
| `Overflow -> Error Entity_id_overflow
863
+
in
864
+
let header =
865
+
{
866
+
version;
867
+
pdu_type = (if pdu_type_bit = 0 then File_directive else File_data);
868
+
direction =
869
+
(if direction_bit = 0 then Toward_receiver else Toward_sender);
870
+
transmission_mode =
871
+
(if mode_bit = 0 then Acknowledged else Unacknowledged);
872
+
crc_present = crc_bit = 1;
873
+
large_file = large_bit = 1;
874
+
segment_ctrl = seg_ctrl_bit = 1;
875
+
segment_metadata = seg_meta_bit = 1;
876
+
source_entity;
877
+
transaction_seq;
878
+
dest_entity;
879
+
data_len;
880
+
}
881
+
in
882
+
Ok (header, config, 4 + var_len)
883
+
884
+
let decode_fss buf off ~large_file =
885
+
if large_file then (get_u64_be buf off, 8)
886
+
else (Int64.of_int32 (Int32.of_int (get_u32_be buf off)), 4)
887
+
888
+
let decode_lv buf off =
889
+
let len = String.length buf in
890
+
if off >= len then Error (Truncated { need = 1; have = 0 })
891
+
else
892
+
let str_len = Char.code buf.[off] in
893
+
let need = off + 1 + str_len in
894
+
if need > len then Error (Truncated { need = 1 + str_len; have = len - off })
895
+
else
896
+
let s = String.sub buf (off + 1) str_len in
897
+
Ok (s, 1 + str_len)
898
+
899
+
let decode_directive ~large_file buf off =
900
+
let len = String.length buf - off in
901
+
if len < 1 then Error (Truncated { need = 1; have = len })
902
+
else
903
+
let code = Char.code buf.[off] in
904
+
match directive_code_of_int code with
905
+
| None -> Error (Invalid_directive_code code)
906
+
| Some Dir_eof -> (
907
+
let fss_len = if large_file then 8 else 4 in
908
+
let min_len = 1 + 1 + 4 + fss_len in
909
+
if len < min_len then Error (Truncated { need = min_len; have = len })
910
+
else
911
+
let b1 = Char.code buf.[off + 1] in
912
+
let cond_code = (b1 lsr 4) land 0xF in
913
+
match condition_of_int cond_code with
914
+
| None -> Error (Invalid_condition_code cond_code)
915
+
| Some cond ->
916
+
let cksum = Int32.of_int (get_u32_be buf (off + 2)) in
917
+
let fsize, _ = decode_fss buf (off + 6) ~large_file in
918
+
let fss_end = off + 6 + fss_len in
919
+
(* Parse fault location TLV if present *)
920
+
let floc, consumed =
921
+
if
922
+
len > fss_end - off
923
+
&& Char.code buf.[fss_end] = 0x06
924
+
then begin
925
+
let tlv_len = Char.code buf.[fss_end + 1] in
926
+
if tlv_len = 8 then
927
+
let raw = get_u64_be buf (fss_end + 2) in
928
+
match Entity_id.of_int64_unsigned raw with
929
+
| `Ok eid -> (Some eid, fss_end + 2 + tlv_len - off)
930
+
| `Overflow -> (None, fss_end - off)
931
+
else (None, fss_end - off)
932
+
end
933
+
else (None, fss_end - off)
934
+
in
935
+
Ok
936
+
( Eof
937
+
{
938
+
condition = cond;
939
+
checksum = cksum;
940
+
file_size = fsize;
941
+
fault_location = floc;
942
+
},
943
+
consumed ))
944
+
| Some Dir_finished -> (
945
+
if len < 2 then Error (Truncated { need = 2; have = len })
946
+
else
947
+
let b1 = Char.code buf.[off + 1] in
948
+
let cond_code = (b1 lsr 4) land 0xF in
949
+
match condition_of_int cond_code with
950
+
| None -> Error (Invalid_condition_code cond_code)
951
+
| Some cond ->
952
+
let delivery =
953
+
if (b1 lsr 2) land 0x1 = 0 then Data_complete
954
+
else Data_incomplete
955
+
in
956
+
let status =
957
+
match b1 land 0x3 with
958
+
| 0 -> Discarded_deliberately
959
+
| 1 -> Discarded_filestore_rejection
960
+
| 2 -> Retained_successfully
961
+
| _ -> Status_unreported
962
+
in
963
+
Ok
964
+
( Finished
965
+
{
966
+
condition = cond;
967
+
delivery_code = delivery;
968
+
file_status = status;
969
+
filestore_responses = [];
970
+
fault_location = None;
971
+
},
972
+
2 ))
973
+
| Some Dir_ack -> (
974
+
if len < 3 then Error (Truncated { need = 3; have = len })
975
+
else
976
+
let b1 = Char.code buf.[off + 1] in
977
+
let dir_code = (b1 lsr 4) land 0xF in
978
+
let sub = b1 land 0xF in
979
+
let b2 = Char.code buf.[off + 2] in
980
+
let cond_code = (b2 lsr 4) land 0xF in
981
+
let tx_status = b2 land 0x3 in
982
+
match (directive_code_of_int dir_code, condition_of_int cond_code) with
983
+
| None, _ -> Error (Invalid_directive_code dir_code)
984
+
| _, None -> Error (Invalid_condition_code cond_code)
985
+
| Some dc, Some cond ->
986
+
let status =
987
+
match tx_status with
988
+
| 0 -> Tx_undefined
989
+
| 1 -> Tx_active
990
+
| 2 -> Tx_terminated
991
+
| _ -> Tx_unrecognized
992
+
in
993
+
Ok
994
+
( Ack
995
+
{
996
+
directive = dc;
997
+
subtype = sub;
998
+
condition = cond;
999
+
transaction_status = status;
1000
+
},
1001
+
3 ))
1002
+
| Some Dir_metadata -> (
1003
+
let fss_len = if large_file then 8 else 4 in
1004
+
let min_len = 1 + 1 + fss_len + 2 in
1005
+
if len < min_len then Error (Truncated { need = min_len; have = len })
1006
+
else
1007
+
let b1 = Char.code buf.[off + 1] in
1008
+
let closure = (b1 lsr 6) land 0x1 = 1 in
1009
+
let cksum_type = b1 land 0xF in
1010
+
match checksum_type_of_int cksum_type with
1011
+
| None -> Error (Invalid_checksum_type cksum_type)
1012
+
| Some ctype ->
1013
+
let fsize, fss_consumed = decode_fss buf (off + 2) ~large_file in
1014
+
let off2 = off + 2 + fss_consumed in
1015
+
let* src, src_consumed = decode_lv buf off2 in
1016
+
let off3 = off2 + src_consumed in
1017
+
let* dst, dst_consumed = decode_lv buf off3 in
1018
+
let off4 = off3 + dst_consumed in
1019
+
Ok
1020
+
( Metadata
1021
+
{
1022
+
closure_requested = closure;
1023
+
checksum_type = ctype;
1024
+
file_size = fsize;
1025
+
source_filename = src;
1026
+
dest_filename = dst;
1027
+
filestore_requests = [];
1028
+
messages_to_user = [];
1029
+
},
1030
+
off4 - off ))
1031
+
| Some Dir_nak ->
1032
+
let fss_len = if large_file then 8 else 4 in
1033
+
let min_len = 1 + (2 * fss_len) in
1034
+
if len < min_len then Error (Truncated { need = min_len; have = len })
1035
+
else
1036
+
let sscope, _ = decode_fss buf (off + 1) ~large_file in
1037
+
let escope, _ = decode_fss buf (off + 1 + fss_len) ~large_file in
1038
+
let remaining = len - (1 + (2 * fss_len)) in
1039
+
let seg_count = remaining / (2 * fss_len) in
1040
+
let segs = ref [] in
1041
+
let curr_off = ref (off + 1 + (2 * fss_len)) in
1042
+
for _ = 1 to seg_count do
1043
+
let soff, _ = decode_fss buf !curr_off ~large_file in
1044
+
let eoff, _ = decode_fss buf (!curr_off + fss_len) ~large_file in
1045
+
segs := { start_offset = soff; end_offset = eoff } :: !segs;
1046
+
curr_off := !curr_off + (2 * fss_len)
1047
+
done;
1048
+
Ok
1049
+
( Nak
1050
+
{
1051
+
start_scope = sscope;
1052
+
end_scope = escope;
1053
+
segments = List.rev !segs;
1054
+
},
1055
+
!curr_off - off )
1056
+
| Some Dir_prompt ->
1057
+
if len < 2 then Error (Truncated { need = 2; have = len })
1058
+
else
1059
+
let b1 = Char.code buf.[off + 1] in
1060
+
let resp =
1061
+
if b1 land 0x80 = 0 then Prompt_nak else Prompt_keep_alive
1062
+
in
1063
+
Ok (Prompt { response = resp }, 2)
1064
+
| Some Dir_keep_alive ->
1065
+
let fss_len = if large_file then 8 else 4 in
1066
+
if len < 1 + fss_len then
1067
+
Error (Truncated { need = 1 + fss_len; have = len })
1068
+
else
1069
+
let prog, _ = decode_fss buf (off + 1) ~large_file in
1070
+
Ok (Keep_alive { progress = prog }, 1 + fss_len)
1071
+
1072
+
let decode_continuation b0 =
1073
+
match (b0 lsr 6) land 0x3 with
1074
+
| 0 -> No_record_boundary
1075
+
| 1 -> Record_start
1076
+
| 2 -> Record_end
1077
+
| _ -> Complete_record
1078
+
1079
+
let decode_file_data ~large_file ~segment_metadata:seg_meta_flag buf off
1080
+
data_len =
1081
+
let buf_len = String.length buf in
1082
+
let fss_len = if large_file then 8 else 4 in
1083
+
if off < 0 || off > buf_len then truncated ~need:1 ~have:0
1084
+
else if data_len < 0 then truncated ~need:0 ~have:data_len
1085
+
else
1086
+
let cont, seg_meta, meta_consumed =
1087
+
if seg_meta_flag && data_len >= 1 && off < buf_len then
1088
+
let b0 = Char.code buf.[off] in
1089
+
let cont = Some (decode_continuation b0) in
1090
+
let meta_len = b0 land 0x3F in
1091
+
let meta_off = off + 1 in
1092
+
if meta_len > 0 && meta_off + meta_len <= buf_len then
1093
+
(cont, Some (Bytes.of_string (String.sub buf meta_off meta_len)), 1 + meta_len)
1094
+
else (cont, None, 1)
1095
+
else (None, None, 0)
1096
+
in
1097
+
let off_after_meta = off + meta_consumed in
1098
+
let remaining = data_len - meta_consumed in
1099
+
if remaining < fss_len then truncated ~need:fss_len ~have:remaining
1100
+
else if off_after_meta + fss_len > buf_len then
1101
+
truncated ~need:fss_len ~have:(buf_len - off_after_meta)
1102
+
else
1103
+
let foff, _ = decode_fss buf off_after_meta ~large_file in
1104
+
let data_start = off_after_meta + fss_len in
1105
+
let data_len_actual = data_len - (data_start - off) in
1106
+
if data_start + data_len_actual > buf_len then
1107
+
truncated ~need:data_len_actual ~have:(buf_len - data_start)
1108
+
else
1109
+
let fdata = Bytes.of_string (String.sub buf data_start data_len_actual) in
1110
+
Ok
1111
+
( {
1112
+
continuation = cont;
1113
+
segment_metadata = seg_meta;
1114
+
offset = foff;
1115
+
data = fdata;
1116
+
},
1117
+
data_len )
1118
+
1119
+
let decode buf =
1120
+
let* header, _config, hdr_consumed = decode_header buf in
1121
+
let data_off = hdr_consumed in
1122
+
let total_len = hdr_consumed + header.data_len in
1123
+
let crc_len = if header.crc_present then 2 else 0 in
1124
+
let buf_len = String.length buf in
1125
+
if buf_len < total_len + crc_len then
1126
+
truncated ~need:(total_len + crc_len) ~have:buf_len
1127
+
else begin
1128
+
(* Verify CRC if present *)
1129
+
if header.crc_present then begin
1130
+
let expected = crc16_ccitt_sub (Bytes.of_string buf) 0 total_len in
1131
+
let actual = get_u16_be buf total_len in
1132
+
if expected <> actual then
1133
+
Error (Crc_mismatch { expected; actual })
1134
+
else
1135
+
match header.pdu_type with
1136
+
| File_directive ->
1137
+
let* dir, _ = decode_directive ~large_file:header.large_file buf data_off in
1138
+
Ok (Pdu_directive (header, dir), total_len + crc_len)
1139
+
| File_data ->
1140
+
let* fd, _ =
1141
+
decode_file_data ~large_file:header.large_file
1142
+
~segment_metadata:header.segment_metadata buf data_off
1143
+
header.data_len
1144
+
in
1145
+
Ok (Pdu_file_data (header, fd), total_len + crc_len)
1146
+
end
1147
+
else
1148
+
match header.pdu_type with
1149
+
| File_directive ->
1150
+
let* dir, _ = decode_directive ~large_file:header.large_file buf data_off in
1151
+
Ok (Pdu_directive (header, dir), total_len)
1152
+
| File_data ->
1153
+
let* fd, _ =
1154
+
decode_file_data ~large_file:header.large_file
1155
+
~segment_metadata:header.segment_metadata buf data_off
1156
+
header.data_len
1157
+
in
1158
+
Ok (Pdu_file_data (header, fd), total_len)
1159
+
end
1160
+
1161
+
(* {1 State Machines} *)
1162
+
1163
+
type timer_id =
1164
+
| Timer_nak
1165
+
| Timer_eof
1166
+
| Timer_finished
1167
+
| Timer_inactivity
1168
+
| Timer_keep_alive
1169
+
1170
+
type indication =
1171
+
| Ind_transaction_started of transaction_id
1172
+
| Ind_eof_sent of transaction_id
1173
+
| Ind_transaction_finished of transaction_id * condition
1174
+
| Ind_metadata_recv of transaction_id * metadata
1175
+
| Ind_file_segment_recv of transaction_id * int64 * int
1176
+
| Ind_suspended of transaction_id * condition
1177
+
| Ind_resumed of transaction_id
1178
+
| Ind_fault of transaction_id * condition
1179
+
1180
+
type put_request = {
1181
+
dest_entity : entity_id;
1182
+
source_filename : string;
1183
+
dest_filename : string;
1184
+
transmission_mode : transmission_mode;
1185
+
closure_requested : bool;
1186
+
filestore_requests : filestore_request list;
1187
+
messages_to_user : bytes list;
1188
+
}
1189
+
1190
+
let put_request ?(transmission_mode = Unacknowledged)
1191
+
?(closure_requested = false) ?(filestore_requests = [])
1192
+
?(messages_to_user = []) ~dest_entity ~source_filename ~dest_filename () =
1193
+
{
1194
+
dest_entity;
1195
+
source_filename;
1196
+
dest_filename;
1197
+
transmission_mode;
1198
+
closure_requested;
1199
+
filestore_requests;
1200
+
messages_to_user;
1201
+
}
1202
+
1203
+
(* {2 Class 1 Sender} *)
1204
+
1205
+
module Sender1 = struct
1206
+
type state = S1_idle | S2_sending | S3_eof_sent
1207
+
1208
+
type t = {
1209
+
state : state;
1210
+
local_entity : entity_id;
1211
+
next_seq : int64;
1212
+
transaction : transaction_id option;
1213
+
dest_entity : entity_id option;
1214
+
file_size : int64;
1215
+
progress : int64;
1216
+
checksum : int32;
1217
+
closure_requested : bool;
1218
+
source_filename : string;
1219
+
dest_filename : string;
1220
+
}
1221
+
1222
+
type event =
1223
+
| Ev_put_request of put_request * int64 * (int64 -> bytes)
1224
+
| Ev_segment_sent of int64
1225
+
| Ev_eof_sent
1226
+
| Ev_finished_recv of finished
1227
+
| Ev_cancel
1228
+
| Ev_fault of condition
1229
+
1230
+
type action =
1231
+
| Act_send_metadata of metadata
1232
+
| Act_send_file_data of file_data
1233
+
| Act_send_eof of eof
1234
+
| Act_finished of condition
1235
+
| Act_indication of indication
1236
+
1237
+
let initial local_entity =
1238
+
{
1239
+
state = S1_idle;
1240
+
local_entity;
1241
+
next_seq = 1L;
1242
+
transaction = None;
1243
+
dest_entity = None;
1244
+
file_size = 0L;
1245
+
progress = 0L;
1246
+
checksum = 0l;
1247
+
closure_requested = false;
1248
+
source_filename = "";
1249
+
dest_filename = "";
1250
+
}
1251
+
1252
+
let state t = t.state
1253
+
let transaction_id t = t.transaction
1254
+
1255
+
let step t ev =
1256
+
match (t.state, ev) with
1257
+
| S1_idle, Ev_put_request (req, fsize, _reader) ->
1258
+
let tid = { source = t.local_entity; seq_nr = t.next_seq } in
1259
+
let meta =
1260
+
metadata ~closure_requested:req.closure_requested ~file_size:fsize
1261
+
~source_filename:req.source_filename
1262
+
~dest_filename:req.dest_filename
1263
+
~filestore_requests:req.filestore_requests
1264
+
~messages_to_user:req.messages_to_user ()
1265
+
in
1266
+
let t' =
1267
+
{
1268
+
t with
1269
+
state = S2_sending;
1270
+
next_seq = Int64.succ t.next_seq;
1271
+
transaction = Some tid;
1272
+
dest_entity = Some req.dest_entity;
1273
+
file_size = fsize;
1274
+
progress = 0L;
1275
+
checksum = 0l;
1276
+
closure_requested = req.closure_requested;
1277
+
source_filename = req.source_filename;
1278
+
dest_filename = req.dest_filename;
1279
+
}
1280
+
in
1281
+
( t',
1282
+
[
1283
+
Act_send_metadata meta; Act_indication (Ind_transaction_started tid);
1284
+
] )
1285
+
| S2_sending, Ev_segment_sent new_progress ->
1286
+
let t' = { t with progress = new_progress } in
1287
+
if new_progress >= t.file_size then
1288
+
let eof_pdu =
1289
+
eof ~condition:No_error ~checksum:t.checksum ~file_size:t.file_size
1290
+
()
1291
+
in
1292
+
(t', [ Act_send_eof eof_pdu ])
1293
+
else (t', [])
1294
+
| S2_sending, Ev_eof_sent ->
1295
+
let tid = Option.get t.transaction in
1296
+
let t' = { t with state = S3_eof_sent } in
1297
+
if t.closure_requested then (t', [ Act_indication (Ind_eof_sent tid) ])
1298
+
else
1299
+
let t'' = { t' with state = S1_idle; transaction = None } in
1300
+
( t'',
1301
+
[
1302
+
Act_finished No_error;
1303
+
Act_indication (Ind_transaction_finished (tid, No_error));
1304
+
] )
1305
+
| S3_eof_sent, Ev_finished_recv fin ->
1306
+
let tid = Option.get t.transaction in
1307
+
let t' = { t with state = S1_idle; transaction = None } in
1308
+
( t',
1309
+
[
1310
+
Act_finished fin.condition;
1311
+
Act_indication (Ind_transaction_finished (tid, fin.condition));
1312
+
] )
1313
+
| _, Ev_cancel -> (
1314
+
let cond = Cancel_received in
1315
+
match t.transaction with
1316
+
| Some tid ->
1317
+
let eof_pdu =
1318
+
eof ~condition:cond ~checksum:t.checksum ~file_size:t.progress
1319
+
~fault_location:t.local_entity ()
1320
+
in
1321
+
let t' = { t with state = S1_idle; transaction = None } in
1322
+
( t',
1323
+
[
1324
+
Act_send_eof eof_pdu;
1325
+
Act_finished cond;
1326
+
Act_indication (Ind_transaction_finished (tid, cond));
1327
+
] )
1328
+
| None -> (t, []))
1329
+
| _, Ev_fault cond -> (
1330
+
match t.transaction with
1331
+
| Some tid ->
1332
+
let eof_pdu =
1333
+
eof ~condition:cond ~checksum:t.checksum ~file_size:t.progress
1334
+
~fault_location:t.local_entity ()
1335
+
in
1336
+
let t' = { t with state = S1_idle; transaction = None } in
1337
+
( t',
1338
+
[
1339
+
Act_send_eof eof_pdu;
1340
+
Act_finished cond;
1341
+
Act_indication (Ind_fault (tid, cond));
1342
+
] )
1343
+
| None -> (t, []))
1344
+
| _ -> (t, [])
1345
+
1346
+
let dest t = t.dest_entity
1347
+
let filenames t = (t.source_filename, t.dest_filename)
1348
+
1349
+
let pp fmt t =
1350
+
Format.fprintf fmt "Sender1{state=%s; tid=%a; dest=%a; file=%s->%s}"
1351
+
(match t.state with
1352
+
| S1_idle -> "Idle"
1353
+
| S2_sending -> "Sending"
1354
+
| S3_eof_sent -> "EOF_sent")
1355
+
(Fmt.option pp_transaction_id)
1356
+
t.transaction (Fmt.option Entity_id.pp) t.dest_entity t.source_filename
1357
+
t.dest_filename
1358
+
end
1359
+
1360
+
(* {2 Class 2 Sender} *)
1361
+
1362
+
module Sender2 = struct
1363
+
type state = S1_idle | S2_sending | S3_eof_sent | S4_eof_acked
1364
+
1365
+
type t = {
1366
+
state : state;
1367
+
local_entity : entity_id;
1368
+
next_seq : int64;
1369
+
transaction : transaction_id option;
1370
+
dest_entity : entity_id option;
1371
+
file_size : int64;
1372
+
progress : int64;
1373
+
checksum : int32;
1374
+
eof_retry_count : int;
1375
+
nak_pending : segment_request list;
1376
+
source_filename : string;
1377
+
dest_filename : string;
1378
+
}
1379
+
1380
+
type event =
1381
+
| Ev_put_request of put_request * int64 * (int64 -> bytes)
1382
+
| Ev_segment_sent of int64
1383
+
| Ev_eof_sent
1384
+
| Ev_ack_recv of ack
1385
+
| Ev_nak_recv of nak
1386
+
| Ev_finished_recv of finished
1387
+
| Ev_timer_expired of timer_id
1388
+
| Ev_cancel
1389
+
| Ev_fault of condition
1390
+
1391
+
type action =
1392
+
| Act_send_metadata of metadata
1393
+
| Act_send_file_data of file_data
1394
+
| Act_send_eof of eof
1395
+
| Act_send_ack of ack
1396
+
| Act_start_timer of timer_id * Duration.t
1397
+
| Act_cancel_timer of timer_id
1398
+
| Act_finished of condition
1399
+
| Act_indication of indication
1400
+
1401
+
let initial local_entity =
1402
+
{
1403
+
state = S1_idle;
1404
+
local_entity;
1405
+
next_seq = 1L;
1406
+
transaction = None;
1407
+
dest_entity = None;
1408
+
file_size = 0L;
1409
+
progress = 0L;
1410
+
checksum = 0l;
1411
+
eof_retry_count = 0;
1412
+
nak_pending = [];
1413
+
source_filename = "";
1414
+
dest_filename = "";
1415
+
}
1416
+
1417
+
let state t = t.state
1418
+
let transaction_id t = t.transaction
1419
+
1420
+
let step t ev =
1421
+
match (t.state, ev) with
1422
+
| S1_idle, Ev_put_request (req, fsize, _reader) ->
1423
+
let tid = { source = t.local_entity; seq_nr = t.next_seq } in
1424
+
let meta =
1425
+
metadata ~closure_requested:false
1426
+
~file_size:fsize ~source_filename:req.source_filename
1427
+
~dest_filename:req.dest_filename
1428
+
~filestore_requests:req.filestore_requests
1429
+
~messages_to_user:req.messages_to_user ()
1430
+
in
1431
+
let t' =
1432
+
{
1433
+
t with
1434
+
state = S2_sending;
1435
+
next_seq = Int64.succ t.next_seq;
1436
+
transaction = Some tid;
1437
+
dest_entity = Some req.dest_entity;
1438
+
file_size = fsize;
1439
+
progress = 0L;
1440
+
checksum = 0l;
1441
+
eof_retry_count = 0;
1442
+
nak_pending = [];
1443
+
source_filename = req.source_filename;
1444
+
dest_filename = req.dest_filename;
1445
+
}
1446
+
in
1447
+
( t',
1448
+
[
1449
+
Act_send_metadata meta; Act_indication (Ind_transaction_started tid);
1450
+
] )
1451
+
| S2_sending, Ev_segment_sent new_progress ->
1452
+
let t' = { t with progress = new_progress } in
1453
+
if new_progress >= t.file_size then
1454
+
let eof_pdu =
1455
+
eof ~condition:No_error ~checksum:t.checksum ~file_size:t.file_size
1456
+
()
1457
+
in
1458
+
(t', [ Act_send_eof eof_pdu ])
1459
+
else (t', [])
1460
+
| S2_sending, Ev_eof_sent ->
1461
+
let tid = Option.get t.transaction in
1462
+
let t' = { t with state = S3_eof_sent } in
1463
+
( t',
1464
+
[
1465
+
Act_start_timer (Timer_eof, Duration.of_sec 10.);
1466
+
Act_indication (Ind_eof_sent tid);
1467
+
] )
1468
+
| S3_eof_sent, Ev_ack_recv ack_pdu when ack_pdu.directive = Dir_eof ->
1469
+
let t' = { t with state = S4_eof_acked } in
1470
+
(t', [ Act_cancel_timer Timer_eof ])
1471
+
| S3_eof_sent, Ev_timer_expired Timer_eof ->
1472
+
if t.eof_retry_count >= 3 then
1473
+
let cond = Positive_ack_limit in
1474
+
let tid = Option.get t.transaction in
1475
+
let t' = { t with state = S1_idle; transaction = None } in
1476
+
(t', [ Act_finished cond; Act_indication (Ind_fault (tid, cond)) ])
1477
+
else
1478
+
let eof_pdu =
1479
+
eof ~condition:No_error ~checksum:t.checksum ~file_size:t.file_size
1480
+
()
1481
+
in
1482
+
let t' = { t with eof_retry_count = t.eof_retry_count + 1 } in
1483
+
( t',
1484
+
[
1485
+
Act_send_eof eof_pdu;
1486
+
Act_start_timer (Timer_eof, Duration.of_sec 10.);
1487
+
] )
1488
+
| (S3_eof_sent | S4_eof_acked), Ev_nak_recv nak_pdu ->
1489
+
let t' = { t with nak_pending = nak_pdu.segments } in
1490
+
(t', [])
1491
+
| S4_eof_acked, Ev_finished_recv fin ->
1492
+
let tid = Option.get t.transaction in
1493
+
let ack_pdu =
1494
+
ack ~directive:Dir_finished ~subtype:1 ~condition:fin.condition
1495
+
~transaction_status:Tx_active
1496
+
in
1497
+
let t' = { t with state = S1_idle; transaction = None } in
1498
+
( t',
1499
+
[
1500
+
Act_send_ack ack_pdu;
1501
+
Act_finished fin.condition;
1502
+
Act_indication (Ind_transaction_finished (tid, fin.condition));
1503
+
] )
1504
+
| _, Ev_cancel -> (
1505
+
let cond = Cancel_received in
1506
+
match t.transaction with
1507
+
| Some tid ->
1508
+
let eof_pdu =
1509
+
eof ~condition:cond ~checksum:t.checksum ~file_size:t.progress
1510
+
~fault_location:t.local_entity ()
1511
+
in
1512
+
let t' = { t with state = S1_idle; transaction = None } in
1513
+
( t',
1514
+
[
1515
+
Act_send_eof eof_pdu;
1516
+
Act_finished cond;
1517
+
Act_indication (Ind_transaction_finished (tid, cond));
1518
+
] )
1519
+
| None -> (t, []))
1520
+
| _, Ev_fault cond -> (
1521
+
match t.transaction with
1522
+
| Some tid ->
1523
+
let t' = { t with state = S1_idle; transaction = None } in
1524
+
(t', [ Act_finished cond; Act_indication (Ind_fault (tid, cond)) ])
1525
+
| None -> (t, []))
1526
+
| _ -> (t, [])
1527
+
1528
+
let dest t = t.dest_entity
1529
+
let filenames t = (t.source_filename, t.dest_filename)
1530
+
let pending_retransmits t = t.nak_pending
1531
+
1532
+
let pp fmt t =
1533
+
Format.fprintf fmt
1534
+
"Sender2{state=%s; tid=%a; dest=%a; file=%s->%s; pending=%d}"
1535
+
(match t.state with
1536
+
| S1_idle -> "Idle"
1537
+
| S2_sending -> "Sending"
1538
+
| S3_eof_sent -> "EOF_sent"
1539
+
| S4_eof_acked -> "EOF_acked")
1540
+
(Fmt.option pp_transaction_id)
1541
+
t.transaction (Fmt.option Entity_id.pp) t.dest_entity t.source_filename
1542
+
t.dest_filename
1543
+
(List.length t.nak_pending)
1544
+
end
1545
+
1546
+
(* {2 Class 1 Receiver} *)
1547
+
1548
+
module Receiver1 = struct
1549
+
type state = R1_idle | R2_receiving | R3_complete
1550
+
1551
+
type t = {
1552
+
state : state;
1553
+
local_entity : entity_id;
1554
+
transaction : transaction_id option;
1555
+
expected_file_size : int64;
1556
+
received_bytes : int64;
1557
+
checksum : int32;
1558
+
checksum_type : checksum_type;
1559
+
closure_requested : bool;
1560
+
dest_filename : string;
1561
+
}
1562
+
1563
+
type event =
1564
+
| Ev_metadata_recv of header * metadata
1565
+
| Ev_file_data_recv of header * file_data
1566
+
| Ev_eof_recv of header * eof
1567
+
| Ev_cancel
1568
+
| Ev_inactivity_timeout
1569
+
1570
+
type action =
1571
+
| Act_store_data of int64 * bytes
1572
+
| Act_send_finished of finished
1573
+
| Act_deliver_file of string * int64 * int32
1574
+
| Act_finished of condition
1575
+
| Act_indication of indication
1576
+
1577
+
let initial local_entity =
1578
+
{
1579
+
state = R1_idle;
1580
+
local_entity;
1581
+
transaction = None;
1582
+
expected_file_size = 0L;
1583
+
received_bytes = 0L;
1584
+
checksum = 0l;
1585
+
checksum_type = Checksum_modular;
1586
+
closure_requested = false;
1587
+
dest_filename = "";
1588
+
}
1589
+
1590
+
let state t = t.state
1591
+
let transaction_id t = t.transaction
1592
+
let local_entity t = t.local_entity
1593
+
let expected_size t = t.expected_file_size
1594
+
let computed_checksum t = t.checksum
1595
+
1596
+
let step t ev =
1597
+
match (t.state, ev) with
1598
+
| R1_idle, Ev_metadata_recv (hdr, meta) ->
1599
+
if not (Entity_id.equal hdr.dest_entity t.local_entity) then (t, [])
1600
+
else
1601
+
let tid =
1602
+
{ source = hdr.source_entity; seq_nr = hdr.transaction_seq }
1603
+
in
1604
+
let t' =
1605
+
{
1606
+
t with
1607
+
state = R2_receiving;
1608
+
transaction = Some tid;
1609
+
expected_file_size = meta.file_size;
1610
+
received_bytes = 0L;
1611
+
checksum = 0l;
1612
+
checksum_type = meta.checksum_type;
1613
+
closure_requested = meta.closure_requested;
1614
+
dest_filename = meta.dest_filename;
1615
+
}
1616
+
in
1617
+
(t', [ Act_indication (Ind_metadata_recv (tid, meta)) ])
1618
+
| R2_receiving, Ev_file_data_recv (hdr, fd) ->
1619
+
let tid =
1620
+
{ source = hdr.source_entity; seq_nr = hdr.transaction_seq }
1621
+
in
1622
+
let data_len = Bytes.length fd.data in
1623
+
let data_checksum = compute_checksum t.checksum_type fd.data in
1624
+
let new_checksum = Int32.add t.checksum data_checksum in
1625
+
let t' =
1626
+
{
1627
+
t with
1628
+
received_bytes = Int64.add t.received_bytes (Int64.of_int data_len);
1629
+
checksum = new_checksum;
1630
+
}
1631
+
in
1632
+
( t',
1633
+
[
1634
+
Act_store_data (fd.offset, fd.data);
1635
+
Act_indication (Ind_file_segment_recv (tid, fd.offset, data_len));
1636
+
] )
1637
+
| R2_receiving, Ev_eof_recv (hdr, eof_pdu) ->
1638
+
let tid =
1639
+
{ source = hdr.source_entity; seq_nr = hdr.transaction_seq }
1640
+
in
1641
+
let size_ok = t.received_bytes >= t.expected_file_size in
1642
+
let checksum_ok = Int32.equal t.checksum eof_pdu.checksum in
1643
+
let cond =
1644
+
if size_ok && checksum_ok then No_error else File_checksum_failure
1645
+
in
1646
+
let delivery = if size_ok then Data_complete else Data_incomplete in
1647
+
let t' = { t with state = R3_complete } in
1648
+
if t.closure_requested then
1649
+
let fin =
1650
+
finished ~condition:cond ~delivery_code:delivery
1651
+
~file_status:
1652
+
(if cond = No_error then Retained_successfully
1653
+
else Discarded_deliberately)
1654
+
?fault_location:
1655
+
(if cond = No_error then None else Some t.local_entity)
1656
+
()
1657
+
in
1658
+
( t',
1659
+
[
1660
+
Act_deliver_file
1661
+
(t.dest_filename, eof_pdu.file_size, eof_pdu.checksum);
1662
+
Act_send_finished fin;
1663
+
Act_finished cond;
1664
+
Act_indication (Ind_transaction_finished (tid, cond));
1665
+
] )
1666
+
else
1667
+
let t'' = { t' with state = R1_idle; transaction = None } in
1668
+
( t'',
1669
+
[
1670
+
Act_deliver_file
1671
+
(t.dest_filename, eof_pdu.file_size, eof_pdu.checksum);
1672
+
Act_finished cond;
1673
+
Act_indication (Ind_transaction_finished (tid, cond));
1674
+
] )
1675
+
| _, Ev_cancel -> (
1676
+
match t.transaction with
1677
+
| Some tid ->
1678
+
let t' = { t with state = R1_idle; transaction = None } in
1679
+
( t',
1680
+
[
1681
+
Act_finished Cancel_received;
1682
+
Act_indication (Ind_transaction_finished (tid, Cancel_received));
1683
+
] )
1684
+
| None -> (t, []))
1685
+
| _, Ev_inactivity_timeout -> (
1686
+
match t.transaction with
1687
+
| Some tid ->
1688
+
let t' = { t with state = R1_idle; transaction = None } in
1689
+
( t',
1690
+
[
1691
+
Act_finished Inactivity_detected;
1692
+
Act_indication (Ind_fault (tid, Inactivity_detected));
1693
+
] )
1694
+
| None -> (t, []))
1695
+
| _ -> (t, [])
1696
+
1697
+
let pp fmt t =
1698
+
Format.fprintf fmt
1699
+
"Receiver1{state=%s; tid=%a; entity=%a; size=%Ld/%Ld; csum=0x%08lx}"
1700
+
(match t.state with
1701
+
| R1_idle -> "Idle"
1702
+
| R2_receiving -> "Receiving"
1703
+
| R3_complete -> "Complete")
1704
+
(Fmt.option pp_transaction_id)
1705
+
t.transaction Entity_id.pp t.local_entity t.received_bytes
1706
+
t.expected_file_size t.checksum
1707
+
end
1708
+
1709
+
(* {2 Class 2 Receiver} *)
1710
+
1711
+
module Receiver2 = struct
1712
+
type state = R1_idle | R2_receiving | R3_eof_received | R4_complete
1713
+
1714
+
type t = {
1715
+
state : state;
1716
+
local_entity : entity_id;
1717
+
transaction : transaction_id option;
1718
+
expected_file_size : int64;
1719
+
received_bytes : int64;
1720
+
checksum : int32;
1721
+
checksum_type : checksum_type;
1722
+
gaps : (int64 * int64) list;
1723
+
nak_retry_count : int;
1724
+
finished_retry_count : int;
1725
+
dest_filename : string;
1726
+
}
1727
+
1728
+
type event =
1729
+
| Ev_metadata_recv of header * metadata
1730
+
| Ev_file_data_recv of header * file_data
1731
+
| Ev_eof_recv of header * eof
1732
+
| Ev_ack_recv of ack
1733
+
| Ev_prompt_recv of prompt
1734
+
| Ev_timer_expired of timer_id
1735
+
| Ev_cancel
1736
+
| Ev_inactivity_timeout
1737
+
1738
+
type action =
1739
+
| Act_store_data of int64 * bytes
1740
+
| Act_send_nak of nak
1741
+
| Act_send_finished of finished
1742
+
| Act_send_keep_alive of keep_alive
1743
+
| Act_send_ack of ack
1744
+
| Act_start_timer of timer_id * Duration.t
1745
+
| Act_cancel_timer of timer_id
1746
+
| Act_deliver_file of string * int64 * int32
1747
+
| Act_finished of condition
1748
+
| Act_indication of indication
1749
+
1750
+
let initial local_entity =
1751
+
{
1752
+
state = R1_idle;
1753
+
local_entity;
1754
+
transaction = None;
1755
+
expected_file_size = 0L;
1756
+
received_bytes = 0L;
1757
+
checksum = 0l;
1758
+
checksum_type = Checksum_modular;
1759
+
gaps = [];
1760
+
nak_retry_count = 0;
1761
+
finished_retry_count = 0;
1762
+
dest_filename = "";
1763
+
}
1764
+
1765
+
let state t = t.state
1766
+
let transaction_id t = t.transaction
1767
+
let local_entity t = t.local_entity
1768
+
let expected_size t = t.expected_file_size
1769
+
let computed_checksum t = t.checksum
1770
+
1771
+
let step t ev =
1772
+
match (t.state, ev) with
1773
+
| R1_idle, Ev_metadata_recv (hdr, meta) ->
1774
+
if not (Entity_id.equal hdr.dest_entity t.local_entity) then (t, [])
1775
+
else
1776
+
let tid =
1777
+
{ source = hdr.source_entity; seq_nr = hdr.transaction_seq }
1778
+
in
1779
+
let t' =
1780
+
{
1781
+
t with
1782
+
state = R2_receiving;
1783
+
transaction = Some tid;
1784
+
expected_file_size = meta.file_size;
1785
+
received_bytes = 0L;
1786
+
checksum = 0l;
1787
+
checksum_type = meta.checksum_type;
1788
+
gaps = [];
1789
+
nak_retry_count = 0;
1790
+
finished_retry_count = 0;
1791
+
dest_filename = meta.dest_filename;
1792
+
}
1793
+
in
1794
+
( t',
1795
+
[
1796
+
Act_indication (Ind_metadata_recv (tid, meta));
1797
+
Act_start_timer (Timer_inactivity, Duration.of_sec 30.);
1798
+
] )
1799
+
| R2_receiving, Ev_file_data_recv (hdr, fd) ->
1800
+
let tid =
1801
+
{ source = hdr.source_entity; seq_nr = hdr.transaction_seq }
1802
+
in
1803
+
let data_len = Bytes.length fd.data in
1804
+
let data_checksum = compute_checksum t.checksum_type fd.data in
1805
+
let new_checksum = Int32.add t.checksum data_checksum in
1806
+
let t' =
1807
+
{
1808
+
t with
1809
+
received_bytes = Int64.add t.received_bytes (Int64.of_int data_len);
1810
+
checksum = new_checksum;
1811
+
}
1812
+
in
1813
+
( t',
1814
+
[
1815
+
Act_store_data (fd.offset, fd.data);
1816
+
Act_indication (Ind_file_segment_recv (tid, fd.offset, data_len));
1817
+
Act_start_timer (Timer_inactivity, Duration.of_sec 30.);
1818
+
] )
1819
+
| R2_receiving, Ev_eof_recv (hdr, eof_pdu) ->
1820
+
let tid =
1821
+
{ source = hdr.source_entity; seq_nr = hdr.transaction_seq }
1822
+
in
1823
+
let ack_pdu =
1824
+
ack ~directive:Dir_eof ~subtype:0 ~condition:eof_pdu.condition
1825
+
~transaction_status:Tx_active
1826
+
in
1827
+
if t.gaps = [] then begin
1828
+
let fin =
1829
+
finished ~condition:No_error ~delivery_code:Data_complete
1830
+
~file_status:Retained_successfully ()
1831
+
in
1832
+
let t' = { t with state = R4_complete } in
1833
+
( t',
1834
+
[
1835
+
Act_send_ack ack_pdu;
1836
+
Act_deliver_file
1837
+
(t.dest_filename, eof_pdu.file_size, eof_pdu.checksum);
1838
+
Act_send_finished fin;
1839
+
Act_start_timer (Timer_finished, Duration.of_sec 10.);
1840
+
Act_indication (Ind_transaction_finished (tid, No_error));
1841
+
] )
1842
+
end
1843
+
else begin
1844
+
let segs = List.map (fun (s, e) -> segment_request s e) t.gaps in
1845
+
let nak_pdu = nak ~start_scope:0L ~end_scope:eof_pdu.file_size segs in
1846
+
let t' = { t with state = R3_eof_received } in
1847
+
( t',
1848
+
[
1849
+
Act_send_ack ack_pdu;
1850
+
Act_send_nak nak_pdu;
1851
+
Act_start_timer (Timer_nak, Duration.of_sec 10.);
1852
+
] )
1853
+
end
1854
+
| R3_eof_received, Ev_file_data_recv (_hdr, fd) ->
1855
+
let data_len = Bytes.length fd.data in
1856
+
let data_checksum = compute_checksum t.checksum_type fd.data in
1857
+
let new_checksum = Int32.add t.checksum data_checksum in
1858
+
let new_gaps =
1859
+
List.filter
1860
+
(fun (s, e) ->
1861
+
not
1862
+
(fd.offset <= s
1863
+
&& Int64.add fd.offset (Int64.of_int data_len) >= e))
1864
+
t.gaps
1865
+
in
1866
+
let t' =
1867
+
{
1868
+
t with
1869
+
gaps = new_gaps;
1870
+
received_bytes = Int64.add t.received_bytes (Int64.of_int data_len);
1871
+
checksum = new_checksum;
1872
+
}
1873
+
in
1874
+
if new_gaps = [] then begin
1875
+
let tid = Option.get t.transaction in
1876
+
let fin =
1877
+
finished ~condition:No_error ~delivery_code:Data_complete
1878
+
~file_status:Retained_successfully ()
1879
+
in
1880
+
let t'' = { t' with state = R4_complete } in
1881
+
( t'',
1882
+
[
1883
+
Act_store_data (fd.offset, fd.data);
1884
+
Act_cancel_timer Timer_nak;
1885
+
Act_deliver_file
1886
+
(t.dest_filename, t.expected_file_size, t.checksum);
1887
+
Act_send_finished fin;
1888
+
Act_start_timer (Timer_finished, Duration.of_sec 10.);
1889
+
Act_indication (Ind_transaction_finished (tid, No_error));
1890
+
] )
1891
+
end
1892
+
else (t', [ Act_store_data (fd.offset, fd.data) ])
1893
+
| R3_eof_received, Ev_timer_expired Timer_nak ->
1894
+
if t.nak_retry_count >= 3 then
1895
+
let cond = Nak_limit_reached in
1896
+
let tid = Option.get t.transaction in
1897
+
let t' = { t with state = R1_idle; transaction = None } in
1898
+
(t', [ Act_finished cond; Act_indication (Ind_fault (tid, cond)) ])
1899
+
else
1900
+
let segs = List.map (fun (s, e) -> segment_request s e) t.gaps in
1901
+
let nak_pdu =
1902
+
nak ~start_scope:0L ~end_scope:t.expected_file_size segs
1903
+
in
1904
+
let t' = { t with nak_retry_count = t.nak_retry_count + 1 } in
1905
+
( t',
1906
+
[
1907
+
Act_send_nak nak_pdu;
1908
+
Act_start_timer (Timer_nak, Duration.of_sec 10.);
1909
+
] )
1910
+
| R4_complete, Ev_ack_recv ack_pdu when ack_pdu.directive = Dir_finished ->
1911
+
let tid = Option.get t.transaction in
1912
+
let t' = { t with state = R1_idle; transaction = None } in
1913
+
( t',
1914
+
[
1915
+
Act_cancel_timer Timer_finished;
1916
+
Act_finished No_error;
1917
+
Act_indication (Ind_transaction_finished (tid, No_error));
1918
+
] )
1919
+
| R4_complete, Ev_timer_expired Timer_finished ->
1920
+
if t.finished_retry_count >= 3 then
1921
+
let cond = Positive_ack_limit in
1922
+
let tid = Option.get t.transaction in
1923
+
let t' = { t with state = R1_idle; transaction = None } in
1924
+
(t', [ Act_finished cond; Act_indication (Ind_fault (tid, cond)) ])
1925
+
else
1926
+
let fin =
1927
+
finished ~condition:No_error ~delivery_code:Data_complete
1928
+
~file_status:Retained_successfully ()
1929
+
in
1930
+
let t' =
1931
+
{ t with finished_retry_count = t.finished_retry_count + 1 }
1932
+
in
1933
+
( t',
1934
+
[
1935
+
Act_send_finished fin;
1936
+
Act_start_timer (Timer_finished, Duration.of_sec 10.);
1937
+
] )
1938
+
| _, Ev_prompt_recv pmt -> (
1939
+
match pmt.response with
1940
+
| Prompt_keep_alive ->
1941
+
let ka = keep_alive t.received_bytes in
1942
+
(t, [ Act_send_keep_alive ka ])
1943
+
| Prompt_nak when t.gaps <> [] ->
1944
+
let segs = List.map (fun (s, e) -> segment_request s e) t.gaps in
1945
+
let nak_pdu =
1946
+
nak ~start_scope:0L ~end_scope:t.expected_file_size segs
1947
+
in
1948
+
(t, [ Act_send_nak nak_pdu ])
1949
+
| Prompt_nak -> (t, []))
1950
+
| _, Ev_cancel -> (
1951
+
match t.transaction with
1952
+
| Some tid ->
1953
+
let fin =
1954
+
finished ~condition:Cancel_received ~delivery_code:Data_incomplete
1955
+
~file_status:Status_unreported ~fault_location:t.local_entity ()
1956
+
in
1957
+
let t' = { t with state = R1_idle; transaction = None } in
1958
+
( t',
1959
+
[
1960
+
Act_send_finished fin;
1961
+
Act_finished Cancel_received;
1962
+
Act_indication (Ind_transaction_finished (tid, Cancel_received));
1963
+
] )
1964
+
| None -> (t, []))
1965
+
| _, Ev_inactivity_timeout -> (
1966
+
match t.transaction with
1967
+
| Some tid ->
1968
+
let t' = { t with state = R1_idle; transaction = None } in
1969
+
( t',
1970
+
[
1971
+
Act_finished Inactivity_detected;
1972
+
Act_indication (Ind_fault (tid, Inactivity_detected));
1973
+
] )
1974
+
| None -> (t, []))
1975
+
| _ -> (t, [])
1976
+
1977
+
let pp fmt t =
1978
+
Format.fprintf fmt
1979
+
"Receiver2{state=%s; tid=%a; entity=%a; size=%Ld/%Ld; csum=0x%08lx; \
1980
+
gaps=%d}"
1981
+
(match t.state with
1982
+
| R1_idle -> "Idle"
1983
+
| R2_receiving -> "Receiving"
1984
+
| R3_eof_received -> "EOF_recv"
1985
+
| R4_complete -> "Complete")
1986
+
(Fmt.option pp_transaction_id)
1987
+
t.transaction Entity_id.pp t.local_entity t.received_bytes
1988
+
t.expected_file_size t.checksum (List.length t.gaps)
1989
+
end
+615
lib/cfdp.mli
+615
lib/cfdp.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** CCSDS File Delivery Protocol (CCSDS 727.0-B-5).
7
+
8
+
CFDP provides reliable file transfer for space missions with support for:
9
+
- Class 1: Unacknowledged (unreliable) transfers
10
+
- Class 2: Acknowledged (reliable) transfers with NAK-based retransmission
11
+
12
+
{2 PDU Header Format}
13
+
14
+
{v
15
+
Fixed Header (4 bytes minimum):
16
+
+-------+------+-----+------+-----+-------+--------+
17
+
| Ver | Type | Dir | Mode | CRC | Large | PDULen |
18
+
| 3b | 1b | 1b | 1b | 1b | 1b | 16b |
19
+
+-------+------+-----+------+-----+-------+--------+
20
+
| SegCtl| EIDLen| SMF | SeqLen|
21
+
| 1b | 3b | 1b | 3b |
22
+
+-------+-------+-----+-------+
23
+
| Source Entity ID | Variable (1-8 octets) |
24
+
| Transaction Seq Nr | Variable (1-8 octets) |
25
+
| Dest Entity ID | Variable (1-8 octets) |
26
+
+---------------------+---------------------------+
27
+
v}
28
+
29
+
Header size: [4 + 2 * entity_id_len + seq_nr_len] bytes *)
30
+
31
+
(** {1 Duration} *)
32
+
33
+
module Duration : sig
34
+
type t = float
35
+
val of_sec : float -> t
36
+
end
37
+
38
+
(** {1 Entity ID}
39
+
40
+
{b Limitation}: CCSDS 727.0-B-5 section 5.1.4 specifies entity IDs as
41
+
unsigned binary integers of 1-8 bytes (range [0, 2^64-1]). We use OCaml's
42
+
signed [int64] which limits representable values to [0, 2^63-1]. Entity IDs
43
+
>= 2^63 cannot be represented and will be rejected during parsing. This
44
+
covers most practical use cases since missions typically use 1-4 byte entity
45
+
IDs. *)
46
+
47
+
module Entity_id : sig
48
+
type t
49
+
(** Entity identifier (variable length, 1-8 bytes, max 2^63-1). *)
50
+
51
+
val of_int : int -> t option
52
+
(** [of_int n] creates an entity ID from a non-negative integer. *)
53
+
54
+
val of_int_exn : int -> t
55
+
(** [of_int_exn n] creates an entity ID from a non-negative integer.
56
+
@raise Invalid_argument if [n < 0]. *)
57
+
58
+
val of_int64 : int64 -> t option
59
+
(** [of_int64 n] creates an entity ID from a non-negative int64. *)
60
+
61
+
val of_int64_exn : int64 -> t
62
+
(** [of_int64_exn n] creates an entity ID from a non-negative int64.
63
+
@raise Invalid_argument if [n < 0L]. *)
64
+
65
+
val of_int64_unsigned : int64 -> [ `Ok of t | `Overflow ]
66
+
(** [of_int64_unsigned n] creates an entity ID from bytes read as signed
67
+
int64. Returns [`Overflow] if the value >= 2^63 (appears negative due to
68
+
sign bit). Use this when parsing from wire format. *)
69
+
70
+
val to_int64 : t -> int64
71
+
(** [to_int64 eid] returns the entity ID as int64. *)
72
+
73
+
val equal : t -> t -> bool
74
+
val compare : t -> t -> int
75
+
val pp : t Fmt.t
76
+
end
77
+
78
+
type entity_id = Entity_id.t
79
+
(** Alias for {!Entity_id.t}. *)
80
+
81
+
(** {1 Transaction ID} *)
82
+
83
+
type transaction_id = { source : entity_id; seq_nr : int64 }
84
+
(** Transaction identifier = source entity + sequence number. *)
85
+
86
+
val pp_transaction_id : transaction_id Fmt.t
87
+
88
+
(** {1 PDU Configuration} *)
89
+
90
+
type pdu_config = {
91
+
entity_id_len : int; (** Entity ID length in bytes (1-8) *)
92
+
seq_nr_len : int; (** Sequence number length in bytes (1-8) *)
93
+
}
94
+
(** PDU encoding configuration. *)
95
+
96
+
val pdu_config : entity_id_len:int -> seq_nr_len:int -> pdu_config option
97
+
(** [pdu_config ~entity_id_len ~seq_nr_len] creates a PDU config. Returns [None]
98
+
if parameters out of range. *)
99
+
100
+
val default_config : pdu_config
101
+
(** Default config: 2-byte entity IDs, 4-byte sequence numbers. *)
102
+
103
+
(** {1 Enumerations} *)
104
+
105
+
type pdu_type = File_directive | File_data
106
+
type direction = Toward_receiver | Toward_sender
107
+
108
+
type transmission_mode =
109
+
| Acknowledged (** Class 2 - reliable *)
110
+
| Unacknowledged (** Class 1 - unreliable *)
111
+
112
+
type condition =
113
+
| No_error
114
+
| Positive_ack_limit
115
+
| Keep_alive_limit
116
+
| Invalid_transmission_mode
117
+
| Filestore_rejection
118
+
| File_checksum_failure
119
+
| File_size_error
120
+
| Nak_limit_reached
121
+
| Inactivity_detected
122
+
| Invalid_file_structure
123
+
| Check_limit_reached
124
+
| Unsupported_checksum_type
125
+
| Suspend_received
126
+
| Cancel_received
127
+
128
+
val int_of_condition : condition -> int
129
+
val condition_of_int : int -> condition option
130
+
val pp_condition : condition Fmt.t
131
+
132
+
type delivery_code = Data_complete | Data_incomplete
133
+
134
+
type file_status =
135
+
| Discarded_deliberately
136
+
| Discarded_filestore_rejection
137
+
| Retained_successfully
138
+
| Status_unreported
139
+
140
+
type transaction_status =
141
+
| Tx_undefined
142
+
| Tx_active
143
+
| Tx_terminated
144
+
| Tx_unrecognized
145
+
146
+
type record_continuation =
147
+
| No_record_boundary
148
+
| Record_start
149
+
| Record_end
150
+
| Complete_record
151
+
152
+
(** {1 Checksum Types} *)
153
+
154
+
type checksum_type =
155
+
| Checksum_modular (** Type 0: Legacy modular checksum *)
156
+
| Checksum_crc32 (** Type 1: CRC-32 (ISO 3309) *)
157
+
| Checksum_crc32c (** Type 2: CRC-32C (Castagnoli) *)
158
+
| Checksum_null (** Type 15: No checksum *)
159
+
160
+
val int_of_checksum_type : checksum_type -> int
161
+
val checksum_type_of_int : int -> checksum_type option
162
+
val pp_checksum_type : checksum_type Fmt.t
163
+
164
+
val compute_checksum : checksum_type -> bytes -> int32
165
+
(** [compute_checksum typ data] computes checksum over [data]. *)
166
+
167
+
val verify_checksum : checksum_type -> bytes -> int32 -> bool
168
+
(** [verify_checksum typ data expected] verifies checksum. *)
169
+
170
+
(** {1 Directive Codes} *)
171
+
172
+
type directive_code =
173
+
| Dir_eof (** 0x04 *)
174
+
| Dir_finished (** 0x05 *)
175
+
| Dir_ack (** 0x06 *)
176
+
| Dir_metadata (** 0x07 *)
177
+
| Dir_nak (** 0x08 *)
178
+
| Dir_prompt (** 0x09 *)
179
+
| Dir_keep_alive (** 0x0C *)
180
+
181
+
val int_of_directive_code : directive_code -> int
182
+
val directive_code_of_int : int -> directive_code option
183
+
val pp_directive_code : directive_code Fmt.t
184
+
185
+
(** {1 PDU Header} *)
186
+
187
+
type header = {
188
+
version : int; (** Protocol version (1 = CFDP v2) *)
189
+
pdu_type : pdu_type;
190
+
direction : direction;
191
+
transmission_mode : transmission_mode;
192
+
crc_present : bool;
193
+
large_file : bool; (** true = 64-bit offsets *)
194
+
segment_ctrl : bool; (** Record boundaries preserved *)
195
+
segment_metadata : bool; (** Segment metadata present *)
196
+
source_entity : entity_id;
197
+
transaction_seq : int64;
198
+
dest_entity : entity_id;
199
+
data_len : int; (** PDU data field length *)
200
+
}
201
+
(** Fixed PDU header. *)
202
+
203
+
val pp_header : header Fmt.t
204
+
205
+
(** {1 File Directive PDUs} *)
206
+
207
+
(** {2 EOF PDU} *)
208
+
209
+
type eof = {
210
+
condition : condition;
211
+
checksum : int32;
212
+
file_size : int64;
213
+
fault_location : entity_id option;
214
+
}
215
+
216
+
val eof :
217
+
?fault_location:entity_id ->
218
+
condition:condition ->
219
+
checksum:int32 ->
220
+
file_size:int64 ->
221
+
unit ->
222
+
eof
223
+
(** [eof ~condition ~checksum ~file_size ()] creates an EOF PDU. *)
224
+
225
+
val pp_eof : eof Fmt.t
226
+
227
+
(** {2 Finished PDU} *)
228
+
229
+
type filestore_response = {
230
+
action_code : int;
231
+
status_code : int;
232
+
first_filename : string;
233
+
second_filename : string;
234
+
message : string;
235
+
}
236
+
237
+
type finished = {
238
+
condition : condition;
239
+
delivery_code : delivery_code;
240
+
file_status : file_status;
241
+
filestore_responses : filestore_response list;
242
+
fault_location : entity_id option;
243
+
}
244
+
245
+
val finished :
246
+
?filestore_responses:filestore_response list ->
247
+
?fault_location:entity_id ->
248
+
condition:condition ->
249
+
delivery_code:delivery_code ->
250
+
file_status:file_status ->
251
+
unit ->
252
+
finished
253
+
(** [finished ~condition ~delivery_code ~file_status ()] creates a Finished PDU. *)
254
+
255
+
val pp_finished : finished Fmt.t
256
+
257
+
(** {2 ACK PDU} *)
258
+
259
+
type ack = {
260
+
directive : directive_code;
261
+
subtype : int;
262
+
condition : condition;
263
+
transaction_status : transaction_status;
264
+
}
265
+
266
+
val ack :
267
+
directive:directive_code ->
268
+
subtype:int ->
269
+
condition:condition ->
270
+
transaction_status:transaction_status ->
271
+
ack
272
+
(** [ack ~directive ~subtype ~condition ~transaction_status] creates an ACK PDU. *)
273
+
274
+
val pp_ack : ack Fmt.t
275
+
276
+
(** {2 Metadata PDU} *)
277
+
278
+
type filestore_request = {
279
+
action_code : int;
280
+
first_filename : string;
281
+
second_filename : string;
282
+
}
283
+
284
+
type metadata = {
285
+
closure_requested : bool;
286
+
checksum_type : checksum_type;
287
+
file_size : int64;
288
+
source_filename : string;
289
+
dest_filename : string;
290
+
filestore_requests : filestore_request list;
291
+
messages_to_user : bytes list;
292
+
}
293
+
294
+
val metadata :
295
+
?closure_requested:bool ->
296
+
?checksum_type:checksum_type ->
297
+
?filestore_requests:filestore_request list ->
298
+
?messages_to_user:bytes list ->
299
+
file_size:int64 ->
300
+
source_filename:string ->
301
+
dest_filename:string ->
302
+
unit ->
303
+
metadata
304
+
(** [metadata ~file_size ~source_filename ~dest_filename ()] creates a Metadata PDU. *)
305
+
306
+
val pp_metadata : metadata Fmt.t
307
+
308
+
(** {2 NAK PDU} *)
309
+
310
+
type segment_request = { start_offset : int64; end_offset : int64 }
311
+
312
+
val segment_request : int64 -> int64 -> segment_request
313
+
(** [segment_request start_off end_off] creates a segment request. *)
314
+
315
+
type nak = {
316
+
start_scope : int64;
317
+
end_scope : int64;
318
+
segments : segment_request list;
319
+
}
320
+
321
+
val nak : start_scope:int64 -> end_scope:int64 -> segment_request list -> nak
322
+
(** [nak ~start_scope ~end_scope segments] creates a NAK PDU. *)
323
+
324
+
val pp_nak : nak Fmt.t
325
+
326
+
(** {2 Prompt PDU} *)
327
+
328
+
type prompt_response = Prompt_nak | Prompt_keep_alive
329
+
type prompt = { response : prompt_response }
330
+
331
+
val prompt : prompt_response -> prompt
332
+
(** [prompt response] creates a Prompt PDU. *)
333
+
334
+
val pp_prompt : prompt Fmt.t
335
+
336
+
(** {2 Keep Alive PDU} *)
337
+
338
+
type keep_alive = { progress : int64 }
339
+
340
+
val keep_alive : int64 -> keep_alive
341
+
(** [keep_alive progress] creates a Keep Alive PDU. *)
342
+
343
+
val pp_keep_alive : keep_alive Fmt.t
344
+
345
+
(** {1 File Data PDU} *)
346
+
347
+
type file_data = {
348
+
continuation : record_continuation option;
349
+
segment_metadata : bytes option;
350
+
offset : int64;
351
+
data : bytes;
352
+
}
353
+
354
+
val file_data :
355
+
?continuation:record_continuation ->
356
+
?segment_metadata:bytes ->
357
+
offset:int64 ->
358
+
bytes ->
359
+
file_data
360
+
(** [file_data ~offset data] creates a File Data PDU. *)
361
+
362
+
val pp_file_data : file_data Fmt.t
363
+
364
+
(** {1 Complete PDU} *)
365
+
366
+
type directive =
367
+
| Eof of eof
368
+
| Finished of finished
369
+
| Ack of ack
370
+
| Metadata of metadata
371
+
| Nak of nak
372
+
| Prompt of prompt
373
+
| Keep_alive of keep_alive
374
+
375
+
type pdu =
376
+
| Pdu_directive of header * directive
377
+
| Pdu_file_data of header * file_data
378
+
379
+
val pp_directive : directive Fmt.t
380
+
val pp_pdu : pdu Fmt.t
381
+
382
+
(** {1 Encoding} *)
383
+
384
+
val header_len : pdu_config -> int
385
+
(** [header_len config] returns fixed header length for this config. *)
386
+
387
+
val encode_header : pdu_config -> header -> string
388
+
(** [encode_header config hdr] encodes PDU header. *)
389
+
390
+
val encode_directive : large_file:bool -> directive -> string
391
+
(** [encode_directive ~large_file dir] encodes a file directive. *)
392
+
393
+
val encode_file_data : large_file:bool -> segment_metadata:bool -> file_data -> string
394
+
(** [encode_file_data ~large_file ~segment_metadata fd] encodes file data PDU data field. *)
395
+
396
+
val encode : pdu_config -> pdu -> string
397
+
(** [encode config pdu] encodes a complete PDU. *)
398
+
399
+
(** {1 Decoding} *)
400
+
401
+
type error =
402
+
| Truncated of { need : int; have : int }
403
+
| Invalid_version of int
404
+
| Invalid_pdu_type of int
405
+
| Invalid_directive_code of int
406
+
| Invalid_condition_code of int
407
+
| Invalid_checksum_type of int
408
+
| Crc_mismatch of { expected : int; actual : int }
409
+
| Invalid_format of string
410
+
| Entity_id_overflow
411
+
(** Entity ID >= 2^63 cannot be represented. See {!Entity_id}. *)
412
+
413
+
val pp_error : error Fmt.t
414
+
415
+
val decode_header : string -> (header * pdu_config * int, error) result
416
+
(** [decode_header buf] decodes PDU header. Returns [(header, config, consumed)]. *)
417
+
418
+
val decode_directive : large_file:bool -> string -> int -> (directive * int, error) result
419
+
(** [decode_directive ~large_file buf off] decodes file directive at offset. *)
420
+
421
+
val decode_file_data :
422
+
large_file:bool ->
423
+
segment_metadata:bool ->
424
+
string ->
425
+
int ->
426
+
int ->
427
+
(file_data * int, error) result
428
+
(** [decode_file_data ~large_file ~segment_metadata buf off data_len] decodes file data. *)
429
+
430
+
val decode : string -> (pdu * int, error) result
431
+
(** [decode buf] decodes a complete PDU. Returns [(pdu, consumed)]. *)
432
+
433
+
(** {1 State Machines} *)
434
+
435
+
(** {2 Timer Types} *)
436
+
437
+
type timer_id =
438
+
| Timer_nak
439
+
| Timer_eof
440
+
| Timer_finished
441
+
| Timer_inactivity
442
+
| Timer_keep_alive
443
+
444
+
(** {2 Indications} *)
445
+
446
+
type indication =
447
+
| Ind_transaction_started of transaction_id
448
+
| Ind_eof_sent of transaction_id
449
+
| Ind_transaction_finished of transaction_id * condition
450
+
| Ind_metadata_recv of transaction_id * metadata
451
+
| Ind_file_segment_recv of transaction_id * int64 * int
452
+
| Ind_suspended of transaction_id * condition
453
+
| Ind_resumed of transaction_id
454
+
| Ind_fault of transaction_id * condition
455
+
456
+
(** {2 Put Request} *)
457
+
458
+
type put_request = {
459
+
dest_entity : entity_id;
460
+
source_filename : string;
461
+
dest_filename : string;
462
+
transmission_mode : transmission_mode;
463
+
closure_requested : bool;
464
+
filestore_requests : filestore_request list;
465
+
messages_to_user : bytes list;
466
+
}
467
+
468
+
val put_request :
469
+
?transmission_mode:transmission_mode ->
470
+
?closure_requested:bool ->
471
+
?filestore_requests:filestore_request list ->
472
+
?messages_to_user:bytes list ->
473
+
dest_entity:entity_id ->
474
+
source_filename:string ->
475
+
dest_filename:string ->
476
+
unit ->
477
+
put_request
478
+
(** [put_request ~dest_entity ~source_filename ~dest_filename ()] creates a put request. *)
479
+
480
+
(** {2 Class 1 Sender (Unacknowledged)} *)
481
+
482
+
module Sender1 : sig
483
+
type state = S1_idle | S2_sending | S3_eof_sent
484
+
type t
485
+
486
+
type event =
487
+
| Ev_put_request of put_request * int64 * (int64 -> bytes)
488
+
(** Put request with file size and data reader *)
489
+
| Ev_segment_sent of int64
490
+
| Ev_eof_sent
491
+
| Ev_finished_recv of finished
492
+
| Ev_cancel
493
+
| Ev_fault of condition
494
+
495
+
type action =
496
+
| Act_send_metadata of metadata
497
+
| Act_send_file_data of file_data
498
+
| Act_send_eof of eof
499
+
| Act_finished of condition
500
+
| Act_indication of indication
501
+
502
+
val initial : entity_id -> t
503
+
val state : t -> state
504
+
val transaction_id : t -> transaction_id option
505
+
val dest : t -> entity_id option
506
+
val filenames : t -> string * string
507
+
val step : t -> event -> t * action list
508
+
val pp : t Fmt.t
509
+
end
510
+
511
+
(** {2 Class 2 Sender (Acknowledged)} *)
512
+
513
+
module Sender2 : sig
514
+
type state = S1_idle | S2_sending | S3_eof_sent | S4_eof_acked
515
+
type t
516
+
517
+
type event =
518
+
| Ev_put_request of put_request * int64 * (int64 -> bytes)
519
+
| Ev_segment_sent of int64
520
+
| Ev_eof_sent
521
+
| Ev_ack_recv of ack
522
+
| Ev_nak_recv of nak
523
+
| Ev_finished_recv of finished
524
+
| Ev_timer_expired of timer_id
525
+
| Ev_cancel
526
+
| Ev_fault of condition
527
+
528
+
type action =
529
+
| Act_send_metadata of metadata
530
+
| Act_send_file_data of file_data
531
+
| Act_send_eof of eof
532
+
| Act_send_ack of ack
533
+
| Act_start_timer of timer_id * Duration.t
534
+
| Act_cancel_timer of timer_id
535
+
| Act_finished of condition
536
+
| Act_indication of indication
537
+
538
+
val initial : entity_id -> t
539
+
val state : t -> state
540
+
val transaction_id : t -> transaction_id option
541
+
val dest : t -> entity_id option
542
+
val filenames : t -> string * string
543
+
val pending_retransmits : t -> segment_request list
544
+
val step : t -> event -> t * action list
545
+
val pp : t Fmt.t
546
+
end
547
+
548
+
(** {2 Class 1 Receiver (Unacknowledged)} *)
549
+
550
+
module Receiver1 : sig
551
+
type state = R1_idle | R2_receiving | R3_complete
552
+
type t
553
+
554
+
type event =
555
+
| Ev_metadata_recv of header * metadata
556
+
| Ev_file_data_recv of header * file_data
557
+
| Ev_eof_recv of header * eof
558
+
| Ev_cancel
559
+
| Ev_inactivity_timeout
560
+
561
+
type action =
562
+
| Act_store_data of int64 * bytes
563
+
| Act_send_finished of finished
564
+
| Act_deliver_file of string * int64 * int32
565
+
(** filename, size, checksum *)
566
+
| Act_finished of condition
567
+
| Act_indication of indication
568
+
569
+
val initial : entity_id -> t
570
+
val state : t -> state
571
+
val transaction_id : t -> transaction_id option
572
+
val local_entity : t -> entity_id
573
+
val expected_size : t -> int64
574
+
val computed_checksum : t -> int32
575
+
val step : t -> event -> t * action list
576
+
val pp : t Fmt.t
577
+
end
578
+
579
+
(** {2 Class 2 Receiver (Acknowledged)} *)
580
+
581
+
module Receiver2 : sig
582
+
type state = R1_idle | R2_receiving | R3_eof_received | R4_complete
583
+
type t
584
+
585
+
type event =
586
+
| Ev_metadata_recv of header * metadata
587
+
| Ev_file_data_recv of header * file_data
588
+
| Ev_eof_recv of header * eof
589
+
| Ev_ack_recv of ack
590
+
| Ev_prompt_recv of prompt
591
+
| Ev_timer_expired of timer_id
592
+
| Ev_cancel
593
+
| Ev_inactivity_timeout
594
+
595
+
type action =
596
+
| Act_store_data of int64 * bytes
597
+
| Act_send_nak of nak
598
+
| Act_send_finished of finished
599
+
| Act_send_keep_alive of keep_alive
600
+
| Act_send_ack of ack
601
+
| Act_start_timer of timer_id * Duration.t
602
+
| Act_cancel_timer of timer_id
603
+
| Act_deliver_file of string * int64 * int32
604
+
| Act_finished of condition
605
+
| Act_indication of indication
606
+
607
+
val initial : entity_id -> t
608
+
val state : t -> state
609
+
val transaction_id : t -> transaction_id option
610
+
val local_entity : t -> entity_id
611
+
val expected_size : t -> int64
612
+
val computed_checksum : t -> int32
613
+
val step : t -> event -> t * action list
614
+
val pp : t Fmt.t
615
+
end
+769
test/test_cfdp.ml
+769
test/test_cfdp.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for CFDP module (CCSDS 727.0-B-5). *)
7
+
8
+
(* {1 Helpers} *)
9
+
10
+
let _entity_id = Alcotest.testable Cfdp.Entity_id.pp Cfdp.Entity_id.equal
11
+
12
+
let header =
13
+
Alcotest.testable Cfdp.pp_header (fun a b ->
14
+
a.Cfdp.version = b.Cfdp.version
15
+
&& a.pdu_type = b.pdu_type && a.direction = b.direction
16
+
&& a.transmission_mode = b.transmission_mode
17
+
&& a.crc_present = b.crc_present
18
+
&& a.large_file = b.large_file
19
+
&& a.segment_ctrl = b.segment_ctrl
20
+
&& a.segment_metadata = b.segment_metadata
21
+
&& Cfdp.Entity_id.equal a.source_entity b.source_entity
22
+
&& a.transaction_seq = b.transaction_seq
23
+
&& Cfdp.Entity_id.equal a.dest_entity b.dest_entity
24
+
&& a.data_len = b.data_len)
25
+
26
+
(* {2 Local encoding/parsing helpers} *)
27
+
28
+
let encode_header cfg hdr = Cfdp.encode_header cfg hdr
29
+
30
+
let parse_header buf =
31
+
match Cfdp.decode_header buf with
32
+
| Ok (hdr, cfg, consumed) -> Ok (hdr, cfg, consumed)
33
+
| Error e -> Error e
34
+
35
+
let encode_directive ~large_file dir = Cfdp.encode_directive ~large_file dir
36
+
37
+
let parse_directive ~large_file buf off =
38
+
match Cfdp.decode_directive ~large_file buf off with
39
+
| Ok (dir, consumed) -> Ok (dir, consumed)
40
+
| Error e -> Error e
41
+
42
+
let encode_file_data ~large_file ~segment_metadata fd =
43
+
Cfdp.encode_file_data ~large_file ~segment_metadata fd
44
+
45
+
let parse_file_data ~large_file ~segment_metadata buf off data_len =
46
+
match Cfdp.decode_file_data ~large_file ~segment_metadata buf off data_len with
47
+
| Ok (fd, consumed) -> Ok (fd, consumed)
48
+
| Error e -> Error e
49
+
50
+
let encode cfg pdu = Cfdp.encode cfg pdu
51
+
52
+
let parse buf =
53
+
match Cfdp.decode buf with
54
+
| Ok (pdu, consumed) ->
55
+
let rest = String.sub buf consumed (String.length buf - consumed) in
56
+
Ok (pdu, rest)
57
+
| Error e -> Error e
58
+
59
+
(* {1 Entity ID Tests} *)
60
+
61
+
let test_entity_id_basic () =
62
+
let eid = Cfdp.Entity_id.of_int_exn 42 in
63
+
Alcotest.(check int64) "to_int64" 42L (Cfdp.Entity_id.to_int64 eid)
64
+
65
+
let test_entity_id_int64 () =
66
+
let eid = Cfdp.Entity_id.of_int64_exn 0xDEADBEEFL in
67
+
Alcotest.(check int64) "large value" 0xDEADBEEFL (Cfdp.Entity_id.to_int64 eid)
68
+
69
+
let test_entity_id_equal () =
70
+
let e1 = Cfdp.Entity_id.of_int_exn 1 in
71
+
let e2 = Cfdp.Entity_id.of_int_exn 1 in
72
+
let e3 = Cfdp.Entity_id.of_int_exn 2 in
73
+
Alcotest.(check bool) "equal" true (Cfdp.Entity_id.equal e1 e2);
74
+
Alcotest.(check bool) "not equal" false (Cfdp.Entity_id.equal e1 e3)
75
+
76
+
let test_entity_id_compare () =
77
+
let e1 = Cfdp.Entity_id.of_int_exn 1 in
78
+
let e2 = Cfdp.Entity_id.of_int_exn 2 in
79
+
Alcotest.(check int) "compare <" (-1) (Cfdp.Entity_id.compare e1 e2);
80
+
Alcotest.(check int) "compare =" 0 (Cfdp.Entity_id.compare e1 e1);
81
+
Alcotest.(check int) "compare >" 1 (Cfdp.Entity_id.compare e2 e1)
82
+
83
+
let test_entity_id_unsigned_valid () =
84
+
(match Cfdp.Entity_id.of_int64_unsigned 0L with
85
+
| `Ok eid -> Alcotest.(check int64) "zero" 0L (Cfdp.Entity_id.to_int64 eid)
86
+
| `Overflow -> Alcotest.fail "zero should be valid");
87
+
match Cfdp.Entity_id.of_int64_unsigned Int64.max_int with
88
+
| `Ok eid ->
89
+
Alcotest.(check int64)
90
+
"max int64" Int64.max_int
91
+
(Cfdp.Entity_id.to_int64 eid)
92
+
| `Overflow -> Alcotest.fail "max_int should be valid"
93
+
94
+
let test_entity_id_unsigned_overflow () =
95
+
(match Cfdp.Entity_id.of_int64_unsigned Int64.min_int with
96
+
| `Overflow -> ()
97
+
| `Ok _ -> Alcotest.fail "Int64.min_int (2^63 unsigned) should overflow");
98
+
match Cfdp.Entity_id.of_int64_unsigned (-1L) with
99
+
| `Overflow -> ()
100
+
| `Ok _ -> Alcotest.fail "-1L (2^64-1 unsigned) should overflow"
101
+
102
+
(* {1 PDU Config Tests} *)
103
+
104
+
let test_pdu_config_valid () =
105
+
match Cfdp.pdu_config ~entity_id_len:2 ~seq_nr_len:4 with
106
+
| Some cfg ->
107
+
Alcotest.(check int) "entity_id_len" 2 cfg.entity_id_len;
108
+
Alcotest.(check int) "seq_nr_len" 4 cfg.seq_nr_len
109
+
| None -> Alcotest.fail "should create valid config"
110
+
111
+
let test_pdu_config_invalid () =
112
+
Alcotest.(check bool)
113
+
"invalid entity_id_len" true
114
+
(Option.is_none (Cfdp.pdu_config ~entity_id_len:0 ~seq_nr_len:4));
115
+
Alcotest.(check bool)
116
+
"invalid seq_nr_len" true
117
+
(Option.is_none (Cfdp.pdu_config ~entity_id_len:2 ~seq_nr_len:9))
118
+
119
+
let test_header_len () =
120
+
let cfg = Cfdp.default_config in
121
+
(* 4 bytes fixed + 2*2 entity IDs + 4 seq nr = 12 *)
122
+
Alcotest.(check int) "default header len" 12 (Cfdp.header_len cfg)
123
+
124
+
(* {1 Header Encoding/Decoding Tests} *)
125
+
126
+
let test_header_roundtrip () =
127
+
let cfg = Cfdp.default_config in
128
+
let original : Cfdp.header =
129
+
{
130
+
version = 1;
131
+
pdu_type = Cfdp.File_directive;
132
+
direction = Cfdp.Toward_receiver;
133
+
transmission_mode = Cfdp.Acknowledged;
134
+
crc_present = true;
135
+
large_file = false;
136
+
segment_ctrl = false;
137
+
segment_metadata = false;
138
+
source_entity = Cfdp.Entity_id.of_int_exn 1;
139
+
transaction_seq = 42L;
140
+
dest_entity = Cfdp.Entity_id.of_int_exn 2;
141
+
data_len = 10;
142
+
}
143
+
in
144
+
let encoded = encode_header cfg original in
145
+
match parse_header encoded with
146
+
| Ok (decoded, _cfg, _consumed) ->
147
+
Alcotest.(check header) "roundtrip" original decoded
148
+
| Error e ->
149
+
Alcotest.fail (Format.asprintf "decode failed: %a" Cfdp.pp_error e)
150
+
151
+
let test_header_file_data () =
152
+
let cfg = Cfdp.default_config in
153
+
let original : Cfdp.header =
154
+
{
155
+
version = 1;
156
+
pdu_type = Cfdp.File_data;
157
+
direction = Cfdp.Toward_receiver;
158
+
transmission_mode = Cfdp.Unacknowledged;
159
+
crc_present = false;
160
+
large_file = true;
161
+
segment_ctrl = true;
162
+
segment_metadata = true;
163
+
source_entity = Cfdp.Entity_id.of_int_exn 0xFF;
164
+
transaction_seq = 0xABCDL;
165
+
dest_entity = Cfdp.Entity_id.of_int_exn 0xFE;
166
+
data_len = 1024;
167
+
}
168
+
in
169
+
let encoded = encode_header cfg original in
170
+
match parse_header encoded with
171
+
| Ok (decoded, _cfg, _consumed) ->
172
+
Alcotest.(check header) "file data header" original decoded
173
+
| Error e ->
174
+
Alcotest.fail (Format.asprintf "decode failed: %a" Cfdp.pp_error e)
175
+
176
+
let test_header_truncated () =
177
+
let buf = String.make 2 '\x00' in
178
+
let buf = Bytes.of_string buf in
179
+
Bytes.set_uint8 buf 0 0x20;
180
+
let buf = Bytes.to_string buf in
181
+
match parse_header buf with
182
+
| Error (Cfdp.Truncated _) -> ()
183
+
| Error e -> Alcotest.fail (Format.asprintf "wrong error: %a" Cfdp.pp_error e)
184
+
| _ -> Alcotest.fail "should reject truncated header"
185
+
186
+
(* {1 Directive Tests} *)
187
+
188
+
let test_eof_roundtrip () =
189
+
let original =
190
+
Cfdp.eof ~condition:Cfdp.No_error ~checksum:0x12345678l ~file_size:1024L ()
191
+
in
192
+
let encoded = encode_directive ~large_file:false (Cfdp.Eof original) in
193
+
match parse_directive ~large_file:false encoded 0 with
194
+
| Ok (Cfdp.Eof decoded, _) ->
195
+
Alcotest.(check int32) "checksum" original.checksum decoded.checksum;
196
+
Alcotest.(check int64) "file_size" original.file_size decoded.file_size
197
+
| Ok _ -> Alcotest.fail "wrong directive type"
198
+
| Error e ->
199
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
200
+
201
+
let test_eof_with_fault () =
202
+
let original =
203
+
Cfdp.eof ~condition:Cfdp.Cancel_received ~checksum:0l ~file_size:0L
204
+
~fault_location:(Cfdp.Entity_id.of_int_exn 42)
205
+
()
206
+
in
207
+
let encoded = encode_directive ~large_file:false (Cfdp.Eof original) in
208
+
match parse_directive ~large_file:false encoded 0 with
209
+
| Ok (Cfdp.Eof decoded, _) -> (
210
+
Alcotest.(check bool)
211
+
"has fault" true
212
+
(Option.is_some decoded.fault_location);
213
+
match decoded.fault_location with
214
+
| Some eid ->
215
+
Alcotest.(check int64)
216
+
"fault entity" 42L
217
+
(Cfdp.Entity_id.to_int64 eid)
218
+
| None -> Alcotest.fail "expected fault location")
219
+
| Ok _ -> Alcotest.fail "wrong directive type"
220
+
| Error e ->
221
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
222
+
223
+
let test_metadata_roundtrip () =
224
+
let original =
225
+
Cfdp.metadata ~closure_requested:true ~checksum_type:Cfdp.Checksum_crc32
226
+
~file_size:4096L ~source_filename:"/src/file.dat"
227
+
~dest_filename:"/dst/file.dat" ()
228
+
in
229
+
let encoded = encode_directive ~large_file:false (Cfdp.Metadata original) in
230
+
match parse_directive ~large_file:false encoded 0 with
231
+
| Ok (Cfdp.Metadata decoded, _) ->
232
+
Alcotest.(check bool)
233
+
"closure" original.closure_requested decoded.closure_requested;
234
+
Alcotest.(check int64) "file_size" original.file_size decoded.file_size;
235
+
Alcotest.(check string)
236
+
"src" original.source_filename decoded.source_filename;
237
+
Alcotest.(check string) "dst" original.dest_filename decoded.dest_filename
238
+
| Ok _ -> Alcotest.fail "wrong directive type"
239
+
| Error e ->
240
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
241
+
242
+
let test_finished_roundtrip () =
243
+
let original =
244
+
Cfdp.finished ~condition:Cfdp.No_error ~delivery_code:Cfdp.Data_complete
245
+
~file_status:Cfdp.Retained_successfully ()
246
+
in
247
+
let encoded = encode_directive ~large_file:false (Cfdp.Finished original) in
248
+
match parse_directive ~large_file:false encoded 0 with
249
+
| Ok (Cfdp.Finished decoded, _) ->
250
+
Alcotest.(check bool)
251
+
"data complete"
252
+
(decoded.delivery_code = Cfdp.Data_complete)
253
+
true;
254
+
Alcotest.(check bool)
255
+
"retained"
256
+
(decoded.file_status = Cfdp.Retained_successfully)
257
+
true
258
+
| Ok _ -> Alcotest.fail "wrong directive type"
259
+
| Error e ->
260
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
261
+
262
+
let test_ack_roundtrip () =
263
+
let original =
264
+
Cfdp.ack ~directive:Cfdp.Dir_eof ~subtype:0 ~condition:Cfdp.No_error
265
+
~transaction_status:Cfdp.Tx_active
266
+
in
267
+
let encoded = encode_directive ~large_file:false (Cfdp.Ack original) in
268
+
match parse_directive ~large_file:false encoded 0 with
269
+
| Ok (Cfdp.Ack decoded, _) ->
270
+
Alcotest.(check bool) "code" (decoded.directive = Cfdp.Dir_eof) true;
271
+
Alcotest.(check bool)
272
+
"status"
273
+
(decoded.transaction_status = Cfdp.Tx_active)
274
+
true
275
+
| Ok _ -> Alcotest.fail "wrong directive type"
276
+
| Error e ->
277
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
278
+
279
+
let test_nak_roundtrip () =
280
+
let original =
281
+
Cfdp.nak ~start_scope:0L ~end_scope:1024L
282
+
[ Cfdp.segment_request 100L 200L; Cfdp.segment_request 500L 600L ]
283
+
in
284
+
let encoded = encode_directive ~large_file:false (Cfdp.Nak original) in
285
+
match parse_directive ~large_file:false encoded 0 with
286
+
| Ok (Cfdp.Nak decoded, _) ->
287
+
Alcotest.(check int64)
288
+
"start_scope" original.start_scope decoded.start_scope;
289
+
Alcotest.(check int64) "end_scope" original.end_scope decoded.end_scope;
290
+
Alcotest.(check int) "segments" 2 (List.length decoded.segments)
291
+
| Ok _ -> Alcotest.fail "wrong directive type"
292
+
| Error e ->
293
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
294
+
295
+
let test_prompt_roundtrip () =
296
+
let original = Cfdp.prompt Cfdp.Prompt_nak in
297
+
let encoded = encode_directive ~large_file:false (Cfdp.Prompt original) in
298
+
match parse_directive ~large_file:false encoded 0 with
299
+
| Ok (Cfdp.Prompt decoded, _) ->
300
+
Alcotest.(check bool) "response" (decoded.response = Cfdp.Prompt_nak) true
301
+
| Ok _ -> Alcotest.fail "wrong directive type"
302
+
| Error e ->
303
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
304
+
305
+
let test_keep_alive_roundtrip () =
306
+
let original = Cfdp.keep_alive 12345L in
307
+
let encoded = encode_directive ~large_file:false (Cfdp.Keep_alive original) in
308
+
match parse_directive ~large_file:false encoded 0 with
309
+
| Ok (Cfdp.Keep_alive decoded, _) ->
310
+
Alcotest.(check int64) "progress" original.progress decoded.progress
311
+
| Ok _ -> Alcotest.fail "wrong directive type"
312
+
| Error e ->
313
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
314
+
315
+
(* {1 File Data Tests} *)
316
+
317
+
let test_file_data_roundtrip () =
318
+
let original =
319
+
Cfdp.file_data ~offset:1024L (Bytes.of_string "Hello, CFDP!")
320
+
in
321
+
let encoded =
322
+
encode_file_data ~large_file:false ~segment_metadata:false original
323
+
in
324
+
let len = String.length encoded in
325
+
match
326
+
parse_file_data ~large_file:false ~segment_metadata:false encoded 0 len
327
+
with
328
+
| Ok (decoded, _) ->
329
+
Alcotest.(check int64) "offset" original.offset decoded.offset;
330
+
Alcotest.(check bytes) "data" original.data decoded.data
331
+
| Error e ->
332
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
333
+
334
+
let test_file_data_large_file () =
335
+
let original =
336
+
Cfdp.file_data ~offset:0x100000000L (Bytes.of_string "Large file test")
337
+
in
338
+
let encoded =
339
+
encode_file_data ~large_file:true ~segment_metadata:false original
340
+
in
341
+
let len = String.length encoded in
342
+
match
343
+
parse_file_data ~large_file:true ~segment_metadata:false encoded 0 len
344
+
with
345
+
| Ok (decoded, _) ->
346
+
Alcotest.(check int64) "large offset" original.offset decoded.offset
347
+
| Error e ->
348
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
349
+
350
+
(* {1 Complete PDU Tests} *)
351
+
352
+
let test_pdu_roundtrip_metadata () =
353
+
let cfg = Cfdp.default_config in
354
+
let meta =
355
+
Cfdp.metadata ~file_size:2048L ~source_filename:"test.txt"
356
+
~dest_filename:"dest.txt" ()
357
+
in
358
+
let hdr : Cfdp.header =
359
+
{
360
+
version = 1;
361
+
pdu_type = Cfdp.File_directive;
362
+
direction = Cfdp.Toward_receiver;
363
+
transmission_mode = Cfdp.Unacknowledged;
364
+
crc_present = false;
365
+
large_file = false;
366
+
segment_ctrl = false;
367
+
segment_metadata = false;
368
+
source_entity = Cfdp.Entity_id.of_int_exn 1;
369
+
transaction_seq = 100L;
370
+
dest_entity = Cfdp.Entity_id.of_int_exn 2;
371
+
data_len = 0;
372
+
}
373
+
in
374
+
let pdu = Cfdp.Pdu_directive (hdr, Cfdp.Metadata meta) in
375
+
let encoded = encode cfg pdu in
376
+
match parse encoded with
377
+
| Ok (Cfdp.Pdu_directive (_, Cfdp.Metadata decoded), _) ->
378
+
Alcotest.(check string) "src" meta.source_filename decoded.source_filename
379
+
| Ok _ -> Alcotest.fail "wrong PDU type"
380
+
| Error e ->
381
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
382
+
383
+
let test_pdu_roundtrip_file_data () =
384
+
let cfg = Cfdp.default_config in
385
+
let fd = Cfdp.file_data ~offset:0L (Bytes.of_string "Test file content") in
386
+
let hdr : Cfdp.header =
387
+
{
388
+
version = 1;
389
+
pdu_type = Cfdp.File_data;
390
+
direction = Cfdp.Toward_receiver;
391
+
transmission_mode = Cfdp.Unacknowledged;
392
+
crc_present = true;
393
+
large_file = false;
394
+
segment_ctrl = false;
395
+
segment_metadata = false;
396
+
source_entity = Cfdp.Entity_id.of_int_exn 1;
397
+
transaction_seq = 101L;
398
+
dest_entity = Cfdp.Entity_id.of_int_exn 2;
399
+
data_len = 0;
400
+
}
401
+
in
402
+
let pdu = Cfdp.Pdu_file_data (hdr, fd) in
403
+
let encoded = encode cfg pdu in
404
+
match parse encoded with
405
+
| Ok (Cfdp.Pdu_file_data (_, decoded), _) ->
406
+
Alcotest.(check bytes) "data" fd.data decoded.data
407
+
| Ok _ -> Alcotest.fail "wrong PDU type"
408
+
| Error e ->
409
+
Alcotest.fail (Format.asprintf "parse failed: %a" Cfdp.pp_error e)
410
+
411
+
(* {1 Checksum Tests} *)
412
+
413
+
let test_checksum_modular () =
414
+
let data = Bytes.of_string "ABCD" in
415
+
let checksum = Cfdp.compute_checksum Cfdp.Checksum_modular data in
416
+
Alcotest.(check int32) "modular" 0x41424344l checksum
417
+
418
+
let test_checksum_crc32 () =
419
+
let data = Bytes.of_string "123456789" in
420
+
let checksum = Cfdp.compute_checksum Cfdp.Checksum_crc32 data in
421
+
Alcotest.(check int32) "CRC-32" 0xCBF43926l checksum
422
+
423
+
let test_checksum_crc32c () =
424
+
let data = Bytes.of_string "123456789" in
425
+
let checksum = Cfdp.compute_checksum Cfdp.Checksum_crc32c data in
426
+
Alcotest.(check int32) "CRC-32C" 0xE3069283l checksum
427
+
428
+
let test_checksum_null () =
429
+
let data = Bytes.of_string "anything" in
430
+
let checksum = Cfdp.compute_checksum Cfdp.Checksum_null data in
431
+
Alcotest.(check int32) "null" 0l checksum
432
+
433
+
let test_verify_checksum () =
434
+
let data = Bytes.of_string "123456789" in
435
+
Alcotest.(check bool)
436
+
"verify CRC-32" true
437
+
(Cfdp.verify_checksum Cfdp.Checksum_crc32 data 0xCBF43926l);
438
+
Alcotest.(check bool)
439
+
"verify wrong" false
440
+
(Cfdp.verify_checksum Cfdp.Checksum_crc32 data 0x12345678l)
441
+
442
+
(* {1 Condition Code Tests} *)
443
+
444
+
let test_condition_roundtrip () =
445
+
let conditions =
446
+
[
447
+
Cfdp.No_error;
448
+
Cfdp.Positive_ack_limit;
449
+
Cfdp.Keep_alive_limit;
450
+
Cfdp.Invalid_transmission_mode;
451
+
Cfdp.Filestore_rejection;
452
+
Cfdp.File_checksum_failure;
453
+
Cfdp.File_size_error;
454
+
Cfdp.Nak_limit_reached;
455
+
Cfdp.Inactivity_detected;
456
+
Cfdp.Invalid_file_structure;
457
+
Cfdp.Check_limit_reached;
458
+
Cfdp.Unsupported_checksum_type;
459
+
Cfdp.Suspend_received;
460
+
Cfdp.Cancel_received;
461
+
]
462
+
in
463
+
List.iter
464
+
(fun cond ->
465
+
let code = Cfdp.int_of_condition cond in
466
+
match Cfdp.condition_of_int code with
467
+
| Some decoded ->
468
+
Alcotest.(check bool)
469
+
(Format.asprintf "condition %a" Cfdp.pp_condition cond)
470
+
true (cond = decoded)
471
+
| None -> Alcotest.fail "should decode condition")
472
+
conditions
473
+
474
+
(* {1 State Machine Tests} *)
475
+
476
+
let test_sender1_initial () =
477
+
let eid = Cfdp.Entity_id.of_int_exn 1 in
478
+
let s = Cfdp.Sender1.initial eid in
479
+
Alcotest.(check bool) "idle" true (Cfdp.Sender1.state s = Cfdp.Sender1.S1_idle);
480
+
Alcotest.(check bool)
481
+
"no transaction" true
482
+
(Option.is_none (Cfdp.Sender1.transaction_id s))
483
+
484
+
let test_sender1_put_request () =
485
+
let eid = Cfdp.Entity_id.of_int_exn 1 in
486
+
let s = Cfdp.Sender1.initial eid in
487
+
let req =
488
+
Cfdp.put_request
489
+
~dest_entity:(Cfdp.Entity_id.of_int_exn 2)
490
+
~source_filename:"test.txt" ~dest_filename:"dest.txt" ()
491
+
in
492
+
let reader _offset = Bytes.of_string "data" in
493
+
let s', actions =
494
+
Cfdp.Sender1.step s (Cfdp.Sender1.Ev_put_request (req, 100L, reader))
495
+
in
496
+
Alcotest.(check bool)
497
+
"sending" true
498
+
(Cfdp.Sender1.state s' = Cfdp.Sender1.S2_sending);
499
+
Alcotest.(check bool)
500
+
"has transaction" true
501
+
(Option.is_some (Cfdp.Sender1.transaction_id s'));
502
+
Alcotest.(check bool) "has actions" true (List.length actions >= 2)
503
+
504
+
let test_receiver1_initial () =
505
+
let eid = Cfdp.Entity_id.of_int_exn 2 in
506
+
let r = Cfdp.Receiver1.initial eid in
507
+
Alcotest.(check bool)
508
+
"idle" true
509
+
(Cfdp.Receiver1.state r = Cfdp.Receiver1.R1_idle);
510
+
Alcotest.(check bool)
511
+
"no transaction" true
512
+
(Option.is_none (Cfdp.Receiver1.transaction_id r))
513
+
514
+
let test_receiver1_metadata () =
515
+
let eid = Cfdp.Entity_id.of_int_exn 2 in
516
+
let r = Cfdp.Receiver1.initial eid in
517
+
let hdr : Cfdp.header =
518
+
{
519
+
version = 1;
520
+
pdu_type = Cfdp.File_directive;
521
+
direction = Cfdp.Toward_receiver;
522
+
transmission_mode = Cfdp.Unacknowledged;
523
+
crc_present = false;
524
+
large_file = false;
525
+
segment_ctrl = false;
526
+
segment_metadata = false;
527
+
source_entity = Cfdp.Entity_id.of_int_exn 1;
528
+
transaction_seq = 1L;
529
+
dest_entity = eid;
530
+
data_len = 0;
531
+
}
532
+
in
533
+
let meta =
534
+
Cfdp.metadata ~file_size:100L ~source_filename:"src.txt"
535
+
~dest_filename:"dst.txt" ()
536
+
in
537
+
let r', actions =
538
+
Cfdp.Receiver1.step r (Cfdp.Receiver1.Ev_metadata_recv (hdr, meta))
539
+
in
540
+
Alcotest.(check bool)
541
+
"receiving" true
542
+
(Cfdp.Receiver1.state r' = Cfdp.Receiver1.R2_receiving);
543
+
Alcotest.(check int64) "expected size" 100L (Cfdp.Receiver1.expected_size r');
544
+
Alcotest.(check bool) "has indication" true (List.length actions >= 1)
545
+
546
+
let test_sender2_initial () =
547
+
let eid = Cfdp.Entity_id.of_int_exn 1 in
548
+
let s = Cfdp.Sender2.initial eid in
549
+
Alcotest.(check bool) "idle" true (Cfdp.Sender2.state s = Cfdp.Sender2.S1_idle)
550
+
551
+
let test_receiver2_initial () =
552
+
let eid = Cfdp.Entity_id.of_int_exn 2 in
553
+
let r = Cfdp.Receiver2.initial eid in
554
+
Alcotest.(check bool)
555
+
"idle" true
556
+
(Cfdp.Receiver2.state r = Cfdp.Receiver2.R1_idle)
557
+
558
+
(* {1 E2E Transfer Test} *)
559
+
560
+
let test_e2e_class1_transfer () =
561
+
let src_eid = Cfdp.Entity_id.of_int_exn 1 in
562
+
let dst_eid = Cfdp.Entity_id.of_int_exn 2 in
563
+
let file_content = Bytes.of_string "Hello, CFDP! This is a test file." in
564
+
let file_size = Int64.of_int (Bytes.length file_content) in
565
+
let file_checksum =
566
+
Cfdp.compute_checksum Cfdp.Checksum_modular file_content
567
+
in
568
+
569
+
let sender = Cfdp.Sender1.initial src_eid in
570
+
let receiver = Cfdp.Receiver1.initial dst_eid in
571
+
572
+
let req =
573
+
Cfdp.put_request ~dest_entity:dst_eid ~source_filename:"test.txt"
574
+
~dest_filename:"received.txt" ()
575
+
in
576
+
let reader offset =
577
+
let start = Int64.to_int offset in
578
+
if start >= Bytes.length file_content then Bytes.empty
579
+
else
580
+
Bytes.sub file_content start (min 16 (Bytes.length file_content - start))
581
+
in
582
+
let sender, send_actions =
583
+
Cfdp.Sender1.step sender
584
+
(Cfdp.Sender1.Ev_put_request (req, file_size, reader))
585
+
in
586
+
587
+
Alcotest.(check bool)
588
+
"sender in S2" true
589
+
(Cfdp.Sender1.state sender = Cfdp.Sender1.S2_sending);
590
+
591
+
let metadata_opt =
592
+
List.find_map
593
+
(function Cfdp.Sender1.Act_send_metadata m -> Some m | _ -> None)
594
+
send_actions
595
+
in
596
+
let metadata =
597
+
match metadata_opt with
598
+
| Some m -> m
599
+
| None -> Alcotest.fail "expected metadata action"
600
+
in
601
+
602
+
let meta_hdr : Cfdp.header =
603
+
{
604
+
version = 1;
605
+
pdu_type = Cfdp.File_directive;
606
+
direction = Cfdp.Toward_receiver;
607
+
transmission_mode = Cfdp.Unacknowledged;
608
+
crc_present = false;
609
+
large_file = false;
610
+
segment_ctrl = false;
611
+
segment_metadata = false;
612
+
source_entity = src_eid;
613
+
transaction_seq = 1L;
614
+
dest_entity = dst_eid;
615
+
data_len = 0;
616
+
}
617
+
in
618
+
let receiver, _recv_actions =
619
+
Cfdp.Receiver1.step receiver
620
+
(Cfdp.Receiver1.Ev_metadata_recv (meta_hdr, metadata))
621
+
in
622
+
623
+
Alcotest.(check bool)
624
+
"receiver in R2" true
625
+
(Cfdp.Receiver1.state receiver = Cfdp.Receiver1.R2_receiving);
626
+
Alcotest.(check int64)
627
+
"receiver expected size" file_size
628
+
(Cfdp.Receiver1.expected_size receiver);
629
+
630
+
let fd = Cfdp.file_data ~offset:0L file_content in
631
+
let fd_hdr : Cfdp.header =
632
+
{
633
+
version = 1;
634
+
pdu_type = Cfdp.File_data;
635
+
direction = Cfdp.Toward_receiver;
636
+
transmission_mode = Cfdp.Unacknowledged;
637
+
crc_present = false;
638
+
large_file = false;
639
+
segment_ctrl = false;
640
+
segment_metadata = false;
641
+
source_entity = src_eid;
642
+
transaction_seq = 1L;
643
+
dest_entity = dst_eid;
644
+
data_len = 0;
645
+
}
646
+
in
647
+
let receiver, _fd_actions =
648
+
Cfdp.Receiver1.step receiver (Cfdp.Receiver1.Ev_file_data_recv (fd_hdr, fd))
649
+
in
650
+
651
+
Alcotest.(check bool)
652
+
"receiver checksum updated" true
653
+
(Cfdp.Receiver1.computed_checksum receiver <> 0l);
654
+
655
+
let eof_pdu =
656
+
Cfdp.eof ~condition:Cfdp.No_error ~checksum:file_checksum ~file_size ()
657
+
in
658
+
let eof_hdr : Cfdp.header =
659
+
{
660
+
version = 1;
661
+
pdu_type = Cfdp.File_directive;
662
+
direction = Cfdp.Toward_receiver;
663
+
transmission_mode = Cfdp.Unacknowledged;
664
+
crc_present = false;
665
+
large_file = false;
666
+
segment_ctrl = false;
667
+
segment_metadata = false;
668
+
source_entity = src_eid;
669
+
transaction_seq = 1L;
670
+
dest_entity = dst_eid;
671
+
data_len = 0;
672
+
}
673
+
in
674
+
let receiver, eof_actions =
675
+
Cfdp.Receiver1.step receiver (Cfdp.Receiver1.Ev_eof_recv (eof_hdr, eof_pdu))
676
+
in
677
+
678
+
Alcotest.(check bool)
679
+
"receiver in R1 (idle)" true
680
+
(Cfdp.Receiver1.state receiver = Cfdp.Receiver1.R1_idle);
681
+
682
+
let has_deliver =
683
+
List.exists
684
+
(function Cfdp.Receiver1.Act_deliver_file _ -> true | _ -> false)
685
+
eof_actions
686
+
in
687
+
Alcotest.(check bool) "has deliver action" true has_deliver;
688
+
689
+
let finished_ok =
690
+
List.exists
691
+
(function
692
+
| Cfdp.Receiver1.Act_finished Cfdp.No_error -> true | _ -> false)
693
+
eof_actions
694
+
in
695
+
Alcotest.(check bool) "finished with No_error" true finished_ok
696
+
697
+
(* {1 Test Suite} *)
698
+
699
+
let () =
700
+
Alcotest.run "CFDP"
701
+
[
702
+
( "Entity_id",
703
+
[
704
+
Alcotest.test_case "basic" `Quick test_entity_id_basic;
705
+
Alcotest.test_case "int64" `Quick test_entity_id_int64;
706
+
Alcotest.test_case "equal" `Quick test_entity_id_equal;
707
+
Alcotest.test_case "compare" `Quick test_entity_id_compare;
708
+
Alcotest.test_case "unsigned valid" `Quick test_entity_id_unsigned_valid;
709
+
Alcotest.test_case "unsigned overflow" `Quick test_entity_id_unsigned_overflow;
710
+
] );
711
+
( "PDU Config",
712
+
[
713
+
Alcotest.test_case "valid" `Quick test_pdu_config_valid;
714
+
Alcotest.test_case "invalid" `Quick test_pdu_config_invalid;
715
+
Alcotest.test_case "header_len" `Quick test_header_len;
716
+
] );
717
+
( "Header",
718
+
[
719
+
Alcotest.test_case "roundtrip" `Quick test_header_roundtrip;
720
+
Alcotest.test_case "file_data" `Quick test_header_file_data;
721
+
Alcotest.test_case "truncated" `Quick test_header_truncated;
722
+
] );
723
+
( "Directives",
724
+
[
725
+
Alcotest.test_case "EOF roundtrip" `Quick test_eof_roundtrip;
726
+
Alcotest.test_case "EOF with fault" `Quick test_eof_with_fault;
727
+
Alcotest.test_case "Metadata roundtrip" `Quick test_metadata_roundtrip;
728
+
Alcotest.test_case "Finished roundtrip" `Quick test_finished_roundtrip;
729
+
Alcotest.test_case "ACK roundtrip" `Quick test_ack_roundtrip;
730
+
Alcotest.test_case "NAK roundtrip" `Quick test_nak_roundtrip;
731
+
Alcotest.test_case "Prompt roundtrip" `Quick test_prompt_roundtrip;
732
+
Alcotest.test_case "Keep Alive roundtrip" `Quick test_keep_alive_roundtrip;
733
+
] );
734
+
( "File Data",
735
+
[
736
+
Alcotest.test_case "roundtrip" `Quick test_file_data_roundtrip;
737
+
Alcotest.test_case "large_file" `Quick test_file_data_large_file;
738
+
] );
739
+
( "Complete PDU",
740
+
[
741
+
Alcotest.test_case "metadata" `Quick test_pdu_roundtrip_metadata;
742
+
Alcotest.test_case "file_data" `Quick test_pdu_roundtrip_file_data;
743
+
] );
744
+
( "Checksums",
745
+
[
746
+
Alcotest.test_case "modular" `Quick test_checksum_modular;
747
+
Alcotest.test_case "CRC-32" `Quick test_checksum_crc32;
748
+
Alcotest.test_case "CRC-32C" `Quick test_checksum_crc32c;
749
+
Alcotest.test_case "null" `Quick test_checksum_null;
750
+
Alcotest.test_case "verify" `Quick test_verify_checksum;
751
+
] );
752
+
( "Condition codes",
753
+
[
754
+
Alcotest.test_case "roundtrip" `Quick test_condition_roundtrip;
755
+
] );
756
+
( "State Machines",
757
+
[
758
+
Alcotest.test_case "Sender1 initial" `Quick test_sender1_initial;
759
+
Alcotest.test_case "Sender1 put_request" `Quick test_sender1_put_request;
760
+
Alcotest.test_case "Receiver1 initial" `Quick test_receiver1_initial;
761
+
Alcotest.test_case "Receiver1 metadata" `Quick test_receiver1_metadata;
762
+
Alcotest.test_case "Sender2 initial" `Quick test_sender2_initial;
763
+
Alcotest.test_case "Receiver2 initial" `Quick test_receiver2_initial;
764
+
] );
765
+
( "E2E",
766
+
[
767
+
Alcotest.test_case "Class 1 transfer" `Quick test_e2e_class1_transfer;
768
+
] );
769
+
]