Pure OCaml ARP table lookup - reads /proc/net/arp on Linux and arp -a on macOS/BSD
ocaml-arp: Restore after accidental SLE overwrite
ocaml-sle: Add tests and fuzz tests
+164
-5825
+25
arp.opam
+25
arp.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Pure OCaml ARP table lookup"
4
+
description:
5
+
"Read the system ARP cache without external dependencies. Uses /proc/net/arp on Linux and arp -a on macOS/BSD."
6
+
depends: [
7
+
"ocaml" {>= "4.14.0"}
8
+
"dune" {>= "3.0" & >= "3.0"}
9
+
"alcotest" {with-test}
10
+
"odoc" {with-doc}
11
+
]
12
+
build: [
13
+
["dune" "subst"] {dev}
14
+
[
15
+
"dune"
16
+
"build"
17
+
"-p"
18
+
name
19
+
"-j"
20
+
jobs
21
+
"@install"
22
+
"@runtest" {with-test}
23
+
"@doc" {with-doc}
24
+
]
25
+
]
+7
-36
dune-project
+7
-36
dune-project
···
1
1
(lang dune 3.0)
2
-
3
-
(name sle)
2
+
(name arp)
4
3
5
4
(generate_opam_files true)
6
5
7
-
(license ISC)
8
-
9
-
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
10
-
11
-
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
12
-
13
-
(source
14
-
(github tarides/ocaml-sle))
15
-
16
6
(package
17
-
(name sle)
18
-
(synopsis "CCSDS Space Link Extension (SLE) protocols")
7
+
(name arp)
8
+
(synopsis "Pure OCaml ARP table lookup")
19
9
(description
20
-
"Pure OCaml implementation of CCSDS Space Link Extension protocols for ground station communication. Includes RAF (Return All Frames), RCF (Return Channel Frames), and FCLTU (Forward CLTU) services.")
10
+
"Read the system ARP cache without external dependencies. Uses /proc/net/arp on Linux and arp -a on macOS/BSD.")
21
11
(depends
22
-
(ocaml (>= 5.1))
23
-
(asn1-combinators (>= 0.3))
24
-
(digestif (>= 1.0))
25
-
(fmt (>= 0.9))
26
-
(logs (>= 0.7))
27
-
(alcotest :with-test)
28
-
(odoc :with-doc)))
29
-
30
-
(package
31
-
(name sle-eio)
32
-
(synopsis "Eio-based SLE client")
33
-
(description
34
-
"Effectful SLE client using Eio for TCP communication. Wraps the pure SLE library with I/O handling for TML framing and heartbeats.")
35
-
(depends
36
-
(ocaml (>= 5.1))
37
-
(sle (= :version))
38
-
(eio (>= 1.0))
39
-
(cstruct (>= 6.0))
40
-
(crypto (>= 0.1))
41
-
(crypto-rng (>= 0.1))
42
-
(alcotest :with-test)
43
-
(odoc :with-doc)))
12
+
(ocaml (>= 4.14.0))
13
+
(dune (>= 3.0))
14
+
(alcotest :with-test)))
+97
lib/arp.ml
+97
lib/arp.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** ARP table lookup.
7
+
8
+
Pure OCaml implementation:
9
+
- Linux: reads /proc/net/arp directly
10
+
- macOS/BSD: parses output of arp -a *)
11
+
12
+
type entry = { ip : string; mac : string; interface : string option }
13
+
14
+
let parse_proc_net_arp lines =
15
+
(* /proc/net/arp format:
16
+
IP address HW type Flags HW address Mask Device
17
+
192.168.1.1 0x1 0x2 aa:bb:cc:dd:ee:ff * eth0 *)
18
+
match lines with
19
+
| [] -> []
20
+
| _ :: data_lines ->
21
+
List.filter_map
22
+
(fun line ->
23
+
let parts =
24
+
String.split_on_char ' ' line
25
+
|> List.filter (fun s -> String.length s > 0)
26
+
in
27
+
match parts with
28
+
| ip :: _ :: flags :: mac :: _ :: iface :: _ ->
29
+
(* flags 0x2 = complete entry, 0x0 = incomplete *)
30
+
if flags <> "0x0" && mac <> "00:00:00:00:00:00" then
31
+
Some { ip; mac; interface = Some iface }
32
+
else None
33
+
| _ -> None)
34
+
data_lines
35
+
36
+
let parse_arp_a_output lines =
37
+
(* arp -a format (macOS/BSD):
38
+
hostname (192.168.1.1) at aa:bb:cc:dd:ee:ff on en0 ifscope [ethernet] *)
39
+
List.filter_map
40
+
(fun line ->
41
+
let parts =
42
+
String.split_on_char ' ' line
43
+
|> List.filter (fun s -> String.length s > 0)
44
+
in
45
+
match parts with
46
+
| _ :: ip_paren :: _ :: mac :: _ :: iface :: _
47
+
when String.length ip_paren > 2
48
+
&& ip_paren.[0] = '('
49
+
&& ip_paren.[String.length ip_paren - 1] = ')' ->
50
+
let ip = String.sub ip_paren 1 (String.length ip_paren - 2) in
51
+
if mac <> "(incomplete)" then Some { ip; mac; interface = Some iface }
52
+
else None
53
+
| _ -> None)
54
+
lines
55
+
56
+
let read_file path =
57
+
try
58
+
let ic = open_in path in
59
+
let rec read_lines acc =
60
+
match input_line ic with
61
+
| line -> read_lines (line :: acc)
62
+
| exception End_of_file ->
63
+
close_in ic;
64
+
List.rev acc
65
+
in
66
+
Some (read_lines [])
67
+
with _ -> None
68
+
69
+
let run_command args =
70
+
let cmd = String.concat " " args in
71
+
try
72
+
let ic = Unix.open_process_in cmd in
73
+
let rec read_lines acc =
74
+
match input_line ic with
75
+
| line -> read_lines (line :: acc)
76
+
| exception End_of_file ->
77
+
ignore (Unix.close_process_in ic);
78
+
List.rev acc
79
+
in
80
+
Some (read_lines [])
81
+
with _ -> None
82
+
83
+
let get_table () =
84
+
(* Try Linux /proc/net/arp first *)
85
+
match read_file "/proc/net/arp" with
86
+
| Some lines -> parse_proc_net_arp lines
87
+
| None -> (
88
+
(* Fall back to arp -a for macOS/BSD *)
89
+
match run_command [ "arp"; "-a" ] with
90
+
| Some lines -> parse_arp_a_output lines
91
+
| None -> [])
92
+
93
+
let lookup ip =
94
+
let entries = get_table () in
95
+
List.find_opt (fun e -> e.ip = ip) entries
96
+
97
+
let lookup_mac ip = Option.map (fun e -> e.mac) (lookup ip)
+31
lib/arp.mli
+31
lib/arp.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** ARP table lookup.
7
+
8
+
Pure OCaml implementation that reads the system ARP cache:
9
+
- Linux: reads [/proc/net/arp] directly
10
+
- macOS/BSD: parses output of [arp -a]
11
+
12
+
{2 Example}
13
+
14
+
{[
15
+
let () =
16
+
List.iter
17
+
(fun entry -> Printf.printf "%s -> %s\n" entry.Arp.ip entry.Arp.mac)
18
+
(Arp.get_table ())
19
+
]} *)
20
+
21
+
type entry = { ip : string; mac : string; interface : string option }
22
+
(** An ARP table entry. *)
23
+
24
+
val get_table : unit -> entry list
25
+
(** [get_table ()] returns all entries from the system ARP cache. *)
26
+
27
+
val lookup : string -> entry option
28
+
(** [lookup ip] finds the ARP entry for the given IP address. *)
29
+
30
+
val lookup_mac : string -> string option
31
+
(** [lookup_mac ip] returns the MAC address for the given IP, if known. *)
-4
lib/eio/dune
-4
lib/eio/dune
-462
lib/eio/sle_eio.ml
-462
lib/eio/sle_eio.ml
···
1
-
(** SLE Eio - Effectful SLE client using Eio.
2
-
3
-
Wraps the pure SLE modules with Eio I/O for TCP communication. Handles TML
4
-
framing, heartbeats, and state machine progression.
5
-
6
-
{b Usage}
7
-
{[
8
-
Eio_main.run @@ fun env ->
9
-
Eio.Switch.run @@ fun sw ->
10
-
let client =
11
-
Sle_eio.connect ~sw ~net:(Eio.Stdenv.net env)
12
-
~clock:(Eio.Stdenv.clock env) config
13
-
in
14
-
Sle_eio.bind client ~initiator_id:"user" ~service_instance_id:si;
15
-
Sle_eio.start_raf client
16
-
(* Receive frames via callback or stream *)
17
-
]}
18
-
19
-
{b Protocol}
20
-
- TML layer handles framing and heartbeats over TCP
21
-
- Bind layer manages session lifecycle
22
-
- RAF layer delivers TM frames in Active state *)
23
-
24
-
module Tml = Sle.Tml
25
-
module Bind = Sle.Bind
26
-
module Raf = Sle.Raf
27
-
module Common = Sle.Common
28
-
module Isp1 = Sle.Isp1
29
-
30
-
let src = Logs.Src.create "sle.eio" ~doc:"SLE Eio client"
31
-
32
-
module Log = (val Logs.src_log src : Logs.LOG)
33
-
34
-
(* {1 Types} *)
35
-
36
-
type error =
37
-
| Connection_failed of string
38
-
| Bind_failed of Bind.bind_diagnostic
39
-
| Start_failed of Raf.start_diagnostic
40
-
| Protocol_error of string
41
-
| Heartbeat_timeout
42
-
| Peer_abort of Bind.peer_abort_diagnostic
43
-
| Closed
44
-
45
-
let pp_error ppf = function
46
-
| Connection_failed s -> Fmt.pf ppf "connection failed: %s" s
47
-
| Bind_failed d -> Fmt.pf ppf "bind failed: %a" Bind.pp_bind_diagnostic d
48
-
| Start_failed d -> Fmt.pf ppf "start failed: %a" Raf.pp_start_diagnostic d
49
-
| Protocol_error s -> Fmt.pf ppf "protocol error: %s" s
50
-
| Heartbeat_timeout -> Fmt.pf ppf "heartbeat timeout"
51
-
| Peer_abort d -> Fmt.pf ppf "peer abort: %a" Bind.pp_peer_abort_diagnostic d
52
-
| Closed -> Fmt.pf ppf "connection closed"
53
-
54
-
type frame = {
55
-
data : bytes;
56
-
quality : Raf.frame_quality;
57
-
earth_receive_time : Common.time option;
58
-
}
59
-
(** Frame received from RAF service *)
60
-
61
-
type config = {
62
-
host : string;
63
-
port : int;
64
-
heartbeat_interval : int; (** Seconds, 0 = disabled *)
65
-
dead_factor : int; (** Missed heartbeats before disconnect *)
66
-
auth : auth_config option;
67
-
}
68
-
69
-
and auth_config = {
70
-
username : string;
71
-
password : string;
72
-
algo : Isp1.hash_algorithm;
73
-
}
74
-
75
-
let default_config ~host ~port =
76
-
{ host; port; heartbeat_interval = 25; dead_factor = 3; auth = None }
77
-
78
-
(* {1 Client State} *)
79
-
80
-
type t = {
81
-
config : config;
82
-
flow : [ `Generic ] Eio.Net.stream_socket_ty Eio.Resource.t;
83
-
clock : float Eio.Time.clock_ty Eio.Resource.t;
84
-
mutable bind_state : Bind.state;
85
-
mutable raf_state : Raf.state;
86
-
mutable last_heartbeat : float;
87
-
mutable invoke_id : int;
88
-
recv_mutex : Eio.Mutex.t;
89
-
send_mutex : Eio.Mutex.t;
90
-
}
91
-
92
-
(* {1 Internal Helpers} *)
93
-
94
-
let next_invoke_id t =
95
-
let id = t.invoke_id in
96
-
t.invoke_id <- t.invoke_id + 1;
97
-
id
98
-
99
-
(** Read exactly n bytes from flow *)
100
-
let read_exact flow n =
101
-
let buf = Bytes.create n in
102
-
let rec loop off =
103
-
if off >= n then buf
104
-
else
105
-
let cs = Cstruct.create (n - off) in
106
-
let got = Eio.Flow.single_read flow cs in
107
-
Cstruct.blit_to_bytes cs 0 buf off got;
108
-
loop (off + got)
109
-
in
110
-
loop 0
111
-
112
-
(** Send TML message *)
113
-
let send_tml t msg =
114
-
Eio.Mutex.use_rw t.send_mutex ~protect:true @@ fun () ->
115
-
let encoded = Tml.encode msg in
116
-
Log.debug (fun m -> m "Sending %a" Tml.pp_message msg);
117
-
Eio.Flow.write t.flow [ Cstruct.of_bytes encoded ]
118
-
119
-
(** Receive TML message *)
120
-
let recv_tml t =
121
-
Eio.Mutex.use_rw t.recv_mutex ~protect:true @@ fun () ->
122
-
(* Read header first *)
123
-
let header = read_exact t.flow Tml.header_len in
124
-
match Tml.decode_header header with
125
-
| Error e ->
126
-
Log.err (fun m -> m "TML header error: %a" Tml.pp_error e);
127
-
Error (Protocol_error (Fmt.str "%a" Tml.pp_error e))
128
-
| Ok (msg_type, payload_len) ->
129
-
let payload =
130
-
if payload_len > 0 then read_exact t.flow payload_len else Bytes.empty
131
-
in
132
-
let msg = { Tml.msg_type; payload } in
133
-
Log.debug (fun m -> m "Received %a" Tml.pp_message msg);
134
-
t.last_heartbeat <- Eio.Time.now t.clock;
135
-
Ok msg
136
-
137
-
(** Send SLE PDU wrapped in TML *)
138
-
let send_pdu t pdu = send_tml t { Tml.msg_type = Sle_pdu; payload = pdu }
139
-
140
-
(** Generate credentials for auth if configured *)
141
-
let make_credentials t =
142
-
match t.config.auth with
143
-
| None -> Common.Unused
144
-
| Some auth -> (
145
-
let time = String.init 8 (fun _ -> '\x00') in
146
-
(* TODO: use real time *)
147
-
let random = Random.int 0x7FFFFFFF in
148
-
match
149
-
Isp1.generate ~algo:auth.algo ~time ~random ~username:auth.username
150
-
~password:auth.password
151
-
with
152
-
| Ok cred -> Isp1.to_common_credentials cred
153
-
| Error _ -> Common.Unused)
154
-
155
-
(* {1 TML Context Exchange} *)
156
-
157
-
let exchange_context t =
158
-
(* Send context message *)
159
-
let ctx =
160
-
{
161
-
Tml.protocol_id = Tml.protocol_isp1;
162
-
version = 1;
163
-
heartbeat_interval = t.config.heartbeat_interval;
164
-
dead_factor = t.config.dead_factor;
165
-
}
166
-
in
167
-
let ctx_msg = Tml.encode_context ctx in
168
-
Eio.Flow.write t.flow [ Cstruct.of_bytes ctx_msg ];
169
-
Log.debug (fun m -> m "Sent context: %a" Tml.pp_context ctx);
170
-
(* Wait for peer context *)
171
-
match recv_tml t with
172
-
| Error e -> Error e
173
-
| Ok msg -> (
174
-
match msg.msg_type with
175
-
| Context -> (
176
-
match Tml.decode_context msg.payload with
177
-
| Ok peer_ctx ->
178
-
Log.info (fun m -> m "Peer context: %a" Tml.pp_context peer_ctx);
179
-
Ok peer_ctx
180
-
| Error e -> Error (Protocol_error (Fmt.str "%a" Tml.pp_error e)))
181
-
| _ -> Error (Protocol_error "expected Context message"))
182
-
183
-
(* {1 Heartbeat Management} *)
184
-
185
-
let send_heartbeat t =
186
-
send_tml t { Tml.msg_type = Heartbeat; payload = Bytes.empty }
187
-
188
-
let check_heartbeat_timeout t =
189
-
if t.config.heartbeat_interval > 0 then begin
190
-
let now = Eio.Time.now t.clock in
191
-
let timeout =
192
-
float_of_int (t.config.heartbeat_interval * t.config.dead_factor)
193
-
in
194
-
if now -. t.last_heartbeat > timeout then begin
195
-
Log.warn (fun m -> m "Heartbeat timeout");
196
-
true
197
-
end
198
-
else false
199
-
end
200
-
else false
201
-
202
-
(* {1 Connection} *)
203
-
204
-
let connect ~sw ~net ~clock config =
205
-
let addr =
206
-
match
207
-
Eio.Net.getaddrinfo_stream net config.host
208
-
~service:(string_of_int config.port)
209
-
with
210
-
| [] -> failwith (Fmt.str "Cannot resolve %s:%d" config.host config.port)
211
-
| addr :: _ -> addr
212
-
in
213
-
Log.info (fun m -> m "Connecting to %s:%d" config.host config.port);
214
-
let flow = Eio.Net.connect ~sw net addr in
215
-
let t =
216
-
{
217
-
config;
218
-
flow;
219
-
clock;
220
-
bind_state = Bind.initial;
221
-
raf_state = Raf.initial;
222
-
last_heartbeat = Eio.Time.now clock;
223
-
invoke_id = 1;
224
-
recv_mutex = Eio.Mutex.create ();
225
-
send_mutex = Eio.Mutex.create ();
226
-
}
227
-
in
228
-
(* Exchange TML context *)
229
-
match exchange_context t with
230
-
| Error e ->
231
-
Eio.Flow.close t.flow;
232
-
Error e
233
-
| Ok _ctx -> Ok t
234
-
235
-
(* {1 Bind/Unbind} *)
236
-
237
-
let bind t ~initiator_id ~responder_port_id ~service_type ~version
238
-
~service_instance_id =
239
-
let inv =
240
-
{
241
-
Bind.invoker_credentials = make_credentials t;
242
-
initiator_id;
243
-
responder_port_id;
244
-
service_type;
245
-
version;
246
-
service_instance_id;
247
-
}
248
-
in
249
-
match Bind.step t.bind_state (Initiate_bind inv) with
250
-
| Error e -> Error (Protocol_error (Fmt.str "%a" Bind.pp_error e))
251
-
| Ok (state', outputs) ->
252
-
t.bind_state <- state';
253
-
(* Send PDU *)
254
-
List.iter (function Bind.Send pdu -> send_pdu t pdu | _ -> ()) outputs;
255
-
(* Wait for response *)
256
-
let rec wait_response () =
257
-
match recv_tml t with
258
-
| Error e -> Error e
259
-
| Ok msg -> (
260
-
match msg.msg_type with
261
-
| Heartbeat ->
262
-
send_heartbeat t;
263
-
wait_response ()
264
-
| Sle_pdu -> (
265
-
match Bind.decode_bind_return msg.payload with
266
-
| Error e ->
267
-
Error (Protocol_error (Fmt.str "%a" Bind.pp_error e))
268
-
| Ok ret -> (
269
-
match Bind.step t.bind_state (Bind_response ret) with
270
-
| Error e ->
271
-
Error (Protocol_error (Fmt.str "%a" Bind.pp_error e))
272
-
| Ok (state', outputs) ->
273
-
t.bind_state <- state';
274
-
let result =
275
-
List.fold_left
276
-
(fun acc out ->
277
-
match (acc, out) with
278
-
| _, Bind.Bound_ok v -> Ok v
279
-
| _, Bind.Bound_failed d -> Error (Bind_failed d)
280
-
| r, _ -> r)
281
-
(Error (Protocol_error "no bind result")) outputs
282
-
in
283
-
result))
284
-
| _ -> Error (Protocol_error "unexpected TML message during bind"))
285
-
in
286
-
wait_response ()
287
-
288
-
let unbind t ~reason =
289
-
let inv = { Bind.invoker_credentials = make_credentials t; reason } in
290
-
match Bind.step t.bind_state (Initiate_unbind inv) with
291
-
| Error e -> Error (Protocol_error (Fmt.str "%a" Bind.pp_error e))
292
-
| Ok (state', outputs) ->
293
-
t.bind_state <- state';
294
-
List.iter (function Bind.Send pdu -> send_pdu t pdu | _ -> ()) outputs;
295
-
(* Wait for response *)
296
-
let rec wait_response () =
297
-
match recv_tml t with
298
-
| Error e -> Error e
299
-
| Ok msg -> (
300
-
match msg.msg_type with
301
-
| Heartbeat ->
302
-
send_heartbeat t;
303
-
wait_response ()
304
-
| Sle_pdu -> (
305
-
match Bind.decode_unbind_return msg.payload with
306
-
| Error e ->
307
-
Error (Protocol_error (Fmt.str "%a" Bind.pp_error e))
308
-
| Ok ret -> (
309
-
match Bind.step t.bind_state (Unbind_response ret) with
310
-
| Error e ->
311
-
Error (Protocol_error (Fmt.str "%a" Bind.pp_error e))
312
-
| Ok (state', _outputs) ->
313
-
t.bind_state <- state';
314
-
Ok ()))
315
-
| _ -> Error (Protocol_error "unexpected message during unbind"))
316
-
in
317
-
wait_response ()
318
-
319
-
(* {1 RAF Service} *)
320
-
321
-
let start_raf t ~start_time ~stop_time ~requested_quality =
322
-
let inv =
323
-
{
324
-
Raf.invoker_credentials = make_credentials t;
325
-
invoke_id = next_invoke_id t;
326
-
start_time;
327
-
stop_time;
328
-
requested_quality;
329
-
}
330
-
in
331
-
match Raf.step t.raf_state (Initiate_start inv) with
332
-
| Error e -> Error (Protocol_error (Fmt.str "%a" Raf.pp_error e))
333
-
| Ok (state', outputs) ->
334
-
t.raf_state <- state';
335
-
List.iter (function Raf.Send pdu -> send_pdu t pdu | _ -> ()) outputs;
336
-
(* Wait for response *)
337
-
let rec wait_response () =
338
-
match recv_tml t with
339
-
| Error e -> Error e
340
-
| Ok msg -> (
341
-
match msg.msg_type with
342
-
| Heartbeat ->
343
-
send_heartbeat t;
344
-
wait_response ()
345
-
| Sle_pdu -> (
346
-
match Raf.decode_start_return msg.payload with
347
-
| Error e ->
348
-
Error (Protocol_error (Fmt.str "%a" Raf.pp_error e))
349
-
| Ok ret -> (
350
-
match Raf.step t.raf_state (Start_response ret) with
351
-
| Error e ->
352
-
Error (Protocol_error (Fmt.str "%a" Raf.pp_error e))
353
-
| Ok (state', outputs) ->
354
-
t.raf_state <- state';
355
-
let result =
356
-
List.fold_left
357
-
(fun acc out ->
358
-
match (acc, out) with
359
-
| _, Raf.Started -> Ok ()
360
-
| _, Raf.Start_failed d -> Error (Start_failed d)
361
-
| r, _ -> r)
362
-
(Error (Protocol_error "no start result")) outputs
363
-
in
364
-
result))
365
-
| _ -> Error (Protocol_error "unexpected message during start"))
366
-
in
367
-
wait_response ()
368
-
369
-
let stop_raf t =
370
-
let inv =
371
-
{
372
-
Raf.invoker_credentials = make_credentials t;
373
-
invoke_id = next_invoke_id t;
374
-
}
375
-
in
376
-
match Raf.step t.raf_state (Initiate_stop inv) with
377
-
| Error e -> Error (Protocol_error (Fmt.str "%a" Raf.pp_error e))
378
-
| Ok (state', outputs) ->
379
-
t.raf_state <- state';
380
-
List.iter (function Raf.Send pdu -> send_pdu t pdu | _ -> ()) outputs;
381
-
(* Wait for response *)
382
-
let rec wait_response () =
383
-
match recv_tml t with
384
-
| Error e -> Error e
385
-
| Ok msg -> (
386
-
match msg.msg_type with
387
-
| Heartbeat ->
388
-
send_heartbeat t;
389
-
wait_response ()
390
-
| Sle_pdu -> (
391
-
match Raf.decode_stop_return msg.payload with
392
-
| Error e ->
393
-
Error (Protocol_error (Fmt.str "%a" Raf.pp_error e))
394
-
| Ok ret -> (
395
-
match Raf.step t.raf_state (Stop_response ret) with
396
-
| Error e ->
397
-
Error (Protocol_error (Fmt.str "%a" Raf.pp_error e))
398
-
| Ok (state', _outputs) ->
399
-
t.raf_state <- state';
400
-
Ok ()))
401
-
| _ -> Error (Protocol_error "unexpected message during stop"))
402
-
in
403
-
wait_response ()
404
-
405
-
(** Receive next frame from RAF service. Handles heartbeats internally. *)
406
-
let recv_frame t =
407
-
if t.raf_state <> Raf.Active then Error (Protocol_error "RAF not active")
408
-
else
409
-
let rec loop () =
410
-
if check_heartbeat_timeout t then Error Heartbeat_timeout
411
-
else
412
-
match recv_tml t with
413
-
| Error e -> Error e
414
-
| Ok msg -> (
415
-
match msg.msg_type with
416
-
| Heartbeat ->
417
-
send_heartbeat t;
418
-
loop ()
419
-
| Sle_pdu -> (
420
-
(* Try to decode as transfer data *)
421
-
match Raf.decode_transfer_data msg.payload with
422
-
| Error _ -> (
423
-
(* Might be peer abort *)
424
-
match Bind.decode_peer_abort msg.payload with
425
-
| Ok abort ->
426
-
let _ =
427
-
Bind.step t.bind_state (Peer_abort_received abort)
428
-
in
429
-
t.bind_state <- Bind.Unbound;
430
-
Error (Peer_abort abort.diagnostic)
431
-
| Error _ -> Error (Protocol_error "unknown PDU"))
432
-
| Ok td -> (
433
-
match Raf.step t.raf_state (Transfer_data_received td) with
434
-
| Error e ->
435
-
Error (Protocol_error (Fmt.str "%a" Raf.pp_error e))
436
-
| Ok (state', outputs) -> (
437
-
t.raf_state <- state';
438
-
let frame =
439
-
List.find_map
440
-
(function
441
-
| Raf.Frame_received (Raf.Frame f) ->
442
-
Some
443
-
{
444
-
data = f.data;
445
-
quality = f.quality;
446
-
earth_receive_time = f.earth_receive_time;
447
-
}
448
-
| _ -> None)
449
-
outputs
450
-
in
451
-
match frame with Some f -> Ok f | None -> loop ())))
452
-
| Context ->
453
-
(* Ignore context messages after initial exchange *)
454
-
loop ())
455
-
in
456
-
loop ()
457
-
458
-
(* {1 Cleanup} *)
459
-
460
-
let close t =
461
-
Log.debug (fun m -> m "Closing SLE connection");
462
-
Eio.Flow.close t.flow
-145
lib/eio/sle_eio.mli
-145
lib/eio/sle_eio.mli
···
1
-
(** SLE Eio - Effectful SLE client using Eio.
2
-
3
-
Wraps the pure SLE modules with Eio I/O for TCP communication. Handles TML
4
-
framing, heartbeats, and state machine progression.
5
-
6
-
{2 Example: RAF Client}
7
-
8
-
{[
9
-
Eio_main.run @@ fun env ->
10
-
Eio.Switch.run @@ fun sw ->
11
-
let config = default_config ~host:"sle-provider.example.com" ~port:5100 in
12
-
match
13
-
connect ~sw ~net:(Eio.Stdenv.net env) ~clock:(Eio.Stdenv.clock env)
14
-
config
15
-
with
16
-
| Error e -> Fmt.epr "Connection failed: %a@." pp_error e
17
-
| Ok client -> (
18
-
match
19
-
bind client ~initiator_id:"user" ~responder_port_id:"RAF"
20
-
~service_type:Bind.Raf_all ~version:5
21
-
~service_instance_id:"sagr=1.spack=..."
22
-
with
23
-
| Error e -> Fmt.epr "Bind failed: %a@." pp_error e
24
-
| Ok _version -> (
25
-
match
26
-
start_raf client ~start_time:None ~stop_time:None
27
-
~requested_quality:Good
28
-
with
29
-
| Error e -> Fmt.epr "Start failed: %a@." pp_error e
30
-
| Ok () ->
31
-
(* Receive frames *)
32
-
let rec loop () =
33
-
match recv_frame client with
34
-
| Error Closed -> ()
35
-
| Error e -> Fmt.epr "Error: %a@." pp_error e
36
-
| Ok frame ->
37
-
process_frame frame.data;
38
-
loop ()
39
-
in
40
-
loop ()))
41
-
]} *)
42
-
43
-
(** {1 Re-exports} *)
44
-
45
-
module Tml = Sle.Tml
46
-
module Bind = Sle.Bind
47
-
module Raf = Sle.Raf
48
-
module Common = Sle.Common
49
-
module Isp1 = Sle.Isp1
50
-
51
-
(** {1 Errors} *)
52
-
53
-
type error =
54
-
| Connection_failed of string
55
-
| Bind_failed of Bind.bind_diagnostic
56
-
| Start_failed of Raf.start_diagnostic
57
-
| Protocol_error of string
58
-
| Heartbeat_timeout
59
-
| Peer_abort of Bind.peer_abort_diagnostic
60
-
| Closed
61
-
62
-
val pp_error : error Fmt.t
63
-
64
-
(** {1 Types} *)
65
-
66
-
type frame = {
67
-
data : bytes;
68
-
quality : Raf.frame_quality;
69
-
earth_receive_time : Common.time option;
70
-
}
71
-
(** Frame received from RAF service. *)
72
-
73
-
type config = {
74
-
host : string;
75
-
port : int;
76
-
heartbeat_interval : int; (** Seconds, 0 = disabled *)
77
-
dead_factor : int; (** Missed heartbeats before disconnect *)
78
-
auth : auth_config option;
79
-
}
80
-
81
-
and auth_config = {
82
-
username : string;
83
-
password : string;
84
-
algo : Isp1.hash_algorithm;
85
-
}
86
-
87
-
val default_config : host:string -> port:int -> config
88
-
(** [default_config ~host ~port] creates config with:
89
-
- heartbeat_interval: 25s
90
-
- dead_factor: 3
91
-
- auth: None *)
92
-
93
-
(** {1 Client} *)
94
-
95
-
type t
96
-
(** SLE client instance. *)
97
-
98
-
val connect :
99
-
sw:Eio.Switch.t ->
100
-
net:[> [ `Generic ] Eio.Net.ty ] Eio.Resource.t ->
101
-
clock:float Eio.Time.clock_ty Eio.Resource.t ->
102
-
config ->
103
-
(t, error) result
104
-
(** [connect ~sw ~net ~clock config] establishes connection and exchanges TML
105
-
context. *)
106
-
107
-
(** {2 Bind/Unbind} *)
108
-
109
-
val bind :
110
-
t ->
111
-
initiator_id:string ->
112
-
responder_port_id:string ->
113
-
service_type:Bind.service_type ->
114
-
version:int ->
115
-
service_instance_id:Common.service_instance_id ->
116
-
(int, error) result
117
-
(** [bind t ~initiator_id ~responder_port_id ~service_type ~version
118
-
~service_instance_id] binds to an SLE service. Returns the negotiated
119
-
version on success. *)
120
-
121
-
val unbind : t -> reason:Bind.unbind_reason -> (unit, error) result
122
-
(** [unbind t ~reason] unbinds from the SLE service. *)
123
-
124
-
(** {2 RAF Service} *)
125
-
126
-
val start_raf :
127
-
t ->
128
-
start_time:Common.time option ->
129
-
stop_time:Common.time option ->
130
-
requested_quality:Common.requested_frame_quality ->
131
-
(unit, error) result
132
-
(** [start_raf t ~start_time ~stop_time ~requested_quality] starts the RAF
133
-
transfer service. *)
134
-
135
-
val stop_raf : t -> (unit, error) result
136
-
(** [stop_raf t] stops the RAF transfer service. *)
137
-
138
-
val recv_frame : t -> (frame, error) result
139
-
(** [recv_frame t] receives the next frame from the RAF service. Handles
140
-
heartbeats internally. *)
141
-
142
-
(** {2 Cleanup} *)
143
-
144
-
val close : t -> unit
145
-
(** [close t] closes the connection. *)
-402
lib/sle/bind.ml
-402
lib/sle/bind.ml
···
1
-
(** SLE Bind/Unbind Protocol (CCSDS 913.1-B-2 Section 3).
2
-
3
-
Pure module - no I/O effects. Implements bind/unbind state machine and PDU
4
-
encoding/decoding for SLE session management.
5
-
6
-
Session lifecycle:
7
-
{v
8
-
[Unbound] --bind_invoke--> [Bind_pending]
9
-
<--bind_return-- [Bound] or [Unbound] (on reject)
10
-
11
-
[Bound] --unbind_invoke--> [Unbind_pending]
12
-
<--unbind_return-- [Unbound]
13
-
14
-
[Any] --peer_abort--> [Unbound]
15
-
v} *)
16
-
17
-
open Asn.S
18
-
19
-
(* {1 Application Identifiers} *)
20
-
21
-
type service_type =
22
-
| Raf (** Return All Frames *)
23
-
| Rcf (** Return Channel Frames *)
24
-
| Rocf (** Return Operational Control Fields *)
25
-
| Fcltu (** Forward CLTU *)
26
-
| Fsp (** Forward Space Packet *)
27
-
| Unknown_service_type of int (** Unknown value from untrusted PDU *)
28
-
29
-
(* {1 Diagnostics} *)
30
-
31
-
type bind_diagnostic =
32
-
| Access_denied
33
-
| Service_type_not_supported
34
-
| Version_not_supported
35
-
| No_such_service_instance
36
-
| Already_bound
37
-
| Si_not_accessible_to_this_initiator
38
-
| Inconsistent_service_type
39
-
| Invalid_time
40
-
| Out_of_service
41
-
| Other_reason
42
-
| Unknown_bind_diagnostic of int (** Unknown value from untrusted PDU *)
43
-
44
-
type unbind_reason =
45
-
| End
46
-
| Suspend
47
-
| Version_not_supported_unbind
48
-
| Other_unbind
49
-
| Unknown_unbind_reason of int (** Unknown value from untrusted PDU *)
50
-
51
-
type peer_abort_diagnostic =
52
-
| Access_denied_abort
53
-
| Unexpected_responder_id
54
-
| Operational_requirement
55
-
| Protocol_error
56
-
| Communications_failure
57
-
| Encoding_error
58
-
| Return_timeout
59
-
| End_of_service_provision_period
60
-
| Unsolicited_invoke_id
61
-
| Other_abort
62
-
| Unknown_peer_abort_diagnostic of int
63
-
(** Unknown value from untrusted PDU *)
64
-
65
-
(* {1 PDU Types} *)
66
-
67
-
type bind_invocation = {
68
-
invoker_credentials : Common.credentials;
69
-
initiator_id : string;
70
-
responder_port_id : string;
71
-
service_type : service_type;
72
-
version : int;
73
-
service_instance_id : Common.service_instance_id;
74
-
}
75
-
76
-
type bind_return = {
77
-
performer_credentials : Common.credentials;
78
-
responder_id : string;
79
-
result : (int, bind_diagnostic) result; (** Ok version or Error diagnostic *)
80
-
}
81
-
82
-
type unbind_invocation = {
83
-
invoker_credentials : Common.credentials;
84
-
reason : unbind_reason;
85
-
}
86
-
87
-
type unbind_return = { responder_credentials : Common.credentials }
88
-
type peer_abort = { diagnostic : peer_abort_diagnostic }
89
-
90
-
(* {1 State Machine} *)
91
-
92
-
type state = Unbound | Bind_pending | Bound | Unbind_pending
93
-
94
-
type output =
95
-
| Send of bytes (** PDU to send *)
96
-
| Bound_ok of int (** Bound with version *)
97
-
| Bound_failed of bind_diagnostic (** Bind rejected *)
98
-
| Unbound_ok (** Clean unbind *)
99
-
| Aborted of peer_abort_diagnostic (** Peer abort received *)
100
-
101
-
type input =
102
-
| Initiate_bind of bind_invocation
103
-
| Bind_response of bind_return
104
-
| Initiate_unbind of unbind_invocation
105
-
| Unbind_response of unbind_return
106
-
| Peer_abort_received of peer_abort
107
-
| Send_peer_abort of peer_abort_diagnostic
108
-
109
-
type error =
110
-
| Invalid_state of { expected : state; actual : state }
111
-
| Decode_error of string
112
-
113
-
(* {1 ASN.1 Grammars} *)
114
-
115
-
let _service_type_grammar =
116
-
map
117
-
(function
118
-
| 0 -> Raf
119
-
| 2 -> Rcf
120
-
| 1 -> Rocf
121
-
| 16 -> Fcltu
122
-
| 9 -> Fsp
123
-
| n -> Unknown_service_type n)
124
-
(function
125
-
| Raf -> 0
126
-
| Rcf -> 2
127
-
| Rocf -> 1
128
-
| Fcltu -> 16
129
-
| Fsp -> 9
130
-
| Unknown_service_type n -> n)
131
-
int
132
-
133
-
let bind_diagnostic_grammar =
134
-
map
135
-
(function
136
-
| 0 -> Access_denied
137
-
| 1 -> Service_type_not_supported
138
-
| 2 -> Version_not_supported
139
-
| 3 -> No_such_service_instance
140
-
| 4 -> Already_bound
141
-
| 5 -> Si_not_accessible_to_this_initiator
142
-
| 6 -> Inconsistent_service_type
143
-
| 7 -> Invalid_time
144
-
| 8 -> Out_of_service
145
-
| 127 -> Other_reason
146
-
| n -> Unknown_bind_diagnostic n)
147
-
(function
148
-
| Access_denied -> 0
149
-
| Service_type_not_supported -> 1
150
-
| Version_not_supported -> 2
151
-
| No_such_service_instance -> 3
152
-
| Already_bound -> 4
153
-
| Si_not_accessible_to_this_initiator -> 5
154
-
| Inconsistent_service_type -> 6
155
-
| Invalid_time -> 7
156
-
| Out_of_service -> 8
157
-
| Other_reason -> 127
158
-
| Unknown_bind_diagnostic n -> n)
159
-
int
160
-
161
-
let unbind_reason_grammar =
162
-
map
163
-
(function
164
-
| 0 -> End
165
-
| 1 -> Suspend
166
-
| 2 -> Version_not_supported_unbind
167
-
| 127 -> Other_unbind
168
-
| n -> Unknown_unbind_reason n)
169
-
(function
170
-
| End -> 0
171
-
| Suspend -> 1
172
-
| Version_not_supported_unbind -> 2
173
-
| Other_unbind -> 127
174
-
| Unknown_unbind_reason n -> n)
175
-
int
176
-
177
-
let peer_abort_diagnostic_grammar =
178
-
map
179
-
(function
180
-
| 0 -> Access_denied_abort
181
-
| 1 -> Unexpected_responder_id
182
-
| 2 -> Operational_requirement
183
-
| 3 -> Protocol_error
184
-
| 4 -> Communications_failure
185
-
| 5 -> Encoding_error
186
-
| 6 -> Return_timeout
187
-
| 7 -> End_of_service_provision_period
188
-
| 8 -> Unsolicited_invoke_id
189
-
| 127 -> Other_abort
190
-
| n -> Unknown_peer_abort_diagnostic n)
191
-
(function
192
-
| Access_denied_abort -> 0
193
-
| Unexpected_responder_id -> 1
194
-
| Operational_requirement -> 2
195
-
| Protocol_error -> 3
196
-
| Communications_failure -> 4
197
-
| Encoding_error -> 5
198
-
| Return_timeout -> 6
199
-
| End_of_service_provision_period -> 7
200
-
| Unsolicited_invoke_id -> 8
201
-
| Other_abort -> 127
202
-
| Unknown_peer_abort_diagnostic n -> n)
203
-
int
204
-
205
-
(* Service instance ID is a sequence of OID-like components *)
206
-
let _service_instance_id_grammar =
207
-
(* Simplified: encode as visible_string for now.
208
-
For malformed input, return a placeholder with the raw string preserved. *)
209
-
map
210
-
(fun s ->
211
-
(* Parse "scid.facility.service.instance" *)
212
-
match String.split_on_char '.' s with
213
-
| [ sc; fac; svc; inst ] -> (
214
-
match int_of_string_opt inst with
215
-
| Some n ->
216
-
{
217
-
Common.spacecraft_id = sc;
218
-
facility_id = fac;
219
-
service_type = svc;
220
-
instance_number = n;
221
-
}
222
-
| None ->
223
-
(* Invalid instance number - preserve raw string *)
224
-
{
225
-
Common.spacecraft_id = s;
226
-
facility_id = "";
227
-
service_type = "invalid";
228
-
instance_number = 0;
229
-
})
230
-
| _ ->
231
-
(* Invalid format - preserve raw string in spacecraft_id for debugging *)
232
-
{
233
-
Common.spacecraft_id = s;
234
-
facility_id = "";
235
-
service_type = "invalid";
236
-
instance_number = 0;
237
-
})
238
-
(fun si ->
239
-
Printf.sprintf "%s.%s.%s.%d" si.Common.spacecraft_id si.facility_id
240
-
si.service_type si.instance_number)
241
-
visible_string
242
-
243
-
(* Bind invocation - simplified grammar *)
244
-
let bind_invocation_grammar =
245
-
sequence3
246
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
247
-
(required ~label:"initiatorIdentifier" visible_string)
248
-
(required ~label:"version" int)
249
-
250
-
(* Bind return - result is CHOICE of version or diagnostic *)
251
-
let bind_return_result_grammar =
252
-
map
253
-
(function `C1 v -> Ok v | `C2 d -> Error d)
254
-
(function Ok v -> `C1 v | Error d -> `C2 d)
255
-
(choice2 (implicit 0 int) (implicit 1 bind_diagnostic_grammar))
256
-
257
-
let bind_return_grammar =
258
-
sequence3
259
-
(required ~label:"performerCredentials" Common.credentials_grammar)
260
-
(required ~label:"responderIdentifier" visible_string)
261
-
(required ~label:"result" bind_return_result_grammar)
262
-
263
-
let unbind_invocation_grammar =
264
-
sequence2
265
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
266
-
(required ~label:"unbindReason" unbind_reason_grammar)
267
-
268
-
let unbind_return_grammar =
269
-
map (fun cred -> cred) (fun cred -> cred) Common.credentials_grammar
270
-
271
-
let peer_abort_grammar = peer_abort_diagnostic_grammar
272
-
273
-
(* {1 Encoding} *)
274
-
275
-
let encode_bind_invocation (inv : bind_invocation) =
276
-
let codec = Asn.codec Asn.ber bind_invocation_grammar in
277
-
let s =
278
-
Asn.encode codec (inv.invoker_credentials, inv.initiator_id, inv.version)
279
-
in
280
-
Bytes.of_string s
281
-
282
-
let encode_bind_return (ret : bind_return) =
283
-
let codec = Asn.codec Asn.ber bind_return_grammar in
284
-
let s =
285
-
Asn.encode codec (ret.performer_credentials, ret.responder_id, ret.result)
286
-
in
287
-
Bytes.of_string s
288
-
289
-
let encode_unbind_invocation (inv : unbind_invocation) =
290
-
let codec = Asn.codec Asn.ber unbind_invocation_grammar in
291
-
let s = Asn.encode codec (inv.invoker_credentials, inv.reason) in
292
-
Bytes.of_string s
293
-
294
-
let encode_unbind_return (ret : unbind_return) =
295
-
let codec = Asn.codec Asn.ber unbind_return_grammar in
296
-
let s = Asn.encode codec ret.responder_credentials in
297
-
Bytes.of_string s
298
-
299
-
let encode_peer_abort (abort : peer_abort) =
300
-
let codec = Asn.codec Asn.ber peer_abort_grammar in
301
-
let s = Asn.encode codec abort.diagnostic in
302
-
Bytes.of_string s
303
-
304
-
(* {1 Decoding} *)
305
-
306
-
let decode_bind_return buf =
307
-
let codec = Asn.codec Asn.ber bind_return_grammar in
308
-
match Asn.decode codec (Bytes.to_string buf) with
309
-
| Ok ((cred, resp_id, result), _) ->
310
-
Ok { performer_credentials = cred; responder_id = resp_id; result }
311
-
| Error _ -> Error (Decode_error "bind return")
312
-
313
-
let decode_unbind_return buf =
314
-
let codec = Asn.codec Asn.ber unbind_return_grammar in
315
-
match Asn.decode codec (Bytes.to_string buf) with
316
-
| Ok (cred, _) -> Ok { responder_credentials = cred }
317
-
| Error _ -> Error (Decode_error "unbind return")
318
-
319
-
let decode_peer_abort buf =
320
-
let codec = Asn.codec Asn.ber peer_abort_grammar in
321
-
match Asn.decode codec (Bytes.to_string buf) with
322
-
| Ok (diag, _) -> Ok { diagnostic = diag }
323
-
| Error _ -> Error (Decode_error "peer abort")
324
-
325
-
(* {1 State Machine} *)
326
-
327
-
let initial = Unbound
328
-
329
-
let step state input =
330
-
match (state, input) with
331
-
| Unbound, Initiate_bind inv ->
332
-
let pdu = encode_bind_invocation inv in
333
-
Ok (Bind_pending, [ Send pdu ])
334
-
| Bind_pending, Bind_response ret -> (
335
-
match ret.result with
336
-
| Ok version -> Ok (Bound, [ Bound_ok version ])
337
-
| Error diag -> Ok (Unbound, [ Bound_failed diag ]))
338
-
| Bound, Initiate_unbind inv ->
339
-
let pdu = encode_unbind_invocation inv in
340
-
Ok (Unbind_pending, [ Send pdu ])
341
-
| Unbind_pending, Unbind_response _ret -> Ok (Unbound, [ Unbound_ok ])
342
-
| _, Peer_abort_received abort -> Ok (Unbound, [ Aborted abort.diagnostic ])
343
-
| _, Send_peer_abort diag ->
344
-
let pdu = encode_peer_abort { diagnostic = diag } in
345
-
Ok (Unbound, [ Send pdu; Aborted diag ])
346
-
| _, _ -> Error (Invalid_state { expected = state; actual = state })
347
-
348
-
(* {1 Pretty-printers} *)
349
-
350
-
let pp_service_type ppf = function
351
-
| Raf -> Fmt.string ppf "RAF"
352
-
| Rcf -> Fmt.string ppf "RCF"
353
-
| Rocf -> Fmt.string ppf "ROCF"
354
-
| Fcltu -> Fmt.string ppf "FCLTU"
355
-
| Fsp -> Fmt.string ppf "FSP"
356
-
| Unknown_service_type n -> Fmt.pf ppf "unknown(%d)" n
357
-
358
-
let pp_state ppf = function
359
-
| Unbound -> Fmt.string ppf "Unbound"
360
-
| Bind_pending -> Fmt.string ppf "Bind_pending"
361
-
| Bound -> Fmt.string ppf "Bound"
362
-
| Unbind_pending -> Fmt.string ppf "Unbind_pending"
363
-
364
-
let pp_bind_diagnostic ppf = function
365
-
| Access_denied -> Fmt.string ppf "access-denied"
366
-
| Service_type_not_supported -> Fmt.string ppf "service-type-not-supported"
367
-
| Version_not_supported -> Fmt.string ppf "version-not-supported"
368
-
| No_such_service_instance -> Fmt.string ppf "no-such-service-instance"
369
-
| Already_bound -> Fmt.string ppf "already-bound"
370
-
| Si_not_accessible_to_this_initiator ->
371
-
Fmt.string ppf "si-not-accessible-to-this-initiator"
372
-
| Inconsistent_service_type -> Fmt.string ppf "inconsistent-service-type"
373
-
| Invalid_time -> Fmt.string ppf "invalid-time"
374
-
| Out_of_service -> Fmt.string ppf "out-of-service"
375
-
| Other_reason -> Fmt.string ppf "other-reason"
376
-
| Unknown_bind_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
377
-
378
-
let pp_unbind_reason ppf = function
379
-
| End -> Fmt.string ppf "end"
380
-
| Suspend -> Fmt.string ppf "suspend"
381
-
| Version_not_supported_unbind -> Fmt.string ppf "version-not-supported"
382
-
| Other_unbind -> Fmt.string ppf "other"
383
-
| Unknown_unbind_reason n -> Fmt.pf ppf "unknown(%d)" n
384
-
385
-
let pp_peer_abort_diagnostic ppf = function
386
-
| Access_denied_abort -> Fmt.string ppf "access-denied"
387
-
| Unexpected_responder_id -> Fmt.string ppf "unexpected-responder-id"
388
-
| Operational_requirement -> Fmt.string ppf "operational-requirement"
389
-
| Protocol_error -> Fmt.string ppf "protocol-error"
390
-
| Communications_failure -> Fmt.string ppf "communications-failure"
391
-
| Encoding_error -> Fmt.string ppf "encoding-error"
392
-
| Return_timeout -> Fmt.string ppf "return-timeout"
393
-
| End_of_service_provision_period -> Fmt.string ppf "end-of-service"
394
-
| Unsolicited_invoke_id -> Fmt.string ppf "unsolicited-invoke-id"
395
-
| Other_abort -> Fmt.string ppf "other"
396
-
| Unknown_peer_abort_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
397
-
398
-
let pp_error ppf = function
399
-
| Invalid_state { expected; actual } ->
400
-
Fmt.pf ppf "invalid state: expected %a, actual %a" pp_state expected
401
-
pp_state actual
402
-
| Decode_error s -> Fmt.pf ppf "decode error: %s" s
-141
lib/sle/bind.mli
-141
lib/sle/bind.mli
···
1
-
(** SLE Bind/Unbind Protocol (CCSDS 913.1-B-2 Section 3).
2
-
3
-
Pure module - no I/O effects. Implements bind/unbind state machine and PDU
4
-
encoding/decoding for SLE session management.
5
-
6
-
Session lifecycle:
7
-
{v
8
-
[Unbound] --bind_invoke--> [Bind_pending]
9
-
<--bind_return-- [Bound] or [Unbound] (on reject)
10
-
11
-
[Bound] --unbind_invoke--> [Unbind_pending]
12
-
<--unbind_return-- [Unbound]
13
-
14
-
[Any] --peer_abort--> [Unbound]
15
-
v} *)
16
-
17
-
(** {1 Application Identifiers} *)
18
-
19
-
type service_type =
20
-
| Raf (** Return All Frames *)
21
-
| Rcf (** Return Channel Frames *)
22
-
| Rocf (** Return Operational Control Fields *)
23
-
| Fcltu (** Forward CLTU *)
24
-
| Fsp (** Forward Space Packet *)
25
-
| Unknown_service_type of int (** Unknown value from untrusted PDU *)
26
-
27
-
(** {1 Diagnostics} *)
28
-
29
-
type bind_diagnostic =
30
-
| Access_denied
31
-
| Service_type_not_supported
32
-
| Version_not_supported
33
-
| No_such_service_instance
34
-
| Already_bound
35
-
| Si_not_accessible_to_this_initiator
36
-
| Inconsistent_service_type
37
-
| Invalid_time
38
-
| Out_of_service
39
-
| Other_reason
40
-
| Unknown_bind_diagnostic of int (** Unknown value from untrusted PDU *)
41
-
42
-
type unbind_reason =
43
-
| End
44
-
| Suspend
45
-
| Version_not_supported_unbind
46
-
| Other_unbind
47
-
| Unknown_unbind_reason of int (** Unknown value from untrusted PDU *)
48
-
49
-
type peer_abort_diagnostic =
50
-
| Access_denied_abort
51
-
| Unexpected_responder_id
52
-
| Operational_requirement
53
-
| Protocol_error
54
-
| Communications_failure
55
-
| Encoding_error
56
-
| Return_timeout
57
-
| End_of_service_provision_period
58
-
| Unsolicited_invoke_id
59
-
| Other_abort
60
-
| Unknown_peer_abort_diagnostic of int
61
-
(** Unknown value from untrusted PDU *)
62
-
63
-
(** {1 PDU Types} *)
64
-
65
-
type bind_invocation = {
66
-
invoker_credentials : Common.credentials;
67
-
initiator_id : string;
68
-
responder_port_id : string;
69
-
service_type : service_type;
70
-
version : int;
71
-
service_instance_id : Common.service_instance_id;
72
-
}
73
-
74
-
type bind_return = {
75
-
performer_credentials : Common.credentials;
76
-
responder_id : string;
77
-
result : (int, bind_diagnostic) result; (** Ok version or Error diagnostic *)
78
-
}
79
-
80
-
type unbind_invocation = {
81
-
invoker_credentials : Common.credentials;
82
-
reason : unbind_reason;
83
-
}
84
-
85
-
type unbind_return = { responder_credentials : Common.credentials }
86
-
type peer_abort = { diagnostic : peer_abort_diagnostic }
87
-
88
-
(** {1 State Machine} *)
89
-
90
-
type state = Unbound | Bind_pending | Bound | Unbind_pending
91
-
92
-
type output =
93
-
| Send of bytes (** PDU to send *)
94
-
| Bound_ok of int (** Bound with version *)
95
-
| Bound_failed of bind_diagnostic (** Bind rejected *)
96
-
| Unbound_ok (** Clean unbind *)
97
-
| Aborted of peer_abort_diagnostic (** Peer abort received *)
98
-
99
-
type input =
100
-
| Initiate_bind of bind_invocation
101
-
| Bind_response of bind_return
102
-
| Initiate_unbind of unbind_invocation
103
-
| Unbind_response of unbind_return
104
-
| Peer_abort_received of peer_abort
105
-
| Send_peer_abort of peer_abort_diagnostic
106
-
107
-
type error =
108
-
| Invalid_state of { expected : state; actual : state }
109
-
| Decode_error of string
110
-
111
-
(** {1 State Machine Operations} *)
112
-
113
-
val initial : state
114
-
(** Initial state is [Unbound]. *)
115
-
116
-
val step : state -> input -> (state * output list, error) result
117
-
(** [step state input] processes an input event and returns new state with
118
-
outputs. *)
119
-
120
-
(** {1 Encoding} *)
121
-
122
-
val encode_bind_invocation : bind_invocation -> bytes
123
-
val encode_bind_return : bind_return -> bytes
124
-
val encode_unbind_invocation : unbind_invocation -> bytes
125
-
val encode_unbind_return : unbind_return -> bytes
126
-
val encode_peer_abort : peer_abort -> bytes
127
-
128
-
(** {1 Decoding} *)
129
-
130
-
val decode_bind_return : bytes -> (bind_return, error) result
131
-
val decode_unbind_return : bytes -> (unbind_return, error) result
132
-
val decode_peer_abort : bytes -> (peer_abort, error) result
133
-
134
-
(** {1 Pretty-printers} *)
135
-
136
-
val pp_service_type : service_type Fmt.t
137
-
val pp_state : state Fmt.t
138
-
val pp_bind_diagnostic : bind_diagnostic Fmt.t
139
-
val pp_unbind_reason : unbind_reason Fmt.t
140
-
val pp_peer_abort_diagnostic : peer_abort_diagnostic Fmt.t
141
-
val pp_error : error Fmt.t
-203
lib/sle/common.ml
-203
lib/sle/common.ml
···
1
-
(** Common SLE ASN.1 types (CCSDS 913.1-B-2).
2
-
3
-
Pure module - no I/O effects. Defines shared types used across all SLE
4
-
services: credentials, time formats, diagnostics, and delivery modes. *)
5
-
6
-
open Asn.S
7
-
8
-
(* {1 Numeric Types} *)
9
-
10
-
type invoke_id = int
11
-
type int_pos_long = int
12
-
type int_unsigned_long = int
13
-
type int_pos_short = int
14
-
type int_unsigned_short = int
15
-
16
-
(* {1 Time Formats} *)
17
-
18
-
(** CCSDS time formats. *)
19
-
type time =
20
-
| Ccsds of string (** 8-byte CDS: days + ms + us *)
21
-
| Ccsds_pico of string (** 10-byte CDS: days + ms + ps *)
22
-
23
-
type conditional_time = time option
24
-
25
-
(* {1 Credentials} *)
26
-
27
-
(** Authentication credentials - either unused or ISP1. *)
28
-
type credentials =
29
-
| Unused
30
-
| Used of string (** 8-256 bytes, structure per ISP1 *)
31
-
32
-
(* {1 Delivery Mode} *)
33
-
34
-
type delivery_mode =
35
-
| Timely_online
36
-
| Complete_online
37
-
| Offline
38
-
| Forward_online
39
-
| Forward_offline
40
-
| Unknown_delivery_mode of int (** Unknown value from untrusted PDU *)
41
-
42
-
(* {1 Diagnostics} *)
43
-
44
-
type diagnostics = Duplicate_invoke_id | Other of int
45
-
46
-
(* {1 Duration} *)
47
-
48
-
type duration = int
49
-
(** Duration in microseconds. *)
50
-
51
-
(* {1 Frame Quality} *)
52
-
53
-
type frame_quality =
54
-
| Good
55
-
| Erred
56
-
| Undetermined
57
-
| Unknown_frame_quality of int (** Unknown value from untrusted PDU *)
58
-
59
-
type requested_frame_quality =
60
-
| Good_only
61
-
| Erred_only
62
-
| All_frames
63
-
| Unknown_requested_frame_quality of int
64
-
(** Unknown value from untrusted PDU *)
65
-
66
-
(* {1 Service Instance ID} *)
67
-
68
-
type service_instance_id = {
69
-
spacecraft_id : string;
70
-
facility_id : string;
71
-
service_type : string;
72
-
instance_number : int;
73
-
}
74
-
(** Service instance identifier per CCSDS 913.1-B-2. *)
75
-
76
-
(* {1 ASN.1 Grammars} *)
77
-
78
-
let time_ccsds = octet_string
79
-
let time_ccsds_pico = octet_string
80
-
81
-
let time_grammar =
82
-
map
83
-
(function `C1 t -> Ccsds t | `C2 t -> Ccsds_pico t)
84
-
(function Ccsds t -> `C1 t | Ccsds_pico t -> `C2 t)
85
-
(choice2 (implicit 0 time_ccsds) (implicit 1 time_ccsds_pico))
86
-
87
-
let conditional_time_grammar =
88
-
map
89
-
(function `C1 () -> None | `C2 t -> Some t)
90
-
(function None -> `C1 () | Some t -> `C2 t)
91
-
(choice2 null time_grammar)
92
-
93
-
let credentials_grammar =
94
-
map
95
-
(function `C1 () -> Unused | `C2 b -> Used b)
96
-
(function Unused -> `C1 () | Used b -> `C2 b)
97
-
(choice2 (implicit 0 null) (implicit 1 octet_string))
98
-
99
-
let delivery_mode_grammar =
100
-
map
101
-
(function
102
-
| 0 -> Timely_online
103
-
| 1 -> Complete_online
104
-
| 2 -> Offline
105
-
| 3 -> Forward_online
106
-
| 4 -> Forward_offline
107
-
| n -> Unknown_delivery_mode n)
108
-
(function
109
-
| Timely_online -> 0
110
-
| Complete_online -> 1
111
-
| Offline -> 2
112
-
| Forward_online -> 3
113
-
| Forward_offline -> 4
114
-
| Unknown_delivery_mode n -> n)
115
-
int
116
-
117
-
let diagnostics_grammar =
118
-
map
119
-
(function 100 -> Duplicate_invoke_id | n -> Other n)
120
-
(function Duplicate_invoke_id -> 100 | Other n -> n)
121
-
int
122
-
123
-
let frame_quality_grammar =
124
-
map
125
-
(function
126
-
| 0 -> Good
127
-
| 1 -> Erred
128
-
| 2 -> Undetermined
129
-
| n -> Unknown_frame_quality n)
130
-
(function
131
-
| Good -> 0
132
-
| Erred -> 1
133
-
| Undetermined -> 2
134
-
| Unknown_frame_quality n -> n)
135
-
int
136
-
137
-
let requested_frame_quality_grammar =
138
-
map
139
-
(function
140
-
| 0 -> Good_only
141
-
| 1 -> Erred_only
142
-
| 2 -> All_frames
143
-
| n -> Unknown_requested_frame_quality n)
144
-
(function
145
-
| Good_only -> 0
146
-
| Erred_only -> 1
147
-
| All_frames -> 2
148
-
| Unknown_requested_frame_quality n -> n)
149
-
int
150
-
151
-
(* {1 Encoding/Decoding} *)
152
-
153
-
let codec_of grammar =
154
-
let encode v =
155
-
let s = Asn.encode (Asn.codec Asn.ber grammar) v in
156
-
Bytes.of_string s
157
-
in
158
-
let decode buf =
159
-
match Asn.decode (Asn.codec Asn.ber grammar) (Bytes.to_string buf) with
160
-
| Ok (v, _) -> Ok v
161
-
| Error _ -> Error `Decode_error
162
-
in
163
-
(encode, decode)
164
-
165
-
let encode_credentials, decode_credentials = codec_of credentials_grammar
166
-
let encode_time, decode_time = codec_of time_grammar
167
-
168
-
let encode_conditional_time, decode_conditional_time =
169
-
codec_of conditional_time_grammar
170
-
171
-
(* {1 Pretty-printers} *)
172
-
173
-
let pp_time ppf = function
174
-
| Ccsds s -> Fmt.pf ppf "CDS(%d bytes)" (String.length s)
175
-
| Ccsds_pico s -> Fmt.pf ppf "CDS-pico(%d bytes)" (String.length s)
176
-
177
-
let pp_credentials ppf = function
178
-
| Unused -> Fmt.pf ppf "unused"
179
-
| Used s -> Fmt.pf ppf "ISP1(%d bytes)" (String.length s)
180
-
181
-
let pp_delivery_mode ppf = function
182
-
| Timely_online -> Fmt.string ppf "timely-online"
183
-
| Complete_online -> Fmt.string ppf "complete-online"
184
-
| Offline -> Fmt.string ppf "offline"
185
-
| Forward_online -> Fmt.string ppf "forward-online"
186
-
| Forward_offline -> Fmt.string ppf "forward-offline"
187
-
| Unknown_delivery_mode n -> Fmt.pf ppf "unknown(%d)" n
188
-
189
-
let pp_frame_quality ppf = function
190
-
| Good -> Fmt.string ppf "good"
191
-
| Erred -> Fmt.string ppf "erred"
192
-
| Undetermined -> Fmt.string ppf "undetermined"
193
-
| Unknown_frame_quality n -> Fmt.pf ppf "unknown(%d)" n
194
-
195
-
let pp_requested_frame_quality ppf = function
196
-
| Good_only -> Fmt.string ppf "good-only"
197
-
| Erred_only -> Fmt.string ppf "erred-only"
198
-
| All_frames -> Fmt.string ppf "all-frames"
199
-
| Unknown_requested_frame_quality n -> Fmt.pf ppf "unknown(%d)" n
200
-
201
-
let pp_service_instance_id ppf si =
202
-
Fmt.pf ppf "%s.%s.%s.%d" si.spacecraft_id si.facility_id si.service_type
203
-
si.instance_number
-102
lib/sle/common.mli
-102
lib/sle/common.mli
···
1
-
(** Common SLE ASN.1 types (CCSDS 913.1-B-2).
2
-
3
-
Pure module - no I/O effects. Defines shared types used across all SLE
4
-
services: credentials, time formats, diagnostics, and delivery modes. *)
5
-
6
-
(** {1 Numeric Types} *)
7
-
8
-
type invoke_id = int
9
-
type int_pos_long = int
10
-
type int_unsigned_long = int
11
-
type int_pos_short = int
12
-
type int_unsigned_short = int
13
-
14
-
(** {1 Time Formats} *)
15
-
16
-
(** CCSDS time formats. *)
17
-
type time =
18
-
| Ccsds of string (** 8-byte CDS: days + ms + us *)
19
-
| Ccsds_pico of string (** 10-byte CDS: days + ms + ps *)
20
-
21
-
type conditional_time = time option
22
-
23
-
(** {1 Credentials} *)
24
-
25
-
(** Authentication credentials - either unused or ISP1. *)
26
-
type credentials =
27
-
| Unused
28
-
| Used of string (** 8-256 bytes, structure per ISP1 *)
29
-
30
-
(** {1 Delivery Mode} *)
31
-
32
-
type delivery_mode =
33
-
| Timely_online
34
-
| Complete_online
35
-
| Offline
36
-
| Forward_online
37
-
| Forward_offline
38
-
| Unknown_delivery_mode of int (** Unknown value from untrusted PDU *)
39
-
40
-
(** {1 Diagnostics} *)
41
-
42
-
type diagnostics = Duplicate_invoke_id | Other of int
43
-
44
-
(** {1 Duration} *)
45
-
46
-
type duration = int
47
-
(** Duration in microseconds. *)
48
-
49
-
(** {1 Frame Quality} *)
50
-
51
-
type frame_quality =
52
-
| Good
53
-
| Erred
54
-
| Undetermined
55
-
| Unknown_frame_quality of int (** Unknown value from untrusted PDU *)
56
-
57
-
type requested_frame_quality =
58
-
| Good_only
59
-
| Erred_only
60
-
| All_frames
61
-
| Unknown_requested_frame_quality of int
62
-
(** Unknown value from untrusted PDU *)
63
-
64
-
(** {1 Service Instance ID} *)
65
-
66
-
type service_instance_id = {
67
-
spacecraft_id : string;
68
-
facility_id : string;
69
-
service_type : string;
70
-
instance_number : int;
71
-
}
72
-
(** Service instance identifier per CCSDS 913.1-B-2. *)
73
-
74
-
(** {1 ASN.1 Grammars} *)
75
-
76
-
val time_grammar : time Asn.S.t
77
-
val conditional_time_grammar : conditional_time Asn.S.t
78
-
val credentials_grammar : credentials Asn.S.t
79
-
val delivery_mode_grammar : delivery_mode Asn.S.t
80
-
val diagnostics_grammar : diagnostics Asn.S.t
81
-
val frame_quality_grammar : frame_quality Asn.S.t
82
-
val requested_frame_quality_grammar : requested_frame_quality Asn.S.t
83
-
84
-
(** {1 Encoding/Decoding} *)
85
-
86
-
val encode_credentials : credentials -> bytes
87
-
val decode_credentials : bytes -> (credentials, [> `Decode_error ]) result
88
-
val encode_time : time -> bytes
89
-
val decode_time : bytes -> (time, [> `Decode_error ]) result
90
-
val encode_conditional_time : conditional_time -> bytes
91
-
92
-
val decode_conditional_time :
93
-
bytes -> (conditional_time, [> `Decode_error ]) result
94
-
95
-
(** {1 Pretty-printers} *)
96
-
97
-
val pp_time : time Fmt.t
98
-
val pp_credentials : credentials Fmt.t
99
-
val pp_delivery_mode : delivery_mode Fmt.t
100
-
val pp_frame_quality : frame_quality Fmt.t
101
-
val pp_requested_frame_quality : requested_frame_quality Fmt.t
102
-
val pp_service_instance_id : service_instance_id Fmt.t
-4
lib/sle/dune
-4
lib/sle/dune
-945
lib/sle/fcltu.ml
-945
lib/sle/fcltu.ml
···
1
-
(** FCLTU - Forward CLTU Service (CCSDS 912.1-B-4).
2
-
3
-
Pure module - no I/O effects. Implements the Forward CLTU service state
4
-
machine and PDU encoding/decoding.
5
-
6
-
FCLTU provides CLTU (Command Link Transfer Unit) delivery from user to
7
-
ground station for uplink to spacecraft.
8
-
9
-
Service lifecycle:
10
-
{v
11
-
[Ready] --start--> [Active] --stop--> [Ready]
12
-
13
-
In Active state:
14
-
- User sends CLTU-TRANSFER-DATA invocations
15
-
- Provider sends ASYNC-NOTIFY on radiation status
16
-
- User can request GET-PARAMETER, SCHEDULE-STATUS-REPORT, THROW-EVENT
17
-
v} *)
18
-
19
-
open Asn.S
20
-
21
-
(* {1 Types} *)
22
-
23
-
type production_status =
24
-
| Operational
25
-
| Configured
26
-
| Interrupted
27
-
| Halted
28
-
| Unknown_production_status of int
29
-
30
-
type uplink_status =
31
-
| Uplink_status_not_available
32
-
| No_rf_available
33
-
| No_bit_lock
34
-
| Nominal
35
-
| Unknown_uplink_status of int
36
-
37
-
type cltu_status =
38
-
| Radiated
39
-
| Expired
40
-
| Interrupted_cltu
41
-
| Production_started
42
-
| Production_not_started
43
-
| Unknown_cltu_status of int
44
-
45
-
type notification_type =
46
-
| Cltu_radiated
47
-
| Sldu_expired
48
-
| Production_interrupted
49
-
| Production_halted
50
-
| Production_operational
51
-
| Buffer_empty
52
-
| Action_list_completed
53
-
| Action_list_not_completed
54
-
| Event_condition_ev_false
55
-
| Unknown_notification of int
56
-
57
-
(* {1 Service Operations} *)
58
-
59
-
type start_invocation = {
60
-
invoker_credentials : Common.credentials;
61
-
invoke_id : int;
62
-
first_cltu_id : int64 option;
63
-
}
64
-
65
-
type start_result = Positive | Negative of start_diagnostic
66
-
67
-
and start_diagnostic =
68
-
| Unable_to_comply
69
-
| Out_of_service
70
-
| Unable_to_process
71
-
| Production_time_expired
72
-
| Duplicate_invoke_id
73
-
| Unknown_start_diagnostic of int
74
-
75
-
type start_return = {
76
-
performer_credentials : Common.credentials;
77
-
invoke_id : int;
78
-
start_radiation_time : Common.time option;
79
-
stop_radiation_time : Common.time option;
80
-
result : start_result;
81
-
}
82
-
83
-
type stop_invocation = {
84
-
invoker_credentials : Common.credentials;
85
-
invoke_id : int;
86
-
}
87
-
88
-
type stop_result = Stop_positive | Stop_negative of stop_diagnostic
89
-
90
-
and stop_diagnostic =
91
-
| Duplicate_invoke_id_stop
92
-
| Unknown_stop_diagnostic of int
93
-
94
-
type stop_return = {
95
-
performer_credentials : Common.credentials;
96
-
invoke_id : int;
97
-
result : stop_result;
98
-
}
99
-
100
-
(* {1 CLTU Transfer} *)
101
-
102
-
type transfer_data_invocation = {
103
-
invoker_credentials : Common.credentials;
104
-
invoke_id : int;
105
-
cltu_id : int64;
106
-
earliest_radiation_time : Common.conditional_time;
107
-
latest_radiation_time : Common.conditional_time;
108
-
delay_time : int;
109
-
radiation_notification : bool;
110
-
data : bytes;
111
-
}
112
-
113
-
type transfer_data_result =
114
-
| Td_positive
115
-
| Td_negative of transfer_data_diagnostic
116
-
117
-
and transfer_data_diagnostic =
118
-
| Unable_to_process_td
119
-
| Unable_to_store
120
-
| Out_of_sequence
121
-
| Inconsistent_time_range
122
-
| Invalid_time
123
-
| Late_sldu
124
-
| Invalid_delay_time
125
-
| Cltu_error
126
-
| Unknown_td_diagnostic of int
127
-
128
-
type transfer_data_return = {
129
-
performer_credentials : Common.credentials;
130
-
invoke_id : int;
131
-
cltu_id : int64;
132
-
buffer_available : int64;
133
-
result : transfer_data_result;
134
-
}
135
-
136
-
(* {1 Async Notify} *)
137
-
138
-
type async_notify_invocation = {
139
-
invoker_credentials : Common.credentials;
140
-
notification : notification_type;
141
-
cltu_last_processed : int64 option;
142
-
cltu_last_ok : int64 option;
143
-
production_status : production_status;
144
-
uplink_status : uplink_status;
145
-
}
146
-
147
-
(* {1 Throw Event} *)
148
-
149
-
type throw_event_invocation = {
150
-
invoker_credentials : Common.credentials;
151
-
invoke_id : int;
152
-
event_id : int;
153
-
event_qualifier : bytes;
154
-
}
155
-
156
-
type throw_event_result = Te_positive | Te_negative of throw_event_diagnostic
157
-
158
-
and throw_event_diagnostic =
159
-
| Operation_not_supported
160
-
| Event_invocation_error
161
-
| Unknown_te_diagnostic of int
162
-
163
-
type throw_event_return = {
164
-
performer_credentials : Common.credentials;
165
-
invoke_id : int;
166
-
event_id : int;
167
-
result : throw_event_result;
168
-
}
169
-
170
-
(* {1 GET-PARAMETER Operation} *)
171
-
172
-
type parameter_name =
173
-
| Acquisition_sequence_length
174
-
| Bit_lock_required
175
-
| Clcw_global_vcid
176
-
| Clcw_physical_channel
177
-
| Delivery_mode
178
-
| Expected_cltu_id
179
-
| Expected_event_invocation_id
180
-
| Maximum_cltu_length
181
-
| Minimum_delay_time
182
-
| Minimum_reporting_cycle
183
-
| Modulation_frequency
184
-
| Modulation_index
185
-
| Notification_mode
186
-
| Plop_in_effect
187
-
| Reporting_cycle
188
-
| Return_timeout_period
189
-
| Rf_available_required
190
-
| Subcarrier_to_bit_rate_ratio
191
-
| Unknown_parameter of int
192
-
193
-
type plop1 = Plop1_idle | Plop1_sequence | Unknown_plop1 of int
194
-
type plop2 = Plop2_idle | Plop2_sequence | Unknown_plop2 of int
195
-
type plop_in_effect = Plop1 of plop1 | Plop2 of plop2
196
-
197
-
type parameter_value =
198
-
| Pv_acquisition_sequence_length of int
199
-
| Pv_bit_lock_required of bool
200
-
| Pv_clcw_global_vcid of (int * int) option
201
-
| Pv_clcw_physical_channel of string option
202
-
| Pv_delivery_mode of Common.delivery_mode
203
-
| Pv_expected_cltu_id of int64
204
-
| Pv_expected_event_invocation_id of int
205
-
| Pv_maximum_cltu_length of int
206
-
| Pv_minimum_delay_time of int
207
-
| Pv_minimum_reporting_cycle of int option
208
-
| Pv_modulation_frequency of int
209
-
| Pv_modulation_index of int
210
-
| Pv_notification_mode of bool
211
-
| Pv_plop_in_effect of plop_in_effect
212
-
| Pv_reporting_cycle of int option
213
-
| Pv_return_timeout_period of int
214
-
| Pv_rf_available_required of bool
215
-
| Pv_subcarrier_to_bit_rate_ratio of int
216
-
217
-
type get_parameter_diagnostic =
218
-
| Unknown_parameter_diagnostic
219
-
| Gp_duplicate_invoke_id
220
-
| Gp_operation_not_supported
221
-
| Gp_unknown_diagnostic of int
222
-
223
-
type get_parameter_invocation = {
224
-
gp_invoker_credentials : Common.credentials;
225
-
gp_invoke_id : int;
226
-
gp_parameter_name : parameter_name;
227
-
}
228
-
229
-
type get_parameter_return = {
230
-
gp_performer_credentials : Common.credentials;
231
-
gp_invoke_id : int;
232
-
gp_result : (parameter_value, get_parameter_diagnostic) result;
233
-
}
234
-
235
-
(* {1 SCHEDULE-STATUS-REPORT Operation} *)
236
-
237
-
type status_report = {
238
-
sr_cltu_last_processed : int64 option;
239
-
sr_cltu_last_ok : int64 option;
240
-
sr_production_status : production_status;
241
-
sr_uplink_status : uplink_status;
242
-
sr_num_cltus_received : int64;
243
-
sr_num_cltus_processed : int64;
244
-
sr_num_cltus_radiated : int64;
245
-
sr_buffer_available : int64;
246
-
}
247
-
248
-
type schedule_status_report_diagnostic =
249
-
| Invalid_reporting_cycle
250
-
| Ssr_duplicate_invoke_id
251
-
| Already_stopped
252
-
| Ssr_unknown_diagnostic of int
253
-
254
-
type schedule_status_report_invocation = {
255
-
ssr_invoker_credentials : Common.credentials;
256
-
ssr_invoke_id : int;
257
-
ssr_reporting_cycle : int option;
258
-
}
259
-
260
-
type schedule_status_report_return = {
261
-
ssr_performer_credentials : Common.credentials;
262
-
ssr_invoke_id : int;
263
-
ssr_result : (unit, schedule_status_report_diagnostic) result;
264
-
}
265
-
266
-
(* {1 Service State Machine} *)
267
-
268
-
type state = Ready | Active | Stopping
269
-
270
-
type output =
271
-
| Send of bytes
272
-
| Cltu_accepted of int64 * int64
273
-
| Cltu_rejected of int64 * transfer_data_diagnostic
274
-
| Notification of async_notify_invocation
275
-
| Started
276
-
| Start_failed of start_diagnostic
277
-
| Stopped
278
-
| Parameter_value of get_parameter_return
279
-
| Status_report_scheduled
280
-
| Status_report_stopped
281
-
| Status_report_failed of schedule_status_report_diagnostic
282
-
| Status_report of status_report
283
-
| Event_completed of int
284
-
| Event_failed of int * throw_event_diagnostic
285
-
286
-
type input =
287
-
| Initiate_start of start_invocation
288
-
| Start_response of start_return
289
-
| Initiate_stop of stop_invocation
290
-
| Stop_response of stop_return
291
-
| Transfer_cltu of transfer_data_invocation
292
-
| Transfer_cltu_response of transfer_data_return
293
-
| Async_notify_received of async_notify_invocation
294
-
| Initiate_throw_event of throw_event_invocation
295
-
| Throw_event_response of throw_event_return
296
-
| Initiate_get_parameter of get_parameter_invocation
297
-
| Get_parameter_response of get_parameter_return
298
-
| Initiate_schedule_status_report of schedule_status_report_invocation
299
-
| Schedule_status_report_response of schedule_status_report_return
300
-
| Status_report_received of status_report
301
-
302
-
type error =
303
-
| Invalid_state of { current : state; operation : string }
304
-
| Decode_error of string
305
-
306
-
(* {1 ASN.1 Grammars} *)
307
-
308
-
let production_status_grammar =
309
-
map
310
-
(function
311
-
| 0 -> Operational
312
-
| 1 -> Configured
313
-
| 2 -> Interrupted
314
-
| 3 -> Halted
315
-
| n -> Unknown_production_status n)
316
-
(function
317
-
| Operational -> 0
318
-
| Configured -> 1
319
-
| Interrupted -> 2
320
-
| Halted -> 3
321
-
| Unknown_production_status n -> n)
322
-
int
323
-
324
-
let uplink_status_grammar =
325
-
map
326
-
(function
327
-
| 0 -> Uplink_status_not_available
328
-
| 1 -> No_rf_available
329
-
| 2 -> No_bit_lock
330
-
| 3 -> Nominal
331
-
| n -> Unknown_uplink_status n)
332
-
(function
333
-
| Uplink_status_not_available -> 0
334
-
| No_rf_available -> 1
335
-
| No_bit_lock -> 2
336
-
| Nominal -> 3
337
-
| Unknown_uplink_status n -> n)
338
-
int
339
-
340
-
let notification_type_grammar =
341
-
map
342
-
(function
343
-
| 0 -> Cltu_radiated
344
-
| 1 -> Sldu_expired
345
-
| 2 -> Production_interrupted
346
-
| 3 -> Production_halted
347
-
| 4 -> Production_operational
348
-
| 5 -> Buffer_empty
349
-
| 6 -> Action_list_completed
350
-
| 7 -> Action_list_not_completed
351
-
| 8 -> Event_condition_ev_false
352
-
| n -> Unknown_notification n)
353
-
(function
354
-
| Cltu_radiated -> 0
355
-
| Sldu_expired -> 1
356
-
| Production_interrupted -> 2
357
-
| Production_halted -> 3
358
-
| Production_operational -> 4
359
-
| Buffer_empty -> 5
360
-
| Action_list_completed -> 6
361
-
| Action_list_not_completed -> 7
362
-
| Event_condition_ev_false -> 8
363
-
| Unknown_notification n -> n)
364
-
int
365
-
366
-
let start_diagnostic_grammar =
367
-
map
368
-
(function
369
-
| 0 -> Unable_to_comply
370
-
| 1 -> Out_of_service
371
-
| 2 -> Unable_to_process
372
-
| 3 -> Production_time_expired
373
-
| 100 -> Duplicate_invoke_id
374
-
| n -> Unknown_start_diagnostic n)
375
-
(function
376
-
| Unable_to_comply -> 0
377
-
| Out_of_service -> 1
378
-
| Unable_to_process -> 2
379
-
| Production_time_expired -> 3
380
-
| Duplicate_invoke_id -> 100
381
-
| Unknown_start_diagnostic n -> n)
382
-
int
383
-
384
-
let start_result_grammar =
385
-
map
386
-
(function `C1 () -> Positive | `C2 d -> Negative d)
387
-
(function Positive -> `C1 () | Negative d -> `C2 d)
388
-
(choice2 (implicit 0 null) (implicit 1 start_diagnostic_grammar))
389
-
390
-
let start_invocation_grammar =
391
-
sequence3
392
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
393
-
(required ~label:"invokeId" int)
394
-
(optional ~label:"firstCltuIdentification" int)
395
-
396
-
let start_return_grammar =
397
-
sequence3
398
-
(required ~label:"performerCredentials" Common.credentials_grammar)
399
-
(required ~label:"invokeId" int)
400
-
(required ~label:"result" start_result_grammar)
401
-
402
-
let stop_invocation_grammar =
403
-
sequence2
404
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
405
-
(required ~label:"invokeId" int)
406
-
407
-
let stop_diagnostic_grammar =
408
-
map
409
-
(function
410
-
| 100 -> Duplicate_invoke_id_stop | n -> Unknown_stop_diagnostic n)
411
-
(function
412
-
| Duplicate_invoke_id_stop -> 100 | Unknown_stop_diagnostic n -> n)
413
-
int
414
-
415
-
let stop_result_grammar =
416
-
map
417
-
(function `C1 () -> Stop_positive | `C2 d -> Stop_negative d)
418
-
(function Stop_positive -> `C1 () | Stop_negative d -> `C2 d)
419
-
(choice2 (implicit 0 null) (implicit 1 stop_diagnostic_grammar))
420
-
421
-
let stop_return_grammar =
422
-
sequence3
423
-
(required ~label:"performerCredentials" Common.credentials_grammar)
424
-
(required ~label:"invokeId" int)
425
-
(required ~label:"result" stop_result_grammar)
426
-
427
-
let transfer_data_diagnostic_grammar =
428
-
map
429
-
(function
430
-
| 0 -> Unable_to_process_td
431
-
| 1 -> Unable_to_store
432
-
| 2 -> Out_of_sequence
433
-
| 3 -> Inconsistent_time_range
434
-
| 4 -> Invalid_time
435
-
| 5 -> Late_sldu
436
-
| 6 -> Invalid_delay_time
437
-
| 7 -> Cltu_error
438
-
| n -> Unknown_td_diagnostic n)
439
-
(function
440
-
| Unable_to_process_td -> 0
441
-
| Unable_to_store -> 1
442
-
| Out_of_sequence -> 2
443
-
| Inconsistent_time_range -> 3
444
-
| Invalid_time -> 4
445
-
| Late_sldu -> 5
446
-
| Invalid_delay_time -> 6
447
-
| Cltu_error -> 7
448
-
| Unknown_td_diagnostic n -> n)
449
-
int
450
-
451
-
let _transfer_data_result_grammar =
452
-
map
453
-
(function `C1 () -> Td_positive | `C2 d -> Td_negative d)
454
-
(function Td_positive -> `C1 () | Td_negative d -> `C2 d)
455
-
(choice2 (implicit 0 null) (implicit 1 transfer_data_diagnostic_grammar))
456
-
457
-
let transfer_data_invocation_grammar =
458
-
sequence4
459
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
460
-
(required ~label:"invokeId" int)
461
-
(required ~label:"cltuIdentification" int)
462
-
(required ~label:"cltuData" octet_string)
463
-
464
-
let transfer_data_return_grammar =
465
-
sequence4
466
-
(required ~label:"performerCredentials" Common.credentials_grammar)
467
-
(required ~label:"invokeId" int)
468
-
(required ~label:"cltuIdentification" int)
469
-
(required ~label:"cltuBufferAvailable" int)
470
-
471
-
let async_notify_grammar =
472
-
sequence3
473
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
474
-
(required ~label:"cltuNotification" notification_type_grammar)
475
-
(required ~label:"productionStatus" production_status_grammar)
476
-
477
-
let throw_event_diagnostic_grammar =
478
-
map
479
-
(function
480
-
| 0 -> Operation_not_supported
481
-
| 1 -> Event_invocation_error
482
-
| n -> Unknown_te_diagnostic n)
483
-
(function
484
-
| Operation_not_supported -> 0
485
-
| Event_invocation_error -> 1
486
-
| Unknown_te_diagnostic n -> n)
487
-
int
488
-
489
-
let throw_event_result_grammar =
490
-
map
491
-
(function `C1 () -> Te_positive | `C2 d -> Te_negative d)
492
-
(function Te_positive -> `C1 () | Te_negative d -> `C2 d)
493
-
(choice2 (implicit 0 null) (implicit 1 throw_event_diagnostic_grammar))
494
-
495
-
let throw_event_invocation_grammar =
496
-
sequence4
497
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
498
-
(required ~label:"invokeId" int)
499
-
(required ~label:"eventIdentifier" int)
500
-
(required ~label:"eventQualifier" octet_string)
501
-
502
-
let throw_event_return_grammar =
503
-
sequence4
504
-
(required ~label:"performerCredentials" Common.credentials_grammar)
505
-
(required ~label:"invokeId" int)
506
-
(required ~label:"eventIdentifier" int)
507
-
(required ~label:"result" throw_event_result_grammar)
508
-
509
-
(* {2 GET-PARAMETER Grammars} *)
510
-
511
-
let parameter_name_grammar =
512
-
map
513
-
(function
514
-
| 201 -> Acquisition_sequence_length
515
-
| 301 -> Bit_lock_required
516
-
| 202 -> Clcw_global_vcid
517
-
| 203 -> Clcw_physical_channel
518
-
| 6 -> Delivery_mode
519
-
| 204 -> Expected_cltu_id
520
-
| 205 -> Expected_event_invocation_id
521
-
| 206 -> Maximum_cltu_length
522
-
| 207 -> Minimum_delay_time
523
-
| 303 -> Minimum_reporting_cycle
524
-
| 208 -> Modulation_frequency
525
-
| 209 -> Modulation_index
526
-
| 210 -> Notification_mode
527
-
| 211 -> Plop_in_effect
528
-
| 26 -> Reporting_cycle
529
-
| 29 -> Return_timeout_period
530
-
| 302 -> Rf_available_required
531
-
| 212 -> Subcarrier_to_bit_rate_ratio
532
-
| n -> Unknown_parameter n)
533
-
(function
534
-
| Acquisition_sequence_length -> 201
535
-
| Bit_lock_required -> 301
536
-
| Clcw_global_vcid -> 202
537
-
| Clcw_physical_channel -> 203
538
-
| Delivery_mode -> 6
539
-
| Expected_cltu_id -> 204
540
-
| Expected_event_invocation_id -> 205
541
-
| Maximum_cltu_length -> 206
542
-
| Minimum_delay_time -> 207
543
-
| Minimum_reporting_cycle -> 303
544
-
| Modulation_frequency -> 208
545
-
| Modulation_index -> 209
546
-
| Notification_mode -> 210
547
-
| Plop_in_effect -> 211
548
-
| Reporting_cycle -> 26
549
-
| Return_timeout_period -> 29
550
-
| Rf_available_required -> 302
551
-
| Subcarrier_to_bit_rate_ratio -> 212
552
-
| Unknown_parameter n -> n)
553
-
int
554
-
555
-
let get_parameter_invocation_grammar =
556
-
sequence3
557
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
558
-
(required ~label:"invokeId" int)
559
-
(required ~label:"fcltuParameter" parameter_name_grammar)
560
-
561
-
(* {2 SCHEDULE-STATUS-REPORT Grammars} *)
562
-
563
-
let schedule_status_report_diagnostic_grammar =
564
-
map
565
-
(function
566
-
| 0 -> Invalid_reporting_cycle
567
-
| 100 -> Ssr_duplicate_invoke_id
568
-
| 1 -> Already_stopped
569
-
| n -> Ssr_unknown_diagnostic n)
570
-
(function
571
-
| Invalid_reporting_cycle -> 0
572
-
| Ssr_duplicate_invoke_id -> 100
573
-
| Already_stopped -> 1
574
-
| Ssr_unknown_diagnostic n -> n)
575
-
int
576
-
577
-
let schedule_status_report_invocation_grammar =
578
-
sequence3
579
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
580
-
(required ~label:"invokeId" int)
581
-
(required ~label:"reportingCycle" (implicit 0 int))
582
-
583
-
let schedule_status_report_result_grammar =
584
-
map
585
-
(function `C1 () -> Ok () | `C2 d -> Error d)
586
-
(function Ok () -> `C1 () | Error d -> `C2 d)
587
-
(choice2 (implicit 0 null)
588
-
(implicit 1 schedule_status_report_diagnostic_grammar))
589
-
590
-
let schedule_status_report_return_grammar =
591
-
sequence3
592
-
(required ~label:"performerCredentials" Common.credentials_grammar)
593
-
(required ~label:"invokeId" int)
594
-
(required ~label:"result" schedule_status_report_result_grammar)
595
-
596
-
let status_report_grammar =
597
-
sequence4
598
-
(required ~label:"productionStatus" production_status_grammar)
599
-
(required ~label:"uplinkStatus" uplink_status_grammar)
600
-
(required ~label:"numCltusReceived" int)
601
-
(required ~label:"numCltusRadiated" int)
602
-
603
-
(* {1 Encoding} *)
604
-
605
-
let encode_start_invocation (inv : start_invocation) =
606
-
let codec = Asn.codec Asn.ber start_invocation_grammar in
607
-
let first_cltu = Option.map Int64.to_int inv.first_cltu_id in
608
-
let s =
609
-
Asn.encode codec (inv.invoker_credentials, inv.invoke_id, first_cltu)
610
-
in
611
-
Bytes.of_string s
612
-
613
-
let encode_stop_invocation (inv : stop_invocation) =
614
-
let codec = Asn.codec Asn.ber stop_invocation_grammar in
615
-
let s = Asn.encode codec (inv.invoker_credentials, inv.invoke_id) in
616
-
Bytes.of_string s
617
-
618
-
let encode_transfer_data_invocation (inv : transfer_data_invocation) =
619
-
let codec = Asn.codec Asn.ber transfer_data_invocation_grammar in
620
-
let s =
621
-
Asn.encode codec
622
-
( inv.invoker_credentials,
623
-
inv.invoke_id,
624
-
Int64.to_int inv.cltu_id,
625
-
Bytes.to_string inv.data )
626
-
in
627
-
Bytes.of_string s
628
-
629
-
let encode_throw_event_invocation (inv : throw_event_invocation) =
630
-
let codec = Asn.codec Asn.ber throw_event_invocation_grammar in
631
-
let s =
632
-
Asn.encode codec
633
-
( inv.invoker_credentials,
634
-
inv.invoke_id,
635
-
inv.event_id,
636
-
Bytes.to_string inv.event_qualifier )
637
-
in
638
-
Bytes.of_string s
639
-
640
-
let encode_get_parameter_invocation (inv : get_parameter_invocation) =
641
-
let codec = Asn.codec Asn.ber get_parameter_invocation_grammar in
642
-
let s =
643
-
Asn.encode codec
644
-
(inv.gp_invoker_credentials, inv.gp_invoke_id, inv.gp_parameter_name)
645
-
in
646
-
Bytes.of_string s
647
-
648
-
let encode_schedule_status_report_invocation
649
-
(inv : schedule_status_report_invocation) =
650
-
let codec = Asn.codec Asn.ber schedule_status_report_invocation_grammar in
651
-
let cycle = Option.value inv.ssr_reporting_cycle ~default:0 in
652
-
let s =
653
-
Asn.encode codec (inv.ssr_invoker_credentials, inv.ssr_invoke_id, cycle)
654
-
in
655
-
Bytes.of_string s
656
-
657
-
(* {1 Decoding} *)
658
-
659
-
let decode_start_return buf : (start_return, error) result =
660
-
let codec = Asn.codec Asn.ber start_return_grammar in
661
-
match Asn.decode codec (Bytes.to_string buf) with
662
-
| Ok ((cred, id, result), _) ->
663
-
Ok
664
-
{
665
-
performer_credentials = cred;
666
-
invoke_id = id;
667
-
start_radiation_time = None;
668
-
stop_radiation_time = None;
669
-
result;
670
-
}
671
-
| Error _ -> Error (Decode_error "start return")
672
-
673
-
let decode_stop_return buf : (stop_return, error) result =
674
-
let codec = Asn.codec Asn.ber stop_return_grammar in
675
-
match Asn.decode codec (Bytes.to_string buf) with
676
-
| Ok ((cred, id, result), _) ->
677
-
Ok { performer_credentials = cred; invoke_id = id; result }
678
-
| Error _ -> Error (Decode_error "stop return")
679
-
680
-
let decode_transfer_data_return buf : (transfer_data_return, error) result =
681
-
let codec = Asn.codec Asn.ber transfer_data_return_grammar in
682
-
match Asn.decode codec (Bytes.to_string buf) with
683
-
| Ok ((cred, id, cltu_id, buffer), _) ->
684
-
Ok
685
-
{
686
-
performer_credentials = cred;
687
-
invoke_id = id;
688
-
cltu_id = Int64.of_int cltu_id;
689
-
buffer_available = Int64.of_int buffer;
690
-
result = Td_positive;
691
-
}
692
-
| Error _ -> Error (Decode_error "transfer data return")
693
-
694
-
let decode_async_notify buf : (async_notify_invocation, error) result =
695
-
let codec = Asn.codec Asn.ber async_notify_grammar in
696
-
match Asn.decode codec (Bytes.to_string buf) with
697
-
| Ok ((cred, notif, prod), _) ->
698
-
Ok
699
-
{
700
-
invoker_credentials = cred;
701
-
notification = notif;
702
-
cltu_last_processed = None;
703
-
cltu_last_ok = None;
704
-
production_status = prod;
705
-
uplink_status = Uplink_status_not_available;
706
-
}
707
-
| Error _ -> Error (Decode_error "async notify")
708
-
709
-
let decode_throw_event_return buf : (throw_event_return, error) result =
710
-
let codec = Asn.codec Asn.ber throw_event_return_grammar in
711
-
match Asn.decode codec (Bytes.to_string buf) with
712
-
| Ok ((cred, id, event_id, result), _) ->
713
-
Ok { performer_credentials = cred; invoke_id = id; event_id; result }
714
-
| Error _ -> Error (Decode_error "throw event return")
715
-
716
-
let decode_get_parameter_return _buf : (get_parameter_return, error) result =
717
-
(* GET-PARAMETER return has complex structure - simplified for now *)
718
-
Error (Decode_error "get parameter return not implemented")
719
-
720
-
let decode_schedule_status_report_return buf :
721
-
(schedule_status_report_return, error) result =
722
-
let codec = Asn.codec Asn.ber schedule_status_report_return_grammar in
723
-
match Asn.decode codec (Bytes.to_string buf) with
724
-
| Ok ((cred, id, result), _) ->
725
-
Ok
726
-
{
727
-
ssr_performer_credentials = cred;
728
-
ssr_invoke_id = id;
729
-
ssr_result = result;
730
-
}
731
-
| Error _ -> Error (Decode_error "schedule status report return")
732
-
733
-
let decode_status_report buf : (status_report, error) result =
734
-
let codec = Asn.codec Asn.ber status_report_grammar in
735
-
match Asn.decode codec (Bytes.to_string buf) with
736
-
| Ok ((prod, uplink, received, radiated), _) ->
737
-
Ok
738
-
{
739
-
sr_cltu_last_processed = None;
740
-
sr_cltu_last_ok = None;
741
-
sr_production_status = prod;
742
-
sr_uplink_status = uplink;
743
-
sr_num_cltus_received = Int64.of_int received;
744
-
sr_num_cltus_processed = Int64.of_int received;
745
-
sr_num_cltus_radiated = Int64.of_int radiated;
746
-
sr_buffer_available = 0L;
747
-
}
748
-
| Error _ -> Error (Decode_error "status report")
749
-
750
-
(* {1 State Machine} *)
751
-
752
-
let initial = Ready
753
-
754
-
let step state input =
755
-
match (state, input) with
756
-
| Ready, Initiate_start inv ->
757
-
let pdu = encode_start_invocation inv in
758
-
Ok (Ready, [ Send pdu ])
759
-
| Ready, Start_response ret -> (
760
-
match ret.result with
761
-
| Positive -> Ok (Active, [ Started ])
762
-
| Negative diag -> Ok (Ready, [ Start_failed diag ]))
763
-
| Active, Transfer_cltu inv ->
764
-
let pdu = encode_transfer_data_invocation inv in
765
-
Ok (Active, [ Send pdu ])
766
-
| Active, Transfer_cltu_response ret -> (
767
-
match ret.result with
768
-
| Td_positive ->
769
-
Ok (Active, [ Cltu_accepted (ret.cltu_id, ret.buffer_available) ])
770
-
| Td_negative diag -> Ok (Active, [ Cltu_rejected (ret.cltu_id, diag) ]))
771
-
| Active, Async_notify_received notif -> Ok (Active, [ Notification notif ])
772
-
| Active, Initiate_throw_event inv ->
773
-
let pdu = encode_throw_event_invocation inv in
774
-
Ok (Active, [ Send pdu ])
775
-
| Active, Throw_event_response ret -> (
776
-
match ret.result with
777
-
| Te_positive -> Ok (Active, [ Event_completed ret.event_id ])
778
-
| Te_negative diag -> Ok (Active, [ Event_failed (ret.event_id, diag) ]))
779
-
| Active, Initiate_get_parameter inv ->
780
-
let pdu = encode_get_parameter_invocation inv in
781
-
Ok (Active, [ Send pdu ])
782
-
| Active, Get_parameter_response ret -> Ok (Active, [ Parameter_value ret ])
783
-
| Active, Initiate_schedule_status_report inv ->
784
-
let pdu = encode_schedule_status_report_invocation inv in
785
-
Ok (Active, [ Send pdu ])
786
-
| Active, Schedule_status_report_response ret -> (
787
-
match ret.ssr_result with
788
-
| Ok () ->
789
-
if ret.ssr_invoke_id = 0 then Ok (Active, [ Status_report_stopped ])
790
-
else Ok (Active, [ Status_report_scheduled ])
791
-
| Error diag -> Ok (Active, [ Status_report_failed diag ]))
792
-
| Active, Status_report_received report ->
793
-
Ok (Active, [ Status_report report ])
794
-
| Active, Initiate_stop inv ->
795
-
let pdu = encode_stop_invocation inv in
796
-
Ok (Stopping, [ Send pdu ])
797
-
| Stopping, Stop_response ret -> (
798
-
match ret.result with
799
-
| Stop_positive -> Ok (Ready, [ Stopped ])
800
-
| Stop_negative _ -> Ok (Ready, [ Stopped ]))
801
-
| _, _ ->
802
-
Error
803
-
(Invalid_state
804
-
{
805
-
current = state;
806
-
operation =
807
-
(match input with
808
-
| Initiate_start _ -> "start"
809
-
| Start_response _ -> "start_response"
810
-
| Initiate_stop _ -> "stop"
811
-
| Stop_response _ -> "stop_response"
812
-
| Transfer_cltu _ -> "transfer_cltu"
813
-
| Transfer_cltu_response _ -> "transfer_cltu_response"
814
-
| Async_notify_received _ -> "async_notify"
815
-
| Initiate_throw_event _ -> "throw_event"
816
-
| Throw_event_response _ -> "throw_event_response"
817
-
| Initiate_get_parameter _ -> "get_parameter"
818
-
| Get_parameter_response _ -> "get_parameter_response"
819
-
| Initiate_schedule_status_report _ -> "schedule_status_report"
820
-
| Schedule_status_report_response _ ->
821
-
"schedule_status_report_response"
822
-
| Status_report_received _ -> "status_report");
823
-
})
824
-
825
-
(* {1 Pretty-printers} *)
826
-
827
-
let pp_state ppf = function
828
-
| Ready -> Fmt.string ppf "Ready"
829
-
| Active -> Fmt.string ppf "Active"
830
-
| Stopping -> Fmt.string ppf "Stopping"
831
-
832
-
let pp_production_status ppf = function
833
-
| Operational -> Fmt.string ppf "operational"
834
-
| Configured -> Fmt.string ppf "configured"
835
-
| Interrupted -> Fmt.string ppf "interrupted"
836
-
| Halted -> Fmt.string ppf "halted"
837
-
| Unknown_production_status n -> Fmt.pf ppf "unknown(%d)" n
838
-
839
-
let pp_uplink_status ppf = function
840
-
| Uplink_status_not_available -> Fmt.string ppf "not-available"
841
-
| No_rf_available -> Fmt.string ppf "no-rf-available"
842
-
| No_bit_lock -> Fmt.string ppf "no-bit-lock"
843
-
| Nominal -> Fmt.string ppf "nominal"
844
-
| Unknown_uplink_status n -> Fmt.pf ppf "unknown(%d)" n
845
-
846
-
let pp_cltu_status ppf = function
847
-
| Radiated -> Fmt.string ppf "radiated"
848
-
| Expired -> Fmt.string ppf "expired"
849
-
| Interrupted_cltu -> Fmt.string ppf "interrupted"
850
-
| Production_started -> Fmt.string ppf "production-started"
851
-
| Production_not_started -> Fmt.string ppf "production-not-started"
852
-
| Unknown_cltu_status n -> Fmt.pf ppf "unknown(%d)" n
853
-
854
-
let pp_notification_type ppf = function
855
-
| Cltu_radiated -> Fmt.string ppf "cltu-radiated"
856
-
| Sldu_expired -> Fmt.string ppf "sldu-expired"
857
-
| Production_interrupted -> Fmt.string ppf "production-interrupted"
858
-
| Production_halted -> Fmt.string ppf "production-halted"
859
-
| Production_operational -> Fmt.string ppf "production-operational"
860
-
| Buffer_empty -> Fmt.string ppf "buffer-empty"
861
-
| Action_list_completed -> Fmt.string ppf "action-list-completed"
862
-
| Action_list_not_completed -> Fmt.string ppf "action-list-not-completed"
863
-
| Event_condition_ev_false -> Fmt.string ppf "event-condition-false"
864
-
| Unknown_notification n -> Fmt.pf ppf "unknown(%d)" n
865
-
866
-
let pp_start_diagnostic ppf = function
867
-
| Unable_to_comply -> Fmt.string ppf "unable-to-comply"
868
-
| Out_of_service -> Fmt.string ppf "out-of-service"
869
-
| Unable_to_process -> Fmt.string ppf "unable-to-process"
870
-
| Production_time_expired -> Fmt.string ppf "production-time-expired"
871
-
| Duplicate_invoke_id -> Fmt.string ppf "duplicate-invoke-id"
872
-
| Unknown_start_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
873
-
874
-
let pp_stop_diagnostic ppf = function
875
-
| Duplicate_invoke_id_stop -> Fmt.string ppf "duplicate-invoke-id"
876
-
| Unknown_stop_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
877
-
878
-
let pp_transfer_data_diagnostic ppf = function
879
-
| Unable_to_process_td -> Fmt.string ppf "unable-to-process"
880
-
| Unable_to_store -> Fmt.string ppf "unable-to-store"
881
-
| Out_of_sequence -> Fmt.string ppf "out-of-sequence"
882
-
| Inconsistent_time_range -> Fmt.string ppf "inconsistent-time-range"
883
-
| Invalid_time -> Fmt.string ppf "invalid-time"
884
-
| Late_sldu -> Fmt.string ppf "late-sldu"
885
-
| Invalid_delay_time -> Fmt.string ppf "invalid-delay-time"
886
-
| Cltu_error -> Fmt.string ppf "cltu-error"
887
-
| Unknown_td_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
888
-
889
-
let pp_throw_event_diagnostic ppf = function
890
-
| Operation_not_supported -> Fmt.string ppf "operation-not-supported"
891
-
| Event_invocation_error -> Fmt.string ppf "event-invocation-error"
892
-
| Unknown_te_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
893
-
894
-
let pp_parameter_name ppf = function
895
-
| Acquisition_sequence_length -> Fmt.string ppf "acquisition-sequence-length"
896
-
| Bit_lock_required -> Fmt.string ppf "bit-lock-required"
897
-
| Clcw_global_vcid -> Fmt.string ppf "clcw-global-vcid"
898
-
| Clcw_physical_channel -> Fmt.string ppf "clcw-physical-channel"
899
-
| Delivery_mode -> Fmt.string ppf "delivery-mode"
900
-
| Expected_cltu_id -> Fmt.string ppf "expected-cltu-id"
901
-
| Expected_event_invocation_id ->
902
-
Fmt.string ppf "expected-event-invocation-id"
903
-
| Maximum_cltu_length -> Fmt.string ppf "maximum-cltu-length"
904
-
| Minimum_delay_time -> Fmt.string ppf "minimum-delay-time"
905
-
| Minimum_reporting_cycle -> Fmt.string ppf "minimum-reporting-cycle"
906
-
| Modulation_frequency -> Fmt.string ppf "modulation-frequency"
907
-
| Modulation_index -> Fmt.string ppf "modulation-index"
908
-
| Notification_mode -> Fmt.string ppf "notification-mode"
909
-
| Plop_in_effect -> Fmt.string ppf "plop-in-effect"
910
-
| Reporting_cycle -> Fmt.string ppf "reporting-cycle"
911
-
| Return_timeout_period -> Fmt.string ppf "return-timeout-period"
912
-
| Rf_available_required -> Fmt.string ppf "rf-available-required"
913
-
| Subcarrier_to_bit_rate_ratio ->
914
-
Fmt.string ppf "subcarrier-to-bit-rate-ratio"
915
-
| Unknown_parameter n -> Fmt.pf ppf "unknown(%d)" n
916
-
917
-
let pp_get_parameter_diagnostic ppf = function
918
-
| Unknown_parameter_diagnostic -> Fmt.string ppf "unknown-parameter"
919
-
| Gp_duplicate_invoke_id -> Fmt.string ppf "duplicate-invoke-id"
920
-
| Gp_operation_not_supported -> Fmt.string ppf "operation-not-supported"
921
-
| Gp_unknown_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
922
-
923
-
let pp_schedule_status_report_diagnostic ppf = function
924
-
| Invalid_reporting_cycle -> Fmt.string ppf "invalid-reporting-cycle"
925
-
| Ssr_duplicate_invoke_id -> Fmt.string ppf "duplicate-invoke-id"
926
-
| Already_stopped -> Fmt.string ppf "already-stopped"
927
-
| Ssr_unknown_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
928
-
929
-
let pp_status_report ppf sr =
930
-
Fmt.pf ppf
931
-
"@[<v>Status Report:@,\
932
-
\ Production: %a@,\
933
-
\ Uplink: %a@,\
934
-
\ CLTUs received: %Ld@,\
935
-
\ CLTUs processed: %Ld@,\
936
-
\ CLTUs radiated: %Ld@,\
937
-
\ Buffer available: %Ld@]"
938
-
pp_production_status sr.sr_production_status pp_uplink_status
939
-
sr.sr_uplink_status sr.sr_num_cltus_received sr.sr_num_cltus_processed
940
-
sr.sr_num_cltus_radiated sr.sr_buffer_available
941
-
942
-
let pp_error ppf = function
943
-
| Invalid_state { current; operation } ->
944
-
Fmt.pf ppf "invalid state %a for operation %s" pp_state current operation
945
-
| Decode_error msg -> Fmt.pf ppf "decode error: %s" msg
-363
lib/sle/fcltu.mli
-363
lib/sle/fcltu.mli
···
1
-
(** FCLTU - Forward CLTU Service (CCSDS 912.1-B-4).
2
-
3
-
Pure module - no I/O effects. Implements the Forward CLTU service state
4
-
machine and PDU encoding/decoding.
5
-
6
-
FCLTU provides CLTU (Command Link Transfer Unit) delivery from user to
7
-
ground station for uplink to spacecraft.
8
-
9
-
Service lifecycle:
10
-
{v
11
-
[Ready] --start--> [Active] --stop--> [Ready]
12
-
13
-
In Active state:
14
-
- User sends CLTU-TRANSFER-DATA invocations
15
-
- Provider sends ASYNC-NOTIFY on radiation status
16
-
- User can request GET-PARAMETER, SCHEDULE-STATUS-REPORT, THROW-EVENT
17
-
v} *)
18
-
19
-
(** {1 Types} *)
20
-
21
-
type production_status =
22
-
| Operational
23
-
| Configured
24
-
| Interrupted
25
-
| Halted
26
-
| Unknown_production_status of int (** Unknown value from untrusted PDU *)
27
-
28
-
type uplink_status =
29
-
| Uplink_status_not_available
30
-
| No_rf_available
31
-
| No_bit_lock
32
-
| Nominal
33
-
| Unknown_uplink_status of int (** Unknown value from untrusted PDU *)
34
-
35
-
type cltu_status =
36
-
| Radiated
37
-
| Expired
38
-
| Interrupted_cltu
39
-
| Production_started
40
-
| Production_not_started
41
-
| Unknown_cltu_status of int (** Unknown value from untrusted PDU *)
42
-
43
-
type notification_type =
44
-
| Cltu_radiated
45
-
| Sldu_expired
46
-
| Production_interrupted
47
-
| Production_halted
48
-
| Production_operational
49
-
| Buffer_empty
50
-
| Action_list_completed
51
-
| Action_list_not_completed
52
-
| Event_condition_ev_false
53
-
| Unknown_notification of int (** Unknown value from untrusted PDU *)
54
-
55
-
(** {1 Service Operations} *)
56
-
57
-
type start_invocation = {
58
-
invoker_credentials : Common.credentials;
59
-
invoke_id : int;
60
-
first_cltu_id : int64 option; (** First expected CLTU ID *)
61
-
}
62
-
(** Start invocation - begin CLTU delivery session *)
63
-
64
-
type start_result = Positive | Negative of start_diagnostic
65
-
66
-
and start_diagnostic =
67
-
| Unable_to_comply
68
-
| Out_of_service
69
-
| Unable_to_process
70
-
| Production_time_expired
71
-
| Duplicate_invoke_id
72
-
| Unknown_start_diagnostic of int (** Unknown value from untrusted PDU *)
73
-
74
-
type start_return = {
75
-
performer_credentials : Common.credentials;
76
-
invoke_id : int;
77
-
start_radiation_time : Common.time option;
78
-
stop_radiation_time : Common.time option;
79
-
result : start_result;
80
-
}
81
-
82
-
type stop_invocation = {
83
-
invoker_credentials : Common.credentials;
84
-
invoke_id : int;
85
-
}
86
-
(** Stop invocation - end CLTU delivery session *)
87
-
88
-
type stop_result = Stop_positive | Stop_negative of stop_diagnostic
89
-
90
-
and stop_diagnostic =
91
-
| Duplicate_invoke_id_stop
92
-
| Unknown_stop_diagnostic of int (** Unknown value from untrusted PDU *)
93
-
94
-
type stop_return = {
95
-
performer_credentials : Common.credentials;
96
-
invoke_id : int;
97
-
result : stop_result;
98
-
}
99
-
100
-
(** {1 CLTU Transfer} *)
101
-
102
-
type transfer_data_invocation = {
103
-
invoker_credentials : Common.credentials;
104
-
invoke_id : int;
105
-
cltu_id : int64;
106
-
earliest_radiation_time : Common.conditional_time;
107
-
latest_radiation_time : Common.conditional_time;
108
-
delay_time : int; (** Microseconds between CLTUs *)
109
-
radiation_notification : bool;
110
-
data : bytes; (** CLTU to uplink *)
111
-
}
112
-
(** Transfer data - user sends CLTU to provider for uplink *)
113
-
114
-
type transfer_data_result =
115
-
| Td_positive
116
-
| Td_negative of transfer_data_diagnostic
117
-
118
-
and transfer_data_diagnostic =
119
-
| Unable_to_process_td
120
-
| Unable_to_store
121
-
| Out_of_sequence
122
-
| Inconsistent_time_range
123
-
| Invalid_time
124
-
| Late_sldu
125
-
| Invalid_delay_time
126
-
| Cltu_error
127
-
| Unknown_td_diagnostic of int (** Unknown value from untrusted PDU *)
128
-
129
-
type transfer_data_return = {
130
-
performer_credentials : Common.credentials;
131
-
invoke_id : int;
132
-
cltu_id : int64;
133
-
buffer_available : int64;
134
-
result : transfer_data_result;
135
-
}
136
-
137
-
(** {1 Async Notify} *)
138
-
139
-
type async_notify_invocation = {
140
-
invoker_credentials : Common.credentials;
141
-
notification : notification_type;
142
-
cltu_last_processed : int64 option;
143
-
cltu_last_ok : int64 option;
144
-
production_status : production_status;
145
-
uplink_status : uplink_status;
146
-
}
147
-
(** Async notify - provider notifies user of CLTU radiation status *)
148
-
149
-
(** {1 Throw Event} *)
150
-
151
-
type throw_event_invocation = {
152
-
invoker_credentials : Common.credentials;
153
-
invoke_id : int;
154
-
event_id : int;
155
-
event_qualifier : bytes;
156
-
}
157
-
(** Throw event - user triggers provider-side action *)
158
-
159
-
type throw_event_result = Te_positive | Te_negative of throw_event_diagnostic
160
-
161
-
and throw_event_diagnostic =
162
-
| Operation_not_supported
163
-
| Event_invocation_error
164
-
| Unknown_te_diagnostic of int (** Unknown value from untrusted PDU *)
165
-
166
-
type throw_event_return = {
167
-
performer_credentials : Common.credentials;
168
-
invoke_id : int;
169
-
event_id : int;
170
-
result : throw_event_result;
171
-
}
172
-
173
-
(** {1 GET-PARAMETER Operation} *)
174
-
175
-
type parameter_name =
176
-
| Acquisition_sequence_length
177
-
| Bit_lock_required
178
-
| Clcw_global_vcid
179
-
| Clcw_physical_channel
180
-
| Delivery_mode
181
-
| Expected_cltu_id
182
-
| Expected_event_invocation_id
183
-
| Maximum_cltu_length
184
-
| Minimum_delay_time
185
-
| Minimum_reporting_cycle
186
-
| Modulation_frequency
187
-
| Modulation_index
188
-
| Notification_mode
189
-
| Plop_in_effect
190
-
| Reporting_cycle
191
-
| Return_timeout_period
192
-
| Rf_available_required
193
-
| Subcarrier_to_bit_rate_ratio
194
-
| Unknown_parameter of int (** Unknown value from untrusted PDU *)
195
-
196
-
type plop1 = Plop1_idle | Plop1_sequence | Unknown_plop1 of int
197
-
type plop2 = Plop2_idle | Plop2_sequence | Unknown_plop2 of int
198
-
type plop_in_effect = Plop1 of plop1 | Plop2 of plop2
199
-
200
-
type parameter_value =
201
-
| Pv_acquisition_sequence_length of int
202
-
| Pv_bit_lock_required of bool
203
-
| Pv_clcw_global_vcid of (int * int) option (** (SCID, VCID) or None *)
204
-
| Pv_clcw_physical_channel of string option
205
-
| Pv_delivery_mode of Common.delivery_mode
206
-
| Pv_expected_cltu_id of int64
207
-
| Pv_expected_event_invocation_id of int
208
-
| Pv_maximum_cltu_length of int
209
-
| Pv_minimum_delay_time of int (** Microseconds *)
210
-
| Pv_minimum_reporting_cycle of int option
211
-
| Pv_modulation_frequency of int
212
-
| Pv_modulation_index of int
213
-
| Pv_notification_mode of bool (** true = deferred, false = immediate *)
214
-
| Pv_plop_in_effect of plop_in_effect
215
-
| Pv_reporting_cycle of int option (** None = off *)
216
-
| Pv_return_timeout_period of int
217
-
| Pv_rf_available_required of bool
218
-
| Pv_subcarrier_to_bit_rate_ratio of int
219
-
220
-
type get_parameter_diagnostic =
221
-
| Unknown_parameter_diagnostic
222
-
| Gp_duplicate_invoke_id
223
-
| Gp_operation_not_supported
224
-
| Gp_unknown_diagnostic of int (** Unknown value from untrusted PDU *)
225
-
226
-
type get_parameter_invocation = {
227
-
gp_invoker_credentials : Common.credentials;
228
-
gp_invoke_id : int;
229
-
gp_parameter_name : parameter_name;
230
-
}
231
-
232
-
type get_parameter_return = {
233
-
gp_performer_credentials : Common.credentials;
234
-
gp_invoke_id : int;
235
-
gp_result : (parameter_value, get_parameter_diagnostic) result;
236
-
}
237
-
238
-
(** {1 SCHEDULE-STATUS-REPORT Operation} *)
239
-
240
-
type status_report = {
241
-
sr_cltu_last_processed : int64 option;
242
-
sr_cltu_last_ok : int64 option;
243
-
sr_production_status : production_status;
244
-
sr_uplink_status : uplink_status;
245
-
sr_num_cltus_received : int64;
246
-
sr_num_cltus_processed : int64;
247
-
sr_num_cltus_radiated : int64;
248
-
sr_buffer_available : int64;
249
-
}
250
-
251
-
type schedule_status_report_diagnostic =
252
-
| Invalid_reporting_cycle
253
-
| Ssr_duplicate_invoke_id
254
-
| Already_stopped
255
-
| Ssr_unknown_diagnostic of int (** Unknown value from untrusted PDU *)
256
-
257
-
type schedule_status_report_invocation = {
258
-
ssr_invoker_credentials : Common.credentials;
259
-
ssr_invoke_id : int;
260
-
ssr_reporting_cycle : int option; (** None = stop reporting *)
261
-
}
262
-
263
-
type schedule_status_report_return = {
264
-
ssr_performer_credentials : Common.credentials;
265
-
ssr_invoke_id : int;
266
-
ssr_result : (unit, schedule_status_report_diagnostic) result;
267
-
}
268
-
269
-
(** {1 Service State Machine} *)
270
-
271
-
type state =
272
-
| Ready (** Bound, waiting for START *)
273
-
| Active (** Sending CLTUs *)
274
-
| Stopping (** STOP sent, waiting for return *)
275
-
276
-
type output =
277
-
| Send of bytes
278
-
| Cltu_accepted of int64 * int64 (** cltu_id, buffer_available *)
279
-
| Cltu_rejected of int64 * transfer_data_diagnostic
280
-
| Notification of async_notify_invocation
281
-
| Started
282
-
| Start_failed of start_diagnostic
283
-
| Stopped
284
-
| Parameter_value of get_parameter_return
285
-
| Status_report_scheduled
286
-
| Status_report_stopped
287
-
| Status_report_failed of schedule_status_report_diagnostic
288
-
| Status_report of status_report
289
-
| Event_completed of int
290
-
| Event_failed of int * throw_event_diagnostic
291
-
292
-
type input =
293
-
| Initiate_start of start_invocation
294
-
| Start_response of start_return
295
-
| Initiate_stop of stop_invocation
296
-
| Stop_response of stop_return
297
-
| Transfer_cltu of transfer_data_invocation
298
-
| Transfer_cltu_response of transfer_data_return
299
-
| Async_notify_received of async_notify_invocation
300
-
| Initiate_throw_event of throw_event_invocation
301
-
| Throw_event_response of throw_event_return
302
-
| Initiate_get_parameter of get_parameter_invocation
303
-
| Get_parameter_response of get_parameter_return
304
-
| Initiate_schedule_status_report of schedule_status_report_invocation
305
-
| Schedule_status_report_response of schedule_status_report_return
306
-
| Status_report_received of status_report
307
-
308
-
type error =
309
-
| Invalid_state of { current : state; operation : string }
310
-
| Decode_error of string
311
-
312
-
(** {1 State Machine Operations} *)
313
-
314
-
val initial : state
315
-
(** Initial state is [Ready]. *)
316
-
317
-
val step : state -> input -> (state * output list, error) result
318
-
(** [step state input] processes an input and returns new state with outputs. *)
319
-
320
-
(** {1 Encoding} *)
321
-
322
-
val encode_start_invocation : start_invocation -> bytes
323
-
val encode_stop_invocation : stop_invocation -> bytes
324
-
val encode_transfer_data_invocation : transfer_data_invocation -> bytes
325
-
val encode_throw_event_invocation : throw_event_invocation -> bytes
326
-
val encode_get_parameter_invocation : get_parameter_invocation -> bytes
327
-
328
-
val encode_schedule_status_report_invocation :
329
-
schedule_status_report_invocation -> bytes
330
-
331
-
(** {1 Decoding} *)
332
-
333
-
val decode_start_return : bytes -> (start_return, error) result
334
-
val decode_stop_return : bytes -> (stop_return, error) result
335
-
val decode_transfer_data_return : bytes -> (transfer_data_return, error) result
336
-
val decode_async_notify : bytes -> (async_notify_invocation, error) result
337
-
val decode_throw_event_return : bytes -> (throw_event_return, error) result
338
-
val decode_get_parameter_return : bytes -> (get_parameter_return, error) result
339
-
340
-
val decode_schedule_status_report_return :
341
-
bytes -> (schedule_status_report_return, error) result
342
-
343
-
val decode_status_report : bytes -> (status_report, error) result
344
-
345
-
(** {1 Pretty-printers} *)
346
-
347
-
val pp_state : state Fmt.t
348
-
val pp_production_status : production_status Fmt.t
349
-
val pp_uplink_status : uplink_status Fmt.t
350
-
val pp_cltu_status : cltu_status Fmt.t
351
-
val pp_notification_type : notification_type Fmt.t
352
-
val pp_start_diagnostic : start_diagnostic Fmt.t
353
-
val pp_stop_diagnostic : stop_diagnostic Fmt.t
354
-
val pp_transfer_data_diagnostic : transfer_data_diagnostic Fmt.t
355
-
val pp_throw_event_diagnostic : throw_event_diagnostic Fmt.t
356
-
val pp_parameter_name : parameter_name Fmt.t
357
-
val pp_get_parameter_diagnostic : get_parameter_diagnostic Fmt.t
358
-
359
-
val pp_schedule_status_report_diagnostic :
360
-
schedule_status_report_diagnostic Fmt.t
361
-
362
-
val pp_status_report : status_report Fmt.t
363
-
val pp_error : error Fmt.t
-143
lib/sle/isp1.ml
-143
lib/sle/isp1.ml
···
1
-
(** ISP1 Authentication (CCSDS 913.1-B-2 Annex B).
2
-
3
-
Pure module - no I/O effects. Implements credential generation and
4
-
verification for SLE authentication.
5
-
6
-
ISP1 Credential structure (DER encoded):
7
-
{v
8
-
ISP1Credentials ::= SEQUENCE {
9
-
time OCTET STRING (SIZE(8)), -- CDS time
10
-
randomNumber INTEGER (0..2147483647),
11
-
theProtected OCTET STRING (SIZE(20..32)) -- SHA-1 or SHA-256
12
-
}
13
-
v}
14
-
15
-
Hash input:
16
-
{v
17
-
HashInput ::= SEQUENCE {
18
-
time OCTET STRING (SIZE(8)),
19
-
randomNumber INTEGER (0..2147483647),
20
-
userName VisibleString,
21
-
passWord OCTET STRING
22
-
}
23
-
v} *)
24
-
25
-
open Asn.S
26
-
27
-
(* {1 Types} *)
28
-
29
-
type credentials = {
30
-
time : string; (** 8-byte CDS time *)
31
-
random : int; (** 0 to 2^31-1 *)
32
-
protected : string; (** 20 bytes (SHA-1) or 32 bytes (SHA-256) *)
33
-
}
34
-
35
-
type hash_algorithm = Sha1 (** SLE v1-3 *) | Sha256 (** SLE v4+ *)
36
-
37
-
type error =
38
-
| Invalid_time_length of int
39
-
| Invalid_protected_length of int
40
-
| Verification_failed
41
-
| Decode_error
42
-
43
-
(* {1 ASN.1 Grammar} *)
44
-
45
-
let credentials_grammar =
46
-
sequence3
47
-
(required ~label:"time" octet_string)
48
-
(required ~label:"randomNumber" int)
49
-
(required ~label:"theProtected" octet_string)
50
-
51
-
let hash_input_grammar =
52
-
sequence4
53
-
(required ~label:"time" octet_string)
54
-
(required ~label:"randomNumber" int)
55
-
(required ~label:"userName" visible_string)
56
-
(required ~label:"passWord" octet_string)
57
-
58
-
(* {1 Hashing} *)
59
-
60
-
let hash_sha1 data = Digestif.SHA1.(digest_string data |> to_raw_string)
61
-
let hash_sha256 data = Digestif.SHA256.(digest_string data |> to_raw_string)
62
-
63
-
let hash algo data =
64
-
match algo with Sha1 -> hash_sha1 data | Sha256 -> hash_sha256 data
65
-
66
-
(* {1 Credential Generation} *)
67
-
68
-
(** Encode hash input to DER string. *)
69
-
let encode_hash_input ~time ~random ~username ~password =
70
-
let codec = Asn.codec Asn.der hash_input_grammar in
71
-
Asn.encode codec (time, random, username, password)
72
-
73
-
(** Generate ISP1 credentials.
74
-
75
-
@param algo Hash algorithm (Sha1 for SLE v1-3, Sha256 for SLE v4+)
76
-
@param time 8-byte CDS time
77
-
@param random Random nonce (0 to 2^31-1)
78
-
@param username User identifier
79
-
@param password User password *)
80
-
let generate ~algo ~time ~random ~username ~password =
81
-
if String.length time <> 8 then
82
-
Error (Invalid_time_length (String.length time))
83
-
else
84
-
let hash_input = encode_hash_input ~time ~random ~username ~password in
85
-
let protected = hash algo hash_input in
86
-
Ok { time; random; protected }
87
-
88
-
(** Verify ISP1 credentials against expected username/password. *)
89
-
let verify ~algo ~username ~password cred =
90
-
if String.length cred.time <> 8 then
91
-
Error (Invalid_time_length (String.length cred.time))
92
-
else
93
-
let expected_len = match algo with Sha1 -> 20 | Sha256 -> 32 in
94
-
if String.length cred.protected <> expected_len then
95
-
Error (Invalid_protected_length (String.length cred.protected))
96
-
else
97
-
let hash_input =
98
-
encode_hash_input ~time:cred.time ~random:cred.random ~username
99
-
~password
100
-
in
101
-
let expected = hash algo hash_input in
102
-
if String.equal cred.protected expected then Ok ()
103
-
else Error Verification_failed
104
-
105
-
(* {1 Encoding/Decoding} *)
106
-
107
-
let encode cred =
108
-
let codec = Asn.codec Asn.der credentials_grammar in
109
-
let s = Asn.encode codec (cred.time, cred.random, cred.protected) in
110
-
Bytes.of_string s
111
-
112
-
let decode buf =
113
-
let codec = Asn.codec Asn.ber credentials_grammar in
114
-
match Asn.decode codec (Bytes.to_string buf) with
115
-
| Ok ((time, random, protected), _) -> Ok { time; random; protected }
116
-
| Error _ -> Error Decode_error
117
-
118
-
(** Wrap credentials for use in SLE PDUs (Common.credentials type). *)
119
-
let to_common_credentials cred =
120
-
let s =
121
-
Asn.encode
122
-
(Asn.codec Asn.der credentials_grammar)
123
-
(cred.time, cred.random, cred.protected)
124
-
in
125
-
Common.Used s
126
-
127
-
(* {1 Pretty-printers} *)
128
-
129
-
let pp_hash_algorithm ppf = function
130
-
| Sha1 -> Fmt.string ppf "SHA-1"
131
-
| Sha256 -> Fmt.string ppf "SHA-256"
132
-
133
-
let pp_credentials ppf cred =
134
-
Fmt.pf ppf "ISP1{time=%d bytes, random=%d, protected=%d bytes}"
135
-
(String.length cred.time) cred.random
136
-
(String.length cred.protected)
137
-
138
-
let pp_error ppf = function
139
-
| Invalid_time_length n -> Fmt.pf ppf "invalid time length: %d (expected 8)" n
140
-
| Invalid_protected_length n ->
141
-
Fmt.pf ppf "invalid protected length: %d (expected 20 or 32)" n
142
-
| Verification_failed -> Fmt.string ppf "credential verification failed"
143
-
| Decode_error -> Fmt.string ppf "credential decode error"
-82
lib/sle/isp1.mli
-82
lib/sle/isp1.mli
···
1
-
(** ISP1 Authentication (CCSDS 913.1-B-2 Annex B).
2
-
3
-
Pure module - no I/O effects. Implements credential generation and
4
-
verification for SLE authentication.
5
-
6
-
ISP1 Credential structure (DER encoded):
7
-
{v
8
-
ISP1Credentials ::= SEQUENCE {
9
-
time OCTET STRING (SIZE(8)), -- CDS time
10
-
randomNumber INTEGER (0..2147483647),
11
-
theProtected OCTET STRING (SIZE(20..32)) -- SHA-1 or SHA-256
12
-
}
13
-
v}
14
-
15
-
Hash input:
16
-
{v
17
-
HashInput ::= SEQUENCE {
18
-
time OCTET STRING (SIZE(8)),
19
-
randomNumber INTEGER (0..2147483647),
20
-
userName VisibleString,
21
-
passWord OCTET STRING
22
-
}
23
-
v} *)
24
-
25
-
(** {1 Types} *)
26
-
27
-
type credentials = {
28
-
time : string; (** 8-byte CDS time *)
29
-
random : int; (** 0 to 2^31-1 *)
30
-
protected : string; (** 20 bytes (SHA-1) or 32 bytes (SHA-256) *)
31
-
}
32
-
33
-
type hash_algorithm = Sha1 (** SLE v1-3 *) | Sha256 (** SLE v4+ *)
34
-
35
-
type error =
36
-
| Invalid_time_length of int
37
-
| Invalid_protected_length of int
38
-
| Verification_failed
39
-
| Decode_error
40
-
41
-
(** {1 Credential Generation} *)
42
-
43
-
val generate :
44
-
algo:hash_algorithm ->
45
-
time:string ->
46
-
random:int ->
47
-
username:string ->
48
-
password:string ->
49
-
(credentials, error) result
50
-
(** [generate ~algo ~time ~random ~username ~password] generates ISP1
51
-
credentials.
52
-
53
-
@param algo Hash algorithm (Sha1 for SLE v1-3, Sha256 for SLE v4+)
54
-
@param time 8-byte CDS time
55
-
@param random Random nonce (0 to 2^31-1)
56
-
@param username User identifier
57
-
@param password User password *)
58
-
59
-
val verify :
60
-
algo:hash_algorithm ->
61
-
username:string ->
62
-
password:string ->
63
-
credentials ->
64
-
(unit, error) result
65
-
(** [verify ~algo ~username ~password cred] verifies ISP1 credentials. *)
66
-
67
-
(** {1 Encoding/Decoding} *)
68
-
69
-
val encode : credentials -> bytes
70
-
(** [encode cred] DER-encodes credentials for transmission. *)
71
-
72
-
val decode : bytes -> (credentials, error) result
73
-
(** [decode buf] decodes BER-encoded credentials. *)
74
-
75
-
val to_common_credentials : credentials -> Common.credentials
76
-
(** [to_common_credentials cred] wraps credentials for use in SLE PDUs. *)
77
-
78
-
(** {1 Pretty-printers} *)
79
-
80
-
val pp_hash_algorithm : hash_algorithm Fmt.t
81
-
val pp_credentials : credentials Fmt.t
82
-
val pp_error : error Fmt.t
-676
lib/sle/raf.ml
-676
lib/sle/raf.ml
···
1
-
(** RAF - Return All Frames Service (CCSDS 911.1-B-4).
2
-
3
-
Pure module - no I/O effects. Implements the RAF service state machine and
4
-
PDU encoding/decoding.
5
-
6
-
RAF provides TM frame delivery from ground station to user. Modes:
7
-
- Timely online: Real-time delivery with frame dropping on congestion
8
-
- Complete online: Real-time delivery with buffering (may delay)
9
-
- Offline: Playback from storage
10
-
11
-
Service lifecycle:
12
-
{v
13
-
[Ready] --start--> [Active] --stop--> [Ready]
14
-
15
-
In Active state:
16
-
- Provider sends TRANSFER-DATA notifications
17
-
- Provider sends SYNC-NOTIFY on frame sync changes
18
-
- User can request GET-PARAMETER, SCHEDULE-STATUS-REPORT
19
-
v} *)
20
-
21
-
open Asn.S
22
-
23
-
(* {1 Types} *)
24
-
25
-
type frame_quality =
26
-
| Good
27
-
| Erred
28
-
| Undetermined
29
-
| Unknown_frame_quality of int (** Unknown value from untrusted PDU *)
30
-
31
-
type production_status =
32
-
| Running
33
-
| Interrupted
34
-
| Halted
35
-
| Unknown_production_status of int (** Unknown value from untrusted PDU *)
36
-
37
-
type lock_status =
38
-
| In_lock
39
-
| Out_of_lock
40
-
| Not_in_use
41
-
| Unknown
42
-
| Unknown_lock_status of int (** Unknown value from untrusted PDU *)
43
-
44
-
(** RAF transfer buffer entry *)
45
-
type frame_or_notification =
46
-
| Frame of {
47
-
earth_receive_time : Common.time option;
48
-
antenna_id : string option;
49
-
data_link_continuity : int;
50
-
carrier_lock_status : lock_status;
51
-
subcarrier_lock_status : lock_status;
52
-
symbol_sync_lock_status : lock_status;
53
-
quality : frame_quality;
54
-
data : bytes;
55
-
}
56
-
| Sync_notify of {
57
-
time : Common.time option;
58
-
carrier_lock : lock_status;
59
-
subcarrier_lock : lock_status;
60
-
symbol_sync_lock : lock_status;
61
-
production_status : production_status;
62
-
}
63
-
64
-
(* {1 Service Operations} *)
65
-
66
-
type start_invocation = {
67
-
invoker_credentials : Common.credentials;
68
-
invoke_id : int;
69
-
start_time : Common.conditional_time;
70
-
stop_time : Common.conditional_time;
71
-
requested_quality : Common.requested_frame_quality;
72
-
}
73
-
(** Start invocation - request frame delivery *)
74
-
75
-
type start_result = Positive | Negative of start_diagnostic
76
-
77
-
and start_diagnostic =
78
-
| Unable_to_comply
79
-
| Invalid_start_time
80
-
| Invalid_stop_time
81
-
| Missing_time_value
82
-
| Out_of_service_start
83
-
| Duplicate_invoke_id_start
84
-
| Unknown_start_diagnostic of int (** Unknown value from untrusted PDU *)
85
-
86
-
type start_return = {
87
-
performer_credentials : Common.credentials;
88
-
invoke_id : int;
89
-
result : start_result;
90
-
}
91
-
92
-
type stop_invocation = {
93
-
invoker_credentials : Common.credentials;
94
-
invoke_id : int;
95
-
}
96
-
(** Stop invocation - stop frame delivery *)
97
-
98
-
type stop_result = Stop_positive | Stop_negative of stop_diagnostic
99
-
100
-
and stop_diagnostic =
101
-
| Duplicate_invoke_id_stop
102
-
| Unknown_stop_diagnostic of int (** Unknown value from untrusted PDU *)
103
-
104
-
type stop_return = {
105
-
performer_credentials : Common.credentials;
106
-
invoke_id : int;
107
-
result : stop_result;
108
-
}
109
-
110
-
type transfer_data = {
111
-
invoker_credentials : Common.credentials;
112
-
earth_receive_time : Common.time option;
113
-
antenna_id : string option;
114
-
data_link_continuity : int;
115
-
frame_quality : frame_quality;
116
-
data : bytes;
117
-
}
118
-
(** Transfer data - provider sends frames to user *)
119
-
120
-
(* {1 GET-PARAMETER Operation} *)
121
-
122
-
type parameter_name =
123
-
| Buffer_size
124
-
| Delivery_mode
125
-
| Latency_limit
126
-
| Reporting_cycle
127
-
| Requested_frame_quality
128
-
| Return_timeout_period
129
-
| Transfer_buffer_size
130
-
| Permitted_frame_quality
131
-
| Minimum_reporting_cycle
132
-
| Unknown_parameter of int (** Unknown value from untrusted PDU *)
133
-
134
-
type parameter_value =
135
-
| Pv_buffer_size of int
136
-
| Pv_delivery_mode of Common.delivery_mode
137
-
| Pv_latency_limit of int option (** None = online, Some n = offline *)
138
-
| Pv_reporting_cycle of int option (** None = off, Some n = seconds *)
139
-
| Pv_requested_frame_quality of Common.requested_frame_quality
140
-
| Pv_return_timeout_period of int
141
-
| Pv_transfer_buffer_size of int
142
-
| Pv_permitted_frame_quality of Common.requested_frame_quality list
143
-
| Pv_minimum_reporting_cycle of int option
144
-
145
-
type get_parameter_diagnostic =
146
-
| Unknown_parameter_diagnostic
147
-
| Gp_duplicate_invoke_id
148
-
| Gp_operation_not_supported
149
-
| Gp_unknown_diagnostic of int (** Unknown value from untrusted PDU *)
150
-
151
-
type get_parameter_invocation = {
152
-
gp_invoker_credentials : Common.credentials;
153
-
gp_invoke_id : int;
154
-
gp_parameter_name : parameter_name;
155
-
}
156
-
157
-
type get_parameter_return = {
158
-
gp_performer_credentials : Common.credentials;
159
-
gp_invoke_id : int;
160
-
gp_result : (parameter_value, get_parameter_diagnostic) result;
161
-
}
162
-
163
-
(* {1 SCHEDULE-STATUS-REPORT Operation} *)
164
-
165
-
type status_report = {
166
-
sr_num_frames_delivered : int;
167
-
sr_frame_sync_lock_status : lock_status;
168
-
sr_carrier_lock_status : lock_status;
169
-
sr_subcarrier_lock_status : lock_status;
170
-
sr_symbol_sync_lock_status : lock_status;
171
-
sr_production_status : production_status;
172
-
}
173
-
174
-
type schedule_status_report_diagnostic =
175
-
| Invalid_reporting_cycle
176
-
| Ssr_duplicate_invoke_id
177
-
| Already_stopped
178
-
| Ssr_unknown_diagnostic of int (** Unknown value from untrusted PDU *)
179
-
180
-
type schedule_status_report_invocation = {
181
-
ssr_invoker_credentials : Common.credentials;
182
-
ssr_invoke_id : int;
183
-
ssr_reporting_cycle : int option; (** None = stop reporting *)
184
-
}
185
-
186
-
type schedule_status_report_return = {
187
-
ssr_performer_credentials : Common.credentials;
188
-
ssr_invoke_id : int;
189
-
ssr_result : (unit, schedule_status_report_diagnostic) result;
190
-
}
191
-
192
-
(* {1 Service State Machine} *)
193
-
194
-
type state =
195
-
| Ready (** Bound, waiting for START *)
196
-
| Active (** Receiving frames *)
197
-
| Stopping (** STOP sent, waiting for return *)
198
-
199
-
type output =
200
-
| Send of bytes
201
-
| Frame_received of frame_or_notification
202
-
| Started
203
-
| Start_failed of start_diagnostic
204
-
| Stopped
205
-
| Parameter_value of get_parameter_return
206
-
| Status_report_scheduled
207
-
| Status_report_stopped
208
-
| Status_report_failed of schedule_status_report_diagnostic
209
-
| Status_report of status_report
210
-
211
-
type input =
212
-
| Initiate_start of start_invocation
213
-
| Start_response of start_return
214
-
| Initiate_stop of stop_invocation
215
-
| Stop_response of stop_return
216
-
| Transfer_data_received of transfer_data
217
-
| Sync_notification of frame_or_notification
218
-
| Initiate_get_parameter of get_parameter_invocation
219
-
| Get_parameter_response of get_parameter_return
220
-
| Initiate_schedule_status_report of schedule_status_report_invocation
221
-
| Schedule_status_report_response of schedule_status_report_return
222
-
| Status_report_received of status_report
223
-
224
-
type error =
225
-
| Invalid_state of { current : state; operation : string }
226
-
| Decode_error of string
227
-
228
-
(* {1 ASN.1 Grammars} *)
229
-
230
-
let frame_quality_grammar =
231
-
map
232
-
(function
233
-
| 0 -> Good
234
-
| 1 -> Erred
235
-
| 2 -> Undetermined
236
-
| n -> Unknown_frame_quality n)
237
-
(function
238
-
| Good -> 0
239
-
| Erred -> 1
240
-
| Undetermined -> 2
241
-
| Unknown_frame_quality n -> n)
242
-
int
243
-
244
-
let lock_status_grammar =
245
-
map
246
-
(function
247
-
| 0 -> In_lock
248
-
| 1 -> Out_of_lock
249
-
| 2 -> Not_in_use
250
-
| 3 -> Unknown
251
-
| n -> Unknown_lock_status n)
252
-
(function
253
-
| In_lock -> 0
254
-
| Out_of_lock -> 1
255
-
| Not_in_use -> 2
256
-
| Unknown -> 3
257
-
| Unknown_lock_status n -> n)
258
-
int
259
-
260
-
let production_status_grammar =
261
-
map
262
-
(function
263
-
| 0 -> Running
264
-
| 1 -> Interrupted
265
-
| 2 -> Halted
266
-
| n -> Unknown_production_status n)
267
-
(function
268
-
| Running -> 0
269
-
| Interrupted -> 1
270
-
| Halted -> 2
271
-
| Unknown_production_status n -> n)
272
-
int
273
-
274
-
let start_diagnostic_grammar =
275
-
map
276
-
(function
277
-
| 0 -> Unable_to_comply
278
-
| 1 -> Invalid_start_time
279
-
| 2 -> Invalid_stop_time
280
-
| 3 -> Missing_time_value
281
-
| 4 -> Out_of_service_start
282
-
| 100 -> Duplicate_invoke_id_start
283
-
| n -> Unknown_start_diagnostic n)
284
-
(function
285
-
| Unable_to_comply -> 0
286
-
| Invalid_start_time -> 1
287
-
| Invalid_stop_time -> 2
288
-
| Missing_time_value -> 3
289
-
| Out_of_service_start -> 4
290
-
| Duplicate_invoke_id_start -> 100
291
-
| Unknown_start_diagnostic n -> n)
292
-
int
293
-
294
-
let start_result_grammar =
295
-
map
296
-
(function `C1 () -> Positive | `C2 d -> Negative d)
297
-
(function Positive -> `C1 () | Negative d -> `C2 d)
298
-
(choice2 (implicit 0 null) (implicit 1 start_diagnostic_grammar))
299
-
300
-
let start_invocation_grammar =
301
-
sequence4
302
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
303
-
(required ~label:"invokeId" int)
304
-
(required ~label:"startTime" Common.conditional_time_grammar)
305
-
(required ~label:"stopTime" Common.conditional_time_grammar)
306
-
307
-
let start_return_grammar =
308
-
sequence3
309
-
(required ~label:"performerCredentials" Common.credentials_grammar)
310
-
(required ~label:"invokeId" int)
311
-
(required ~label:"result" start_result_grammar)
312
-
313
-
let stop_invocation_grammar =
314
-
sequence2
315
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
316
-
(required ~label:"invokeId" int)
317
-
318
-
let stop_diagnostic_grammar =
319
-
map
320
-
(function
321
-
| 100 -> Duplicate_invoke_id_stop | n -> Unknown_stop_diagnostic n)
322
-
(function
323
-
| Duplicate_invoke_id_stop -> 100 | Unknown_stop_diagnostic n -> n)
324
-
int
325
-
326
-
let stop_result_grammar =
327
-
map
328
-
(function `C1 () -> Stop_positive | `C2 d -> Stop_negative d)
329
-
(function Stop_positive -> `C1 () | Stop_negative d -> `C2 d)
330
-
(choice2 (implicit 0 null) (implicit 1 stop_diagnostic_grammar))
331
-
332
-
let stop_return_grammar =
333
-
sequence3
334
-
(required ~label:"performerCredentials" Common.credentials_grammar)
335
-
(required ~label:"invokeId" int)
336
-
(required ~label:"result" stop_result_grammar)
337
-
338
-
let transfer_data_grammar =
339
-
sequence4
340
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
341
-
(required ~label:"dataLinkContinuity" int)
342
-
(required ~label:"frameQuality" frame_quality_grammar)
343
-
(required ~label:"data" octet_string)
344
-
345
-
(* {2 GET-PARAMETER Grammars} *)
346
-
347
-
let parameter_name_grammar =
348
-
map
349
-
(function
350
-
| 4 -> Buffer_size
351
-
| 6 -> Delivery_mode
352
-
| 7 -> Latency_limit
353
-
| 26 -> Reporting_cycle
354
-
| 27 -> Requested_frame_quality
355
-
| 29 -> Return_timeout_period
356
-
| 202 -> Transfer_buffer_size
357
-
| 302 -> Permitted_frame_quality
358
-
| 303 -> Minimum_reporting_cycle
359
-
| n -> Unknown_parameter n)
360
-
(function
361
-
| Buffer_size -> 4
362
-
| Delivery_mode -> 6
363
-
| Latency_limit -> 7
364
-
| Reporting_cycle -> 26
365
-
| Requested_frame_quality -> 27
366
-
| Return_timeout_period -> 29
367
-
| Transfer_buffer_size -> 202
368
-
| Permitted_frame_quality -> 302
369
-
| Minimum_reporting_cycle -> 303
370
-
| Unknown_parameter n -> n)
371
-
int
372
-
373
-
let _get_parameter_diagnostic_grammar =
374
-
map
375
-
(function
376
-
| 0 -> Unknown_parameter_diagnostic
377
-
| 100 -> Gp_duplicate_invoke_id
378
-
| 101 -> Gp_operation_not_supported
379
-
| n -> Gp_unknown_diagnostic n)
380
-
(function
381
-
| Unknown_parameter_diagnostic -> 0
382
-
| Gp_duplicate_invoke_id -> 100
383
-
| Gp_operation_not_supported -> 101
384
-
| Gp_unknown_diagnostic n -> n)
385
-
int
386
-
387
-
let get_parameter_invocation_grammar =
388
-
sequence3
389
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
390
-
(required ~label:"invokeId" int)
391
-
(required ~label:"rafParameter" parameter_name_grammar)
392
-
393
-
(* {2 SCHEDULE-STATUS-REPORT Grammars} *)
394
-
395
-
let schedule_status_report_diagnostic_grammar =
396
-
map
397
-
(function
398
-
| 0 -> Invalid_reporting_cycle
399
-
| 100 -> Ssr_duplicate_invoke_id
400
-
| 1 -> Already_stopped
401
-
| n -> Ssr_unknown_diagnostic n)
402
-
(function
403
-
| Invalid_reporting_cycle -> 0
404
-
| Ssr_duplicate_invoke_id -> 100
405
-
| Already_stopped -> 1
406
-
| Ssr_unknown_diagnostic n -> n)
407
-
int
408
-
409
-
let schedule_status_report_invocation_grammar =
410
-
sequence3
411
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
412
-
(required ~label:"invokeId" int)
413
-
(required ~label:"reportingCycle" (implicit 0 int))
414
-
415
-
let schedule_status_report_result_grammar =
416
-
map
417
-
(function `C1 () -> Ok () | `C2 d -> Error d)
418
-
(function Ok () -> `C1 () | Error d -> `C2 d)
419
-
(choice2 (implicit 0 null)
420
-
(implicit 1 schedule_status_report_diagnostic_grammar))
421
-
422
-
let schedule_status_report_return_grammar =
423
-
sequence3
424
-
(required ~label:"performerCredentials" Common.credentials_grammar)
425
-
(required ~label:"invokeId" int)
426
-
(required ~label:"result" schedule_status_report_result_grammar)
427
-
428
-
let status_report_grammar =
429
-
sequence6
430
-
(required ~label:"numFramesDelivered" int)
431
-
(required ~label:"frameSyncLockStatus" lock_status_grammar)
432
-
(required ~label:"carrierLockStatus" lock_status_grammar)
433
-
(required ~label:"subcarrierLockStatus" lock_status_grammar)
434
-
(required ~label:"symbolSyncLockStatus" lock_status_grammar)
435
-
(required ~label:"productionStatus" production_status_grammar)
436
-
437
-
(* {1 Encoding} *)
438
-
439
-
let encode_start_invocation (inv : start_invocation) =
440
-
let codec = Asn.codec Asn.ber start_invocation_grammar in
441
-
let s =
442
-
Asn.encode codec
443
-
(inv.invoker_credentials, inv.invoke_id, inv.start_time, inv.stop_time)
444
-
in
445
-
Bytes.of_string s
446
-
447
-
let encode_stop_invocation (inv : stop_invocation) =
448
-
let codec = Asn.codec Asn.ber stop_invocation_grammar in
449
-
let s = Asn.encode codec (inv.invoker_credentials, inv.invoke_id) in
450
-
Bytes.of_string s
451
-
452
-
let encode_get_parameter_invocation (inv : get_parameter_invocation) =
453
-
let codec = Asn.codec Asn.ber get_parameter_invocation_grammar in
454
-
let s =
455
-
Asn.encode codec
456
-
(inv.gp_invoker_credentials, inv.gp_invoke_id, inv.gp_parameter_name)
457
-
in
458
-
Bytes.of_string s
459
-
460
-
let encode_schedule_status_report_invocation
461
-
(inv : schedule_status_report_invocation) =
462
-
let codec = Asn.codec Asn.ber schedule_status_report_invocation_grammar in
463
-
let cycle = Option.value inv.ssr_reporting_cycle ~default:0 in
464
-
let s =
465
-
Asn.encode codec (inv.ssr_invoker_credentials, inv.ssr_invoke_id, cycle)
466
-
in
467
-
Bytes.of_string s
468
-
469
-
(* {1 Decoding} *)
470
-
471
-
let decode_start_return buf : (start_return, error) result =
472
-
let codec = Asn.codec Asn.ber start_return_grammar in
473
-
match Asn.decode codec (Bytes.to_string buf) with
474
-
| Ok ((cred, id, result), _) ->
475
-
Ok { performer_credentials = cred; invoke_id = id; result }
476
-
| Error _ -> Error (Decode_error "start return")
477
-
478
-
let decode_stop_return buf : (stop_return, error) result =
479
-
let codec = Asn.codec Asn.ber stop_return_grammar in
480
-
match Asn.decode codec (Bytes.to_string buf) with
481
-
| Ok ((cred, id, result), _) ->
482
-
Ok { performer_credentials = cred; invoke_id = id; result }
483
-
| Error _ -> Error (Decode_error "stop return")
484
-
485
-
let decode_transfer_data buf =
486
-
let codec = Asn.codec Asn.ber transfer_data_grammar in
487
-
match Asn.decode codec (Bytes.to_string buf) with
488
-
| Ok ((cred, continuity, quality, data), _) ->
489
-
Ok
490
-
{
491
-
invoker_credentials = cred;
492
-
earth_receive_time = None;
493
-
antenna_id = None;
494
-
data_link_continuity = continuity;
495
-
frame_quality = quality;
496
-
data = Bytes.of_string data;
497
-
}
498
-
| Error _ -> Error (Decode_error "transfer data")
499
-
500
-
let decode_schedule_status_report_return buf :
501
-
(schedule_status_report_return, error) result =
502
-
let codec = Asn.codec Asn.ber schedule_status_report_return_grammar in
503
-
match Asn.decode codec (Bytes.to_string buf) with
504
-
| Ok ((cred, id, result), _) ->
505
-
Ok
506
-
{
507
-
ssr_performer_credentials = cred;
508
-
ssr_invoke_id = id;
509
-
ssr_result = result;
510
-
}
511
-
| Error _ -> Error (Decode_error "schedule status report return")
512
-
513
-
let decode_status_report buf : (status_report, error) result =
514
-
let codec = Asn.codec Asn.ber status_report_grammar in
515
-
match Asn.decode codec (Bytes.to_string buf) with
516
-
| Ok ((frames, frame_sync, carrier, subcarrier, symbol, prod), _) ->
517
-
Ok
518
-
{
519
-
sr_num_frames_delivered = frames;
520
-
sr_frame_sync_lock_status = frame_sync;
521
-
sr_carrier_lock_status = carrier;
522
-
sr_subcarrier_lock_status = subcarrier;
523
-
sr_symbol_sync_lock_status = symbol;
524
-
sr_production_status = prod;
525
-
}
526
-
| Error _ -> Error (Decode_error "status report")
527
-
528
-
(* {1 State Machine} *)
529
-
530
-
let initial = Ready
531
-
532
-
let step state input =
533
-
match (state, input) with
534
-
| Ready, Initiate_start inv ->
535
-
let pdu = encode_start_invocation inv in
536
-
Ok (Ready, [ Send pdu ])
537
-
(* Stay Ready until response *)
538
-
| Ready, Start_response ret -> (
539
-
match ret.result with
540
-
| Positive -> Ok (Active, [ Started ])
541
-
| Negative diag -> Ok (Ready, [ Start_failed diag ]))
542
-
| Active, Transfer_data_received td ->
543
-
let frame =
544
-
Frame
545
-
{
546
-
earth_receive_time = td.earth_receive_time;
547
-
antenna_id = td.antenna_id;
548
-
data_link_continuity = td.data_link_continuity;
549
-
carrier_lock_status = Unknown;
550
-
subcarrier_lock_status = Unknown;
551
-
symbol_sync_lock_status = Unknown;
552
-
quality = td.frame_quality;
553
-
data = td.data;
554
-
}
555
-
in
556
-
Ok (Active, [ Frame_received frame ])
557
-
| Active, Sync_notification notif -> Ok (Active, [ Frame_received notif ])
558
-
| Active, Initiate_get_parameter inv ->
559
-
let pdu = encode_get_parameter_invocation inv in
560
-
Ok (Active, [ Send pdu ])
561
-
| Active, Get_parameter_response ret -> Ok (Active, [ Parameter_value ret ])
562
-
| Active, Initiate_schedule_status_report inv ->
563
-
let pdu = encode_schedule_status_report_invocation inv in
564
-
Ok (Active, [ Send pdu ])
565
-
| Active, Schedule_status_report_response ret -> (
566
-
match ret.ssr_result with
567
-
| Ok () ->
568
-
if ret.ssr_invoke_id = 0 then Ok (Active, [ Status_report_stopped ])
569
-
else Ok (Active, [ Status_report_scheduled ])
570
-
| Error diag -> Ok (Active, [ Status_report_failed diag ]))
571
-
| Active, Status_report_received report ->
572
-
Ok (Active, [ Status_report report ])
573
-
| Active, Initiate_stop inv ->
574
-
let pdu = encode_stop_invocation inv in
575
-
Ok (Stopping, [ Send pdu ])
576
-
| Stopping, Stop_response ret -> (
577
-
match ret.result with
578
-
| Stop_positive -> Ok (Ready, [ Stopped ])
579
-
| Stop_negative _ -> Ok (Ready, [ Stopped ]) (* Stop anyway *))
580
-
| _, _ ->
581
-
Error
582
-
(Invalid_state
583
-
{
584
-
current = state;
585
-
operation =
586
-
(match input with
587
-
| Initiate_start _ -> "start"
588
-
| Start_response _ -> "start_response"
589
-
| Initiate_stop _ -> "stop"
590
-
| Stop_response _ -> "stop_response"
591
-
| Transfer_data_received _ -> "transfer_data"
592
-
| Sync_notification _ -> "sync_notify"
593
-
| Initiate_get_parameter _ -> "get_parameter"
594
-
| Get_parameter_response _ -> "get_parameter_response"
595
-
| Initiate_schedule_status_report _ -> "schedule_status_report"
596
-
| Schedule_status_report_response _ ->
597
-
"schedule_status_report_response"
598
-
| Status_report_received _ -> "status_report");
599
-
})
600
-
601
-
(* {1 Pretty-printers} *)
602
-
603
-
let pp_state ppf = function
604
-
| Ready -> Fmt.string ppf "Ready"
605
-
| Active -> Fmt.string ppf "Active"
606
-
| Stopping -> Fmt.string ppf "Stopping"
607
-
608
-
let pp_frame_quality ppf = function
609
-
| Good -> Fmt.string ppf "good"
610
-
| Erred -> Fmt.string ppf "erred"
611
-
| Undetermined -> Fmt.string ppf "undetermined"
612
-
| Unknown_frame_quality n -> Fmt.pf ppf "unknown(%d)" n
613
-
614
-
let pp_lock_status ppf = function
615
-
| In_lock -> Fmt.string ppf "in-lock"
616
-
| Out_of_lock -> Fmt.string ppf "out-of-lock"
617
-
| Not_in_use -> Fmt.string ppf "not-in-use"
618
-
| Unknown -> Fmt.string ppf "unknown"
619
-
| Unknown_lock_status n -> Fmt.pf ppf "unknown(%d)" n
620
-
621
-
let pp_production_status ppf = function
622
-
| Running -> Fmt.string ppf "running"
623
-
| Interrupted -> Fmt.string ppf "interrupted"
624
-
| Halted -> Fmt.string ppf "halted"
625
-
| Unknown_production_status n -> Fmt.pf ppf "unknown(%d)" n
626
-
627
-
let pp_start_diagnostic ppf = function
628
-
| Unable_to_comply -> Fmt.string ppf "unable-to-comply"
629
-
| Invalid_start_time -> Fmt.string ppf "invalid-start-time"
630
-
| Invalid_stop_time -> Fmt.string ppf "invalid-stop-time"
631
-
| Missing_time_value -> Fmt.string ppf "missing-time-value"
632
-
| Out_of_service_start -> Fmt.string ppf "out-of-service"
633
-
| Duplicate_invoke_id_start -> Fmt.string ppf "duplicate-invoke-id"
634
-
| Unknown_start_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
635
-
636
-
let pp_stop_diagnostic ppf = function
637
-
| Duplicate_invoke_id_stop -> Fmt.string ppf "duplicate-invoke-id"
638
-
| Unknown_stop_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
639
-
640
-
let pp_parameter_name ppf = function
641
-
| Buffer_size -> Fmt.string ppf "buffer-size"
642
-
| Delivery_mode -> Fmt.string ppf "delivery-mode"
643
-
| Latency_limit -> Fmt.string ppf "latency-limit"
644
-
| Reporting_cycle -> Fmt.string ppf "reporting-cycle"
645
-
| Requested_frame_quality -> Fmt.string ppf "requested-frame-quality"
646
-
| Return_timeout_period -> Fmt.string ppf "return-timeout-period"
647
-
| Transfer_buffer_size -> Fmt.string ppf "transfer-buffer-size"
648
-
| Permitted_frame_quality -> Fmt.string ppf "permitted-frame-quality"
649
-
| Minimum_reporting_cycle -> Fmt.string ppf "minimum-reporting-cycle"
650
-
| Unknown_parameter n -> Fmt.pf ppf "unknown(%d)" n
651
-
652
-
let pp_get_parameter_diagnostic ppf = function
653
-
| Unknown_parameter_diagnostic -> Fmt.string ppf "unknown-parameter"
654
-
| Gp_duplicate_invoke_id -> Fmt.string ppf "duplicate-invoke-id"
655
-
| Gp_operation_not_supported -> Fmt.string ppf "operation-not-supported"
656
-
| Gp_unknown_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
657
-
658
-
let pp_schedule_status_report_diagnostic ppf = function
659
-
| Invalid_reporting_cycle -> Fmt.string ppf "invalid-reporting-cycle"
660
-
| Ssr_duplicate_invoke_id -> Fmt.string ppf "duplicate-invoke-id"
661
-
| Already_stopped -> Fmt.string ppf "already-stopped"
662
-
| Ssr_unknown_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
663
-
664
-
let pp_status_report ppf sr =
665
-
Fmt.pf ppf
666
-
"{ frames=%d; frame_sync=%a; carrier=%a; subcarrier=%a; symbol=%a; prod=%a \
667
-
}"
668
-
sr.sr_num_frames_delivered pp_lock_status sr.sr_frame_sync_lock_status
669
-
pp_lock_status sr.sr_carrier_lock_status pp_lock_status
670
-
sr.sr_subcarrier_lock_status pp_lock_status sr.sr_symbol_sync_lock_status
671
-
pp_production_status sr.sr_production_status
672
-
673
-
let pp_error ppf = function
674
-
| Invalid_state { current; operation } ->
675
-
Fmt.pf ppf "invalid state %a for operation %s" pp_state current operation
676
-
| Decode_error s -> Fmt.pf ppf "decode error: %s" s
-269
lib/sle/raf.mli
-269
lib/sle/raf.mli
···
1
-
(** RAF - Return All Frames Service (CCSDS 911.1-B-4).
2
-
3
-
Pure module - no I/O effects. Implements the RAF service state machine and
4
-
PDU encoding/decoding.
5
-
6
-
RAF provides TM frame delivery from ground station to user. Modes:
7
-
- Timely online: Real-time delivery with frame dropping on congestion
8
-
- Complete online: Real-time delivery with buffering (may delay)
9
-
- Offline: Playback from storage
10
-
11
-
Service lifecycle:
12
-
{v
13
-
[Ready] --start--> [Active] --stop--> [Ready]
14
-
15
-
In Active state:
16
-
- Provider sends TRANSFER-DATA notifications
17
-
- Provider sends SYNC-NOTIFY on frame sync changes
18
-
- User can request GET-PARAMETER, SCHEDULE-STATUS-REPORT
19
-
v} *)
20
-
21
-
(** {1 Types} *)
22
-
23
-
type frame_quality =
24
-
| Good
25
-
| Erred
26
-
| Undetermined
27
-
| Unknown_frame_quality of int (** Unknown value from untrusted PDU *)
28
-
29
-
type production_status =
30
-
| Running
31
-
| Interrupted
32
-
| Halted
33
-
| Unknown_production_status of int (** Unknown value from untrusted PDU *)
34
-
35
-
type lock_status =
36
-
| In_lock
37
-
| Out_of_lock
38
-
| Not_in_use
39
-
| Unknown
40
-
| Unknown_lock_status of int (** Unknown value from untrusted PDU *)
41
-
42
-
(** RAF transfer buffer entry *)
43
-
type frame_or_notification =
44
-
| Frame of {
45
-
earth_receive_time : Common.time option;
46
-
antenna_id : string option;
47
-
data_link_continuity : int;
48
-
carrier_lock_status : lock_status;
49
-
subcarrier_lock_status : lock_status;
50
-
symbol_sync_lock_status : lock_status;
51
-
quality : frame_quality;
52
-
data : bytes;
53
-
}
54
-
| Sync_notify of {
55
-
time : Common.time option;
56
-
carrier_lock : lock_status;
57
-
subcarrier_lock : lock_status;
58
-
symbol_sync_lock : lock_status;
59
-
production_status : production_status;
60
-
}
61
-
62
-
(** {1 Service Operations} *)
63
-
64
-
type start_invocation = {
65
-
invoker_credentials : Common.credentials;
66
-
invoke_id : int;
67
-
start_time : Common.conditional_time;
68
-
stop_time : Common.conditional_time;
69
-
requested_quality : Common.requested_frame_quality;
70
-
}
71
-
(** Start invocation - request frame delivery *)
72
-
73
-
type start_result = Positive | Negative of start_diagnostic
74
-
75
-
and start_diagnostic =
76
-
| Unable_to_comply
77
-
| Invalid_start_time
78
-
| Invalid_stop_time
79
-
| Missing_time_value
80
-
| Out_of_service_start
81
-
| Duplicate_invoke_id_start
82
-
| Unknown_start_diagnostic of int (** Unknown value from untrusted PDU *)
83
-
84
-
type start_return = {
85
-
performer_credentials : Common.credentials;
86
-
invoke_id : int;
87
-
result : start_result;
88
-
}
89
-
90
-
type stop_invocation = {
91
-
invoker_credentials : Common.credentials;
92
-
invoke_id : int;
93
-
}
94
-
(** Stop invocation - stop frame delivery *)
95
-
96
-
type stop_result = Stop_positive | Stop_negative of stop_diagnostic
97
-
98
-
and stop_diagnostic =
99
-
| Duplicate_invoke_id_stop
100
-
| Unknown_stop_diagnostic of int (** Unknown value from untrusted PDU *)
101
-
102
-
type stop_return = {
103
-
performer_credentials : Common.credentials;
104
-
invoke_id : int;
105
-
result : stop_result;
106
-
}
107
-
108
-
type transfer_data = {
109
-
invoker_credentials : Common.credentials;
110
-
earth_receive_time : Common.time option;
111
-
antenna_id : string option;
112
-
data_link_continuity : int;
113
-
frame_quality : frame_quality;
114
-
data : bytes;
115
-
}
116
-
(** Transfer data - provider sends frames to user *)
117
-
118
-
(** {1 GET-PARAMETER Operation} *)
119
-
120
-
type parameter_name =
121
-
| Buffer_size
122
-
| Delivery_mode
123
-
| Latency_limit
124
-
| Reporting_cycle
125
-
| Requested_frame_quality
126
-
| Return_timeout_period
127
-
| Transfer_buffer_size
128
-
| Permitted_frame_quality
129
-
| Minimum_reporting_cycle
130
-
| Unknown_parameter of int (** Unknown value from untrusted PDU *)
131
-
132
-
type parameter_value =
133
-
| Pv_buffer_size of int
134
-
| Pv_delivery_mode of Common.delivery_mode
135
-
| Pv_latency_limit of int option (** None = online, Some n = offline *)
136
-
| Pv_reporting_cycle of int option (** None = off, Some n = seconds *)
137
-
| Pv_requested_frame_quality of Common.requested_frame_quality
138
-
| Pv_return_timeout_period of int
139
-
| Pv_transfer_buffer_size of int
140
-
| Pv_permitted_frame_quality of Common.requested_frame_quality list
141
-
| Pv_minimum_reporting_cycle of int option
142
-
143
-
type get_parameter_diagnostic =
144
-
| Unknown_parameter_diagnostic
145
-
| Gp_duplicate_invoke_id
146
-
| Gp_operation_not_supported
147
-
| Gp_unknown_diagnostic of int (** Unknown value from untrusted PDU *)
148
-
149
-
type get_parameter_invocation = {
150
-
gp_invoker_credentials : Common.credentials;
151
-
gp_invoke_id : int;
152
-
gp_parameter_name : parameter_name;
153
-
}
154
-
155
-
type get_parameter_return = {
156
-
gp_performer_credentials : Common.credentials;
157
-
gp_invoke_id : int;
158
-
gp_result : (parameter_value, get_parameter_diagnostic) result;
159
-
}
160
-
161
-
(** {1 SCHEDULE-STATUS-REPORT Operation} *)
162
-
163
-
type status_report = {
164
-
sr_num_frames_delivered : int;
165
-
sr_frame_sync_lock_status : lock_status;
166
-
sr_carrier_lock_status : lock_status;
167
-
sr_subcarrier_lock_status : lock_status;
168
-
sr_symbol_sync_lock_status : lock_status;
169
-
sr_production_status : production_status;
170
-
}
171
-
172
-
type schedule_status_report_diagnostic =
173
-
| Invalid_reporting_cycle
174
-
| Ssr_duplicate_invoke_id
175
-
| Already_stopped
176
-
| Ssr_unknown_diagnostic of int (** Unknown value from untrusted PDU *)
177
-
178
-
type schedule_status_report_invocation = {
179
-
ssr_invoker_credentials : Common.credentials;
180
-
ssr_invoke_id : int;
181
-
ssr_reporting_cycle : int option; (** None = stop reporting *)
182
-
}
183
-
184
-
type schedule_status_report_return = {
185
-
ssr_performer_credentials : Common.credentials;
186
-
ssr_invoke_id : int;
187
-
ssr_result : (unit, schedule_status_report_diagnostic) result;
188
-
}
189
-
190
-
(** {1 Service State Machine} *)
191
-
192
-
type state =
193
-
| Ready (** Bound, waiting for START *)
194
-
| Active (** Receiving frames *)
195
-
| Stopping (** STOP sent, waiting for return *)
196
-
197
-
type output =
198
-
| Send of bytes
199
-
| Frame_received of frame_or_notification
200
-
| Started
201
-
| Start_failed of start_diagnostic
202
-
| Stopped
203
-
| Parameter_value of get_parameter_return
204
-
| Status_report_scheduled
205
-
| Status_report_stopped
206
-
| Status_report_failed of schedule_status_report_diagnostic
207
-
| Status_report of status_report
208
-
209
-
type input =
210
-
| Initiate_start of start_invocation
211
-
| Start_response of start_return
212
-
| Initiate_stop of stop_invocation
213
-
| Stop_response of stop_return
214
-
| Transfer_data_received of transfer_data
215
-
| Sync_notification of frame_or_notification
216
-
| Initiate_get_parameter of get_parameter_invocation
217
-
| Get_parameter_response of get_parameter_return
218
-
| Initiate_schedule_status_report of schedule_status_report_invocation
219
-
| Schedule_status_report_response of schedule_status_report_return
220
-
| Status_report_received of status_report
221
-
222
-
type error =
223
-
| Invalid_state of { current : state; operation : string }
224
-
| Decode_error of string
225
-
226
-
(** {1 State Machine Operations} *)
227
-
228
-
val initial : state
229
-
(** Initial state is [Ready]. *)
230
-
231
-
val step : state -> input -> (state * output list, error) result
232
-
(** [step state input] processes an input and returns new state with outputs. *)
233
-
234
-
(** {1 Encoding} *)
235
-
236
-
val encode_start_invocation : start_invocation -> bytes
237
-
val encode_stop_invocation : stop_invocation -> bytes
238
-
val encode_get_parameter_invocation : get_parameter_invocation -> bytes
239
-
240
-
val encode_schedule_status_report_invocation :
241
-
schedule_status_report_invocation -> bytes
242
-
243
-
(** {1 Decoding} *)
244
-
245
-
val decode_start_return : bytes -> (start_return, error) result
246
-
val decode_stop_return : bytes -> (stop_return, error) result
247
-
val decode_transfer_data : bytes -> (transfer_data, error) result
248
-
249
-
val decode_schedule_status_report_return :
250
-
bytes -> (schedule_status_report_return, error) result
251
-
252
-
val decode_status_report : bytes -> (status_report, error) result
253
-
254
-
(** {1 Pretty-printers} *)
255
-
256
-
val pp_state : state Fmt.t
257
-
val pp_frame_quality : frame_quality Fmt.t
258
-
val pp_lock_status : lock_status Fmt.t
259
-
val pp_production_status : production_status Fmt.t
260
-
val pp_start_diagnostic : start_diagnostic Fmt.t
261
-
val pp_stop_diagnostic : stop_diagnostic Fmt.t
262
-
val pp_parameter_name : parameter_name Fmt.t
263
-
val pp_get_parameter_diagnostic : get_parameter_diagnostic Fmt.t
264
-
265
-
val pp_schedule_status_report_diagnostic :
266
-
schedule_status_report_diagnostic Fmt.t
267
-
268
-
val pp_status_report : status_report Fmt.t
269
-
val pp_error : error Fmt.t
-724
lib/sle/rcf.ml
-724
lib/sle/rcf.ml
···
1
-
(** RCF - Return Channel Frames Service (CCSDS 911.2-B-3).
2
-
3
-
Pure module - no I/O effects. Implements the RCF service state machine and
4
-
PDU encoding/decoding.
5
-
6
-
RCF provides TM frame delivery from ground station to user, filtered by
7
-
Global Virtual Channel Identifier (GVCID). This differs from RAF which
8
-
delivers all frames.
9
-
10
-
Key difference from RAF:
11
-
- RCF start invocation includes a requested GVCID list for filtering
12
-
- Frames include GVCID metadata
13
-
14
-
Service lifecycle:
15
-
{v
16
-
[Ready] --start--> [Active] --stop--> [Ready]
17
-
18
-
In Active state:
19
-
- Provider sends TRANSFER-DATA notifications (filtered by GVCID)
20
-
- Provider sends SYNC-NOTIFY on frame sync changes
21
-
- User can request GET-PARAMETER, SCHEDULE-STATUS-REPORT
22
-
v} *)
23
-
24
-
open Asn.S
25
-
26
-
(* {1 Types} *)
27
-
28
-
type frame_quality =
29
-
| Good
30
-
| Erred
31
-
| Undetermined
32
-
| Unknown_frame_quality of int (** Unknown value from untrusted PDU *)
33
-
34
-
type production_status =
35
-
| Running
36
-
| Interrupted
37
-
| Halted
38
-
| Unknown_production_status of int (** Unknown value from untrusted PDU *)
39
-
40
-
type lock_status =
41
-
| In_lock
42
-
| Out_of_lock
43
-
| Not_in_use
44
-
| Unknown
45
-
| Unknown_lock_status of int (** Unknown value from untrusted PDU *)
46
-
47
-
type gvcid = {
48
-
spacecraft_id : int; (** 10-bit spacecraft ID *)
49
-
version : int; (** 2-bit version number *)
50
-
vcid : int option; (** None = master channel, Some n = specific VC (0-63) *)
51
-
}
52
-
(** Global Virtual Channel Identifier - uniquely identifies a virtual channel *)
53
-
54
-
(** Requested GVCID filtering *)
55
-
type requested_gvcid =
56
-
| Gvcid_list of gvcid list (** Filter by specific GVCIDs *)
57
-
| Undefined (** All GVCIDs - no filtering *)
58
-
59
-
(** RCF transfer buffer entry *)
60
-
type frame_or_notification =
61
-
| Frame of {
62
-
earth_receive_time : Common.time option;
63
-
antenna_id : string option;
64
-
data_link_continuity : int;
65
-
carrier_lock_status : lock_status;
66
-
subcarrier_lock_status : lock_status;
67
-
symbol_sync_lock_status : lock_status;
68
-
quality : frame_quality;
69
-
gvcid : gvcid; (** GVCID of this frame - KEY DIFFERENCE from RAF *)
70
-
data : bytes;
71
-
}
72
-
| Sync_notify of {
73
-
time : Common.time option;
74
-
carrier_lock : lock_status;
75
-
subcarrier_lock : lock_status;
76
-
symbol_sync_lock : lock_status;
77
-
production_status : production_status;
78
-
}
79
-
80
-
(* {1 Service Operations} *)
81
-
82
-
type start_invocation = {
83
-
invoker_credentials : Common.credentials;
84
-
invoke_id : int;
85
-
start_time : Common.conditional_time;
86
-
stop_time : Common.conditional_time;
87
-
requested_gvcid : requested_gvcid; (** GVCID filter - KEY DIFFERENCE *)
88
-
requested_quality : Common.requested_frame_quality;
89
-
}
90
-
(** Start invocation - request frame delivery with GVCID filtering *)
91
-
92
-
type start_result = Positive | Negative of start_diagnostic
93
-
94
-
and start_diagnostic =
95
-
| Unable_to_comply
96
-
| Invalid_start_time
97
-
| Invalid_stop_time
98
-
| Missing_time_value
99
-
| Invalid_gvcid (** RCF-specific: requested GVCID not available *)
100
-
| Out_of_service_start
101
-
| Duplicate_invoke_id_start
102
-
| Unknown_start_diagnostic of int (** Unknown value from untrusted PDU *)
103
-
104
-
type start_return = {
105
-
performer_credentials : Common.credentials;
106
-
invoke_id : int;
107
-
result : start_result;
108
-
}
109
-
110
-
type stop_invocation = {
111
-
invoker_credentials : Common.credentials;
112
-
invoke_id : int;
113
-
}
114
-
(** Stop invocation - stop frame delivery *)
115
-
116
-
type stop_result = Stop_positive | Stop_negative of stop_diagnostic
117
-
118
-
and stop_diagnostic =
119
-
| Duplicate_invoke_id_stop
120
-
| Unknown_stop_diagnostic of int (** Unknown value from untrusted PDU *)
121
-
122
-
type stop_return = {
123
-
performer_credentials : Common.credentials;
124
-
invoke_id : int;
125
-
result : stop_result;
126
-
}
127
-
128
-
type transfer_data = {
129
-
invoker_credentials : Common.credentials;
130
-
earth_receive_time : Common.time option;
131
-
antenna_id : string option;
132
-
data_link_continuity : int;
133
-
frame_quality : frame_quality;
134
-
gvcid : gvcid; (** GVCID of this frame *)
135
-
data : bytes;
136
-
}
137
-
(** Transfer data - provider sends frames to user *)
138
-
139
-
(* {1 GET-PARAMETER Operation} *)
140
-
141
-
type parameter_name =
142
-
| Buffer_size
143
-
| Delivery_mode
144
-
| Latency_limit
145
-
| Reporting_cycle
146
-
| Requested_gvcid
147
-
| Return_timeout_period
148
-
| Transfer_buffer_size
149
-
| Permitted_gvcid_set
150
-
| Minimum_reporting_cycle
151
-
| Unknown_parameter of int (** Unknown value from untrusted PDU *)
152
-
153
-
type parameter_value =
154
-
| Pv_buffer_size of int
155
-
| Pv_delivery_mode of Common.delivery_mode
156
-
| Pv_latency_limit of int option (** None = online, Some n = offline *)
157
-
| Pv_reporting_cycle of int option (** None = off, Some n = seconds *)
158
-
| Pv_requested_gvcid of requested_gvcid
159
-
| Pv_return_timeout_period of int
160
-
| Pv_transfer_buffer_size of int
161
-
| Pv_permitted_gvcid_set of gvcid list
162
-
| Pv_minimum_reporting_cycle of int option
163
-
164
-
type get_parameter_diagnostic =
165
-
| Unknown_parameter_diagnostic
166
-
| Gp_duplicate_invoke_id
167
-
| Gp_operation_not_supported
168
-
| Gp_unknown_diagnostic of int (** Unknown value from untrusted PDU *)
169
-
170
-
type get_parameter_invocation = {
171
-
gp_invoker_credentials : Common.credentials;
172
-
gp_invoke_id : int;
173
-
gp_parameter_name : parameter_name;
174
-
}
175
-
176
-
type get_parameter_return = {
177
-
gp_performer_credentials : Common.credentials;
178
-
gp_invoke_id : int;
179
-
gp_result : (parameter_value, get_parameter_diagnostic) result;
180
-
}
181
-
182
-
(* {1 SCHEDULE-STATUS-REPORT Operation} *)
183
-
184
-
type status_report = {
185
-
sr_num_frames_delivered : int;
186
-
sr_frame_sync_lock_status : lock_status;
187
-
sr_carrier_lock_status : lock_status;
188
-
sr_subcarrier_lock_status : lock_status;
189
-
sr_symbol_sync_lock_status : lock_status;
190
-
sr_production_status : production_status;
191
-
}
192
-
193
-
type schedule_status_report_diagnostic =
194
-
| Invalid_reporting_cycle
195
-
| Ssr_duplicate_invoke_id
196
-
| Already_stopped
197
-
| Ssr_unknown_diagnostic of int (** Unknown value from untrusted PDU *)
198
-
199
-
type schedule_status_report_invocation = {
200
-
ssr_invoker_credentials : Common.credentials;
201
-
ssr_invoke_id : int;
202
-
ssr_reporting_cycle : int option; (** None = stop reporting *)
203
-
}
204
-
205
-
type schedule_status_report_return = {
206
-
ssr_performer_credentials : Common.credentials;
207
-
ssr_invoke_id : int;
208
-
ssr_result : (unit, schedule_status_report_diagnostic) result;
209
-
}
210
-
211
-
(* {1 Service State Machine} *)
212
-
213
-
type state =
214
-
| Ready (** Bound, waiting for START *)
215
-
| Active (** Receiving frames *)
216
-
| Stopping (** STOP sent, waiting for return *)
217
-
218
-
type output =
219
-
| Send of bytes
220
-
| Frame_received of frame_or_notification
221
-
| Started
222
-
| Start_failed of start_diagnostic
223
-
| Stopped
224
-
| Parameter_value of get_parameter_return
225
-
| Status_report_scheduled
226
-
| Status_report_stopped
227
-
| Status_report_failed of schedule_status_report_diagnostic
228
-
| Status_report of status_report
229
-
230
-
type input =
231
-
| Initiate_start of start_invocation
232
-
| Start_response of start_return
233
-
| Initiate_stop of stop_invocation
234
-
| Stop_response of stop_return
235
-
| Transfer_data_received of transfer_data
236
-
| Sync_notification of frame_or_notification
237
-
| Initiate_get_parameter of get_parameter_invocation
238
-
| Get_parameter_response of get_parameter_return
239
-
| Initiate_schedule_status_report of schedule_status_report_invocation
240
-
| Schedule_status_report_response of schedule_status_report_return
241
-
| Status_report_received of status_report
242
-
243
-
type error =
244
-
| Invalid_state of { current : state; operation : string }
245
-
| Decode_error of string
246
-
247
-
(* {1 ASN.1 Grammars} *)
248
-
249
-
let frame_quality_grammar =
250
-
map
251
-
(function
252
-
| 0 -> Good
253
-
| 1 -> Erred
254
-
| 2 -> Undetermined
255
-
| n -> Unknown_frame_quality n)
256
-
(function
257
-
| Good -> 0
258
-
| Erred -> 1
259
-
| Undetermined -> 2
260
-
| Unknown_frame_quality n -> n)
261
-
int
262
-
263
-
let lock_status_grammar =
264
-
map
265
-
(function
266
-
| 0 -> In_lock
267
-
| 1 -> Out_of_lock
268
-
| 2 -> Not_in_use
269
-
| 3 -> Unknown
270
-
| n -> Unknown_lock_status n)
271
-
(function
272
-
| In_lock -> 0
273
-
| Out_of_lock -> 1
274
-
| Not_in_use -> 2
275
-
| Unknown -> 3
276
-
| Unknown_lock_status n -> n)
277
-
int
278
-
279
-
let production_status_grammar =
280
-
map
281
-
(function
282
-
| 0 -> Running
283
-
| 1 -> Interrupted
284
-
| 2 -> Halted
285
-
| n -> Unknown_production_status n)
286
-
(function
287
-
| Running -> 0
288
-
| Interrupted -> 1
289
-
| Halted -> 2
290
-
| Unknown_production_status n -> n)
291
-
int
292
-
293
-
(* GVCID is encoded as a SEQUENCE { scid INTEGER, version INTEGER, vcid INTEGER }
294
-
where vcid = -1 means master channel (all VCIDs) *)
295
-
let gvcid_grammar =
296
-
map
297
-
(fun (scid, version, vcid_raw) ->
298
-
let vcid = if vcid_raw < 0 then None else Some vcid_raw in
299
-
{ spacecraft_id = scid; version; vcid })
300
-
(fun g ->
301
-
let vcid_raw = match g.vcid with None -> -1 | Some v -> v in
302
-
(g.spacecraft_id, g.version, vcid_raw))
303
-
(sequence3
304
-
(required ~label:"spacecraftId" int)
305
-
(required ~label:"versionNumber" int)
306
-
(required ~label:"vcId" int))
307
-
308
-
let start_diagnostic_grammar =
309
-
map
310
-
(function
311
-
| 0 -> Unable_to_comply
312
-
| 1 -> Invalid_start_time
313
-
| 2 -> Invalid_stop_time
314
-
| 3 -> Missing_time_value
315
-
| 4 -> Invalid_gvcid
316
-
| 5 -> Out_of_service_start
317
-
| 100 -> Duplicate_invoke_id_start
318
-
| n -> Unknown_start_diagnostic n)
319
-
(function
320
-
| Unable_to_comply -> 0
321
-
| Invalid_start_time -> 1
322
-
| Invalid_stop_time -> 2
323
-
| Missing_time_value -> 3
324
-
| Invalid_gvcid -> 4
325
-
| Out_of_service_start -> 5
326
-
| Duplicate_invoke_id_start -> 100
327
-
| Unknown_start_diagnostic n -> n)
328
-
int
329
-
330
-
let start_result_grammar =
331
-
map
332
-
(function `C1 () -> Positive | `C2 d -> Negative d)
333
-
(function Positive -> `C1 () | Negative d -> `C2 d)
334
-
(choice2 (implicit 0 null) (implicit 1 start_diagnostic_grammar))
335
-
336
-
(* RCF start invocation includes GVCID - simplified encoding for now *)
337
-
let start_invocation_grammar =
338
-
sequence4
339
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
340
-
(required ~label:"invokeId" int)
341
-
(required ~label:"startTime" Common.conditional_time_grammar)
342
-
(required ~label:"stopTime" Common.conditional_time_grammar)
343
-
344
-
let start_return_grammar =
345
-
sequence3
346
-
(required ~label:"performerCredentials" Common.credentials_grammar)
347
-
(required ~label:"invokeId" int)
348
-
(required ~label:"result" start_result_grammar)
349
-
350
-
let stop_invocation_grammar =
351
-
sequence2
352
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
353
-
(required ~label:"invokeId" int)
354
-
355
-
let stop_diagnostic_grammar =
356
-
map
357
-
(function
358
-
| 100 -> Duplicate_invoke_id_stop | n -> Unknown_stop_diagnostic n)
359
-
(function
360
-
| Duplicate_invoke_id_stop -> 100 | Unknown_stop_diagnostic n -> n)
361
-
int
362
-
363
-
let stop_result_grammar =
364
-
map
365
-
(function `C1 () -> Stop_positive | `C2 d -> Stop_negative d)
366
-
(function Stop_positive -> `C1 () | Stop_negative d -> `C2 d)
367
-
(choice2 (implicit 0 null) (implicit 1 stop_diagnostic_grammar))
368
-
369
-
let stop_return_grammar =
370
-
sequence3
371
-
(required ~label:"performerCredentials" Common.credentials_grammar)
372
-
(required ~label:"invokeId" int)
373
-
(required ~label:"result" stop_result_grammar)
374
-
375
-
(* Transfer data includes GVCID *)
376
-
let transfer_data_grammar =
377
-
sequence5
378
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
379
-
(required ~label:"dataLinkContinuity" int)
380
-
(required ~label:"frameQuality" frame_quality_grammar)
381
-
(required ~label:"gvcid" gvcid_grammar)
382
-
(required ~label:"data" octet_string)
383
-
384
-
(* {2 GET-PARAMETER Grammars} *)
385
-
386
-
let parameter_name_grammar =
387
-
map
388
-
(function
389
-
| 4 -> Buffer_size
390
-
| 6 -> Delivery_mode
391
-
| 7 -> Latency_limit
392
-
| 26 -> Reporting_cycle
393
-
| 28 -> Requested_gvcid
394
-
| 29 -> Return_timeout_period
395
-
| 202 -> Transfer_buffer_size
396
-
| 303 -> Permitted_gvcid_set
397
-
| 304 -> Minimum_reporting_cycle
398
-
| n -> Unknown_parameter n)
399
-
(function
400
-
| Buffer_size -> 4
401
-
| Delivery_mode -> 6
402
-
| Latency_limit -> 7
403
-
| Reporting_cycle -> 26
404
-
| Requested_gvcid -> 28
405
-
| Return_timeout_period -> 29
406
-
| Transfer_buffer_size -> 202
407
-
| Permitted_gvcid_set -> 303
408
-
| Minimum_reporting_cycle -> 304
409
-
| Unknown_parameter n -> n)
410
-
int
411
-
412
-
let _get_parameter_diagnostic_grammar =
413
-
map
414
-
(function
415
-
| 0 -> Unknown_parameter_diagnostic
416
-
| 100 -> Gp_duplicate_invoke_id
417
-
| 101 -> Gp_operation_not_supported
418
-
| n -> Gp_unknown_diagnostic n)
419
-
(function
420
-
| Unknown_parameter_diagnostic -> 0
421
-
| Gp_duplicate_invoke_id -> 100
422
-
| Gp_operation_not_supported -> 101
423
-
| Gp_unknown_diagnostic n -> n)
424
-
int
425
-
426
-
let get_parameter_invocation_grammar =
427
-
sequence3
428
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
429
-
(required ~label:"invokeId" int)
430
-
(required ~label:"rcfParameter" parameter_name_grammar)
431
-
432
-
(* {2 SCHEDULE-STATUS-REPORT Grammars} *)
433
-
434
-
let schedule_status_report_diagnostic_grammar =
435
-
map
436
-
(function
437
-
| 0 -> Invalid_reporting_cycle
438
-
| 100 -> Ssr_duplicate_invoke_id
439
-
| 1 -> Already_stopped
440
-
| n -> Ssr_unknown_diagnostic n)
441
-
(function
442
-
| Invalid_reporting_cycle -> 0
443
-
| Ssr_duplicate_invoke_id -> 100
444
-
| Already_stopped -> 1
445
-
| Ssr_unknown_diagnostic n -> n)
446
-
int
447
-
448
-
let schedule_status_report_invocation_grammar =
449
-
sequence3
450
-
(required ~label:"invokerCredentials" Common.credentials_grammar)
451
-
(required ~label:"invokeId" int)
452
-
(required ~label:"reportingCycle" (implicit 0 int))
453
-
454
-
let schedule_status_report_result_grammar =
455
-
map
456
-
(function `C1 () -> Ok () | `C2 d -> Error d)
457
-
(function Ok () -> `C1 () | Error d -> `C2 d)
458
-
(choice2 (implicit 0 null)
459
-
(implicit 1 schedule_status_report_diagnostic_grammar))
460
-
461
-
let schedule_status_report_return_grammar =
462
-
sequence3
463
-
(required ~label:"performerCredentials" Common.credentials_grammar)
464
-
(required ~label:"invokeId" int)
465
-
(required ~label:"result" schedule_status_report_result_grammar)
466
-
467
-
let status_report_grammar =
468
-
sequence6
469
-
(required ~label:"numFramesDelivered" int)
470
-
(required ~label:"frameSyncLockStatus" lock_status_grammar)
471
-
(required ~label:"carrierLockStatus" lock_status_grammar)
472
-
(required ~label:"subcarrierLockStatus" lock_status_grammar)
473
-
(required ~label:"symbolSyncLockStatus" lock_status_grammar)
474
-
(required ~label:"productionStatus" production_status_grammar)
475
-
476
-
(* {1 Encoding} *)
477
-
478
-
let encode_start_invocation (inv : start_invocation) =
479
-
let codec = Asn.codec Asn.ber start_invocation_grammar in
480
-
let s =
481
-
Asn.encode codec
482
-
(inv.invoker_credentials, inv.invoke_id, inv.start_time, inv.stop_time)
483
-
in
484
-
Bytes.of_string s
485
-
486
-
let encode_stop_invocation (inv : stop_invocation) =
487
-
let codec = Asn.codec Asn.ber stop_invocation_grammar in
488
-
let s = Asn.encode codec (inv.invoker_credentials, inv.invoke_id) in
489
-
Bytes.of_string s
490
-
491
-
let encode_get_parameter_invocation (inv : get_parameter_invocation) =
492
-
let codec = Asn.codec Asn.ber get_parameter_invocation_grammar in
493
-
let s =
494
-
Asn.encode codec
495
-
(inv.gp_invoker_credentials, inv.gp_invoke_id, inv.gp_parameter_name)
496
-
in
497
-
Bytes.of_string s
498
-
499
-
let encode_schedule_status_report_invocation
500
-
(inv : schedule_status_report_invocation) =
501
-
let codec = Asn.codec Asn.ber schedule_status_report_invocation_grammar in
502
-
let cycle = Option.value inv.ssr_reporting_cycle ~default:0 in
503
-
let s =
504
-
Asn.encode codec (inv.ssr_invoker_credentials, inv.ssr_invoke_id, cycle)
505
-
in
506
-
Bytes.of_string s
507
-
508
-
(* {1 Decoding} *)
509
-
510
-
let decode_start_return buf : (start_return, error) result =
511
-
let codec = Asn.codec Asn.ber start_return_grammar in
512
-
match Asn.decode codec (Bytes.to_string buf) with
513
-
| Ok ((cred, id, result), _) ->
514
-
Ok { performer_credentials = cred; invoke_id = id; result }
515
-
| Error _ -> Error (Decode_error "start return")
516
-
517
-
let decode_stop_return buf : (stop_return, error) result =
518
-
let codec = Asn.codec Asn.ber stop_return_grammar in
519
-
match Asn.decode codec (Bytes.to_string buf) with
520
-
| Ok ((cred, id, result), _) ->
521
-
Ok { performer_credentials = cred; invoke_id = id; result }
522
-
| Error _ -> Error (Decode_error "stop return")
523
-
524
-
let decode_transfer_data buf =
525
-
let codec = Asn.codec Asn.ber transfer_data_grammar in
526
-
match Asn.decode codec (Bytes.to_string buf) with
527
-
| Ok ((cred, continuity, quality, gvcid, data), _) ->
528
-
Ok
529
-
{
530
-
invoker_credentials = cred;
531
-
earth_receive_time = None;
532
-
antenna_id = None;
533
-
data_link_continuity = continuity;
534
-
frame_quality = quality;
535
-
gvcid;
536
-
data = Bytes.of_string data;
537
-
}
538
-
| Error _ -> Error (Decode_error "transfer data")
539
-
540
-
let decode_schedule_status_report_return buf :
541
-
(schedule_status_report_return, error) result =
542
-
let codec = Asn.codec Asn.ber schedule_status_report_return_grammar in
543
-
match Asn.decode codec (Bytes.to_string buf) with
544
-
| Ok ((cred, id, result), _) ->
545
-
Ok
546
-
{
547
-
ssr_performer_credentials = cred;
548
-
ssr_invoke_id = id;
549
-
ssr_result = result;
550
-
}
551
-
| Error _ -> Error (Decode_error "schedule status report return")
552
-
553
-
let decode_status_report buf : (status_report, error) result =
554
-
let codec = Asn.codec Asn.ber status_report_grammar in
555
-
match Asn.decode codec (Bytes.to_string buf) with
556
-
| Ok ((frames, frame_sync, carrier, subcarrier, symbol, prod), _) ->
557
-
Ok
558
-
{
559
-
sr_num_frames_delivered = frames;
560
-
sr_frame_sync_lock_status = frame_sync;
561
-
sr_carrier_lock_status = carrier;
562
-
sr_subcarrier_lock_status = subcarrier;
563
-
sr_symbol_sync_lock_status = symbol;
564
-
sr_production_status = prod;
565
-
}
566
-
| Error _ -> Error (Decode_error "status report")
567
-
568
-
(* {1 State Machine} *)
569
-
570
-
let initial = Ready
571
-
572
-
let step state input =
573
-
match (state, input) with
574
-
| Ready, Initiate_start inv ->
575
-
let pdu = encode_start_invocation inv in
576
-
Ok (Ready, [ Send pdu ])
577
-
(* Stay Ready until response *)
578
-
| Ready, Start_response ret -> (
579
-
match ret.result with
580
-
| Positive -> Ok (Active, [ Started ])
581
-
| Negative diag -> Ok (Ready, [ Start_failed diag ]))
582
-
| Active, Transfer_data_received td ->
583
-
let frame =
584
-
Frame
585
-
{
586
-
earth_receive_time = td.earth_receive_time;
587
-
antenna_id = td.antenna_id;
588
-
data_link_continuity = td.data_link_continuity;
589
-
carrier_lock_status = Unknown;
590
-
subcarrier_lock_status = Unknown;
591
-
symbol_sync_lock_status = Unknown;
592
-
quality = td.frame_quality;
593
-
gvcid = td.gvcid;
594
-
data = td.data;
595
-
}
596
-
in
597
-
Ok (Active, [ Frame_received frame ])
598
-
| Active, Sync_notification notif -> Ok (Active, [ Frame_received notif ])
599
-
| Active, Initiate_get_parameter inv ->
600
-
let pdu = encode_get_parameter_invocation inv in
601
-
Ok (Active, [ Send pdu ])
602
-
| Active, Get_parameter_response ret -> Ok (Active, [ Parameter_value ret ])
603
-
| Active, Initiate_schedule_status_report inv ->
604
-
let pdu = encode_schedule_status_report_invocation inv in
605
-
Ok (Active, [ Send pdu ])
606
-
| Active, Schedule_status_report_response ret -> (
607
-
match ret.ssr_result with
608
-
| Ok () ->
609
-
if ret.ssr_invoke_id = 0 then Ok (Active, [ Status_report_stopped ])
610
-
else Ok (Active, [ Status_report_scheduled ])
611
-
| Error diag -> Ok (Active, [ Status_report_failed diag ]))
612
-
| Active, Status_report_received report ->
613
-
Ok (Active, [ Status_report report ])
614
-
| Active, Initiate_stop inv ->
615
-
let pdu = encode_stop_invocation inv in
616
-
Ok (Stopping, [ Send pdu ])
617
-
| Stopping, Stop_response ret -> (
618
-
match ret.result with
619
-
| Stop_positive -> Ok (Ready, [ Stopped ])
620
-
| Stop_negative _ -> Ok (Ready, [ Stopped ]) (* Stop anyway *))
621
-
| _, _ ->
622
-
Error
623
-
(Invalid_state
624
-
{
625
-
current = state;
626
-
operation =
627
-
(match input with
628
-
| Initiate_start _ -> "start"
629
-
| Start_response _ -> "start_response"
630
-
| Initiate_stop _ -> "stop"
631
-
| Stop_response _ -> "stop_response"
632
-
| Transfer_data_received _ -> "transfer_data"
633
-
| Sync_notification _ -> "sync_notify"
634
-
| Initiate_get_parameter _ -> "get_parameter"
635
-
| Get_parameter_response _ -> "get_parameter_response"
636
-
| Initiate_schedule_status_report _ -> "schedule_status_report"
637
-
| Schedule_status_report_response _ ->
638
-
"schedule_status_report_response"
639
-
| Status_report_received _ -> "status_report");
640
-
})
641
-
642
-
(* {1 Pretty-printers} *)
643
-
644
-
let pp_state ppf = function
645
-
| Ready -> Fmt.string ppf "Ready"
646
-
| Active -> Fmt.string ppf "Active"
647
-
| Stopping -> Fmt.string ppf "Stopping"
648
-
649
-
let pp_frame_quality ppf = function
650
-
| Good -> Fmt.string ppf "good"
651
-
| Erred -> Fmt.string ppf "erred"
652
-
| Undetermined -> Fmt.string ppf "undetermined"
653
-
| Unknown_frame_quality n -> Fmt.pf ppf "unknown(%d)" n
654
-
655
-
let pp_lock_status ppf = function
656
-
| In_lock -> Fmt.string ppf "in-lock"
657
-
| Out_of_lock -> Fmt.string ppf "out-of-lock"
658
-
| Not_in_use -> Fmt.string ppf "not-in-use"
659
-
| Unknown -> Fmt.string ppf "unknown"
660
-
| Unknown_lock_status n -> Fmt.pf ppf "unknown(%d)" n
661
-
662
-
let pp_production_status ppf = function
663
-
| Running -> Fmt.string ppf "running"
664
-
| Interrupted -> Fmt.string ppf "interrupted"
665
-
| Halted -> Fmt.string ppf "halted"
666
-
| Unknown_production_status n -> Fmt.pf ppf "unknown(%d)" n
667
-
668
-
let pp_gvcid ppf g =
669
-
match g.vcid with
670
-
| None -> Fmt.pf ppf "{ scid=%d; ver=%d; MC }" g.spacecraft_id g.version
671
-
| Some vcid ->
672
-
Fmt.pf ppf "{ scid=%d; ver=%d; vcid=%d }" g.spacecraft_id g.version vcid
673
-
674
-
let pp_start_diagnostic ppf = function
675
-
| Unable_to_comply -> Fmt.string ppf "unable-to-comply"
676
-
| Invalid_start_time -> Fmt.string ppf "invalid-start-time"
677
-
| Invalid_stop_time -> Fmt.string ppf "invalid-stop-time"
678
-
| Missing_time_value -> Fmt.string ppf "missing-time-value"
679
-
| Invalid_gvcid -> Fmt.string ppf "invalid-gvcid"
680
-
| Out_of_service_start -> Fmt.string ppf "out-of-service"
681
-
| Duplicate_invoke_id_start -> Fmt.string ppf "duplicate-invoke-id"
682
-
| Unknown_start_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
683
-
684
-
let pp_stop_diagnostic ppf = function
685
-
| Duplicate_invoke_id_stop -> Fmt.string ppf "duplicate-invoke-id"
686
-
| Unknown_stop_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
687
-
688
-
let pp_parameter_name ppf = function
689
-
| Buffer_size -> Fmt.string ppf "buffer-size"
690
-
| Delivery_mode -> Fmt.string ppf "delivery-mode"
691
-
| Latency_limit -> Fmt.string ppf "latency-limit"
692
-
| Reporting_cycle -> Fmt.string ppf "reporting-cycle"
693
-
| Requested_gvcid -> Fmt.string ppf "requested-gvcid"
694
-
| Return_timeout_period -> Fmt.string ppf "return-timeout-period"
695
-
| Transfer_buffer_size -> Fmt.string ppf "transfer-buffer-size"
696
-
| Permitted_gvcid_set -> Fmt.string ppf "permitted-gvcid-set"
697
-
| Minimum_reporting_cycle -> Fmt.string ppf "minimum-reporting-cycle"
698
-
| Unknown_parameter n -> Fmt.pf ppf "unknown(%d)" n
699
-
700
-
let pp_get_parameter_diagnostic ppf = function
701
-
| Unknown_parameter_diagnostic -> Fmt.string ppf "unknown-parameter"
702
-
| Gp_duplicate_invoke_id -> Fmt.string ppf "duplicate-invoke-id"
703
-
| Gp_operation_not_supported -> Fmt.string ppf "operation-not-supported"
704
-
| Gp_unknown_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
705
-
706
-
let pp_schedule_status_report_diagnostic ppf = function
707
-
| Invalid_reporting_cycle -> Fmt.string ppf "invalid-reporting-cycle"
708
-
| Ssr_duplicate_invoke_id -> Fmt.string ppf "duplicate-invoke-id"
709
-
| Already_stopped -> Fmt.string ppf "already-stopped"
710
-
| Ssr_unknown_diagnostic n -> Fmt.pf ppf "unknown(%d)" n
711
-
712
-
let pp_status_report ppf sr =
713
-
Fmt.pf ppf
714
-
"{ frames=%d; frame_sync=%a; carrier=%a; subcarrier=%a; symbol=%a; prod=%a \
715
-
}"
716
-
sr.sr_num_frames_delivered pp_lock_status sr.sr_frame_sync_lock_status
717
-
pp_lock_status sr.sr_carrier_lock_status pp_lock_status
718
-
sr.sr_subcarrier_lock_status pp_lock_status sr.sr_symbol_sync_lock_status
719
-
pp_production_status sr.sr_production_status
720
-
721
-
let pp_error ppf = function
722
-
| Invalid_state { current; operation } ->
723
-
Fmt.pf ppf "invalid state %a for operation %s" pp_state current operation
724
-
| Decode_error s -> Fmt.pf ppf "decode error: %s" s
-283
lib/sle/rcf.mli
-283
lib/sle/rcf.mli
···
1
-
(** RCF - Return Channel Frames Service (CCSDS 911.2-B-3).
2
-
3
-
Pure module - no I/O effects. Implements the RCF service state machine and
4
-
PDU encoding/decoding.
5
-
6
-
RCF provides TM frame delivery from ground station to user, filtered by
7
-
Global Virtual Channel Identifier (GVCID). This differs from RAF which
8
-
delivers all frames.
9
-
10
-
Key difference from RAF:
11
-
- RCF start invocation includes a requested GVCID list for filtering
12
-
- Frames include GVCID metadata
13
-
14
-
Service lifecycle:
15
-
{v
16
-
[Ready] --start--> [Active] --stop--> [Ready]
17
-
18
-
In Active state:
19
-
- Provider sends TRANSFER-DATA notifications (filtered by GVCID)
20
-
- Provider sends SYNC-NOTIFY on frame sync changes
21
-
- User can request GET-PARAMETER, SCHEDULE-STATUS-REPORT
22
-
v} *)
23
-
24
-
(** {1 Types} *)
25
-
26
-
type frame_quality =
27
-
| Good
28
-
| Erred
29
-
| Undetermined
30
-
| Unknown_frame_quality of int
31
-
32
-
type production_status =
33
-
| Running
34
-
| Interrupted
35
-
| Halted
36
-
| Unknown_production_status of int
37
-
38
-
type lock_status =
39
-
| In_lock
40
-
| Out_of_lock
41
-
| Not_in_use
42
-
| Unknown
43
-
| Unknown_lock_status of int
44
-
45
-
type gvcid = {
46
-
spacecraft_id : int; (** 10-bit spacecraft ID *)
47
-
version : int; (** 2-bit version number *)
48
-
vcid : int option; (** None = master channel, Some n = specific VC (0-63) *)
49
-
}
50
-
(** Global Virtual Channel Identifier - uniquely identifies a virtual channel *)
51
-
52
-
(** Requested GVCID filtering *)
53
-
type requested_gvcid =
54
-
| Gvcid_list of gvcid list (** Filter by specific GVCIDs *)
55
-
| Undefined (** All GVCIDs - no filtering *)
56
-
57
-
(** RCF transfer buffer entry *)
58
-
type frame_or_notification =
59
-
| Frame of {
60
-
earth_receive_time : Common.time option;
61
-
antenna_id : string option;
62
-
data_link_continuity : int;
63
-
carrier_lock_status : lock_status;
64
-
subcarrier_lock_status : lock_status;
65
-
symbol_sync_lock_status : lock_status;
66
-
quality : frame_quality;
67
-
gvcid : gvcid;
68
-
data : bytes;
69
-
}
70
-
| Sync_notify of {
71
-
time : Common.time option;
72
-
carrier_lock : lock_status;
73
-
subcarrier_lock : lock_status;
74
-
symbol_sync_lock : lock_status;
75
-
production_status : production_status;
76
-
}
77
-
78
-
(** {1 Service Operations} *)
79
-
80
-
type start_invocation = {
81
-
invoker_credentials : Common.credentials;
82
-
invoke_id : int;
83
-
start_time : Common.conditional_time;
84
-
stop_time : Common.conditional_time;
85
-
requested_gvcid : requested_gvcid;
86
-
requested_quality : Common.requested_frame_quality;
87
-
}
88
-
89
-
type start_result = Positive | Negative of start_diagnostic
90
-
91
-
and start_diagnostic =
92
-
| Unable_to_comply
93
-
| Invalid_start_time
94
-
| Invalid_stop_time
95
-
| Missing_time_value
96
-
| Invalid_gvcid
97
-
| Out_of_service_start
98
-
| Duplicate_invoke_id_start
99
-
| Unknown_start_diagnostic of int
100
-
101
-
type start_return = {
102
-
performer_credentials : Common.credentials;
103
-
invoke_id : int;
104
-
result : start_result;
105
-
}
106
-
107
-
type stop_invocation = {
108
-
invoker_credentials : Common.credentials;
109
-
invoke_id : int;
110
-
}
111
-
112
-
type stop_result = Stop_positive | Stop_negative of stop_diagnostic
113
-
114
-
and stop_diagnostic =
115
-
| Duplicate_invoke_id_stop
116
-
| Unknown_stop_diagnostic of int
117
-
118
-
type stop_return = {
119
-
performer_credentials : Common.credentials;
120
-
invoke_id : int;
121
-
result : stop_result;
122
-
}
123
-
124
-
type transfer_data = {
125
-
invoker_credentials : Common.credentials;
126
-
earth_receive_time : Common.time option;
127
-
antenna_id : string option;
128
-
data_link_continuity : int;
129
-
frame_quality : frame_quality;
130
-
gvcid : gvcid;
131
-
data : bytes;
132
-
}
133
-
134
-
(** {1 GET-PARAMETER Operation} *)
135
-
136
-
type parameter_name =
137
-
| Buffer_size
138
-
| Delivery_mode
139
-
| Latency_limit
140
-
| Reporting_cycle
141
-
| Requested_gvcid
142
-
| Return_timeout_period
143
-
| Transfer_buffer_size
144
-
| Permitted_gvcid_set
145
-
| Minimum_reporting_cycle
146
-
| Unknown_parameter of int
147
-
148
-
type parameter_value =
149
-
| Pv_buffer_size of int
150
-
| Pv_delivery_mode of Common.delivery_mode
151
-
| Pv_latency_limit of int option
152
-
| Pv_reporting_cycle of int option
153
-
| Pv_requested_gvcid of requested_gvcid
154
-
| Pv_return_timeout_period of int
155
-
| Pv_transfer_buffer_size of int
156
-
| Pv_permitted_gvcid_set of gvcid list
157
-
| Pv_minimum_reporting_cycle of int option
158
-
159
-
type get_parameter_diagnostic =
160
-
| Unknown_parameter_diagnostic
161
-
| Gp_duplicate_invoke_id
162
-
| Gp_operation_not_supported
163
-
| Gp_unknown_diagnostic of int
164
-
165
-
type get_parameter_invocation = {
166
-
gp_invoker_credentials : Common.credentials;
167
-
gp_invoke_id : int;
168
-
gp_parameter_name : parameter_name;
169
-
}
170
-
171
-
type get_parameter_return = {
172
-
gp_performer_credentials : Common.credentials;
173
-
gp_invoke_id : int;
174
-
gp_result : (parameter_value, get_parameter_diagnostic) result;
175
-
}
176
-
177
-
(** {1 SCHEDULE-STATUS-REPORT Operation} *)
178
-
179
-
type status_report = {
180
-
sr_num_frames_delivered : int;
181
-
sr_frame_sync_lock_status : lock_status;
182
-
sr_carrier_lock_status : lock_status;
183
-
sr_subcarrier_lock_status : lock_status;
184
-
sr_symbol_sync_lock_status : lock_status;
185
-
sr_production_status : production_status;
186
-
}
187
-
188
-
type schedule_status_report_diagnostic =
189
-
| Invalid_reporting_cycle
190
-
| Ssr_duplicate_invoke_id
191
-
| Already_stopped
192
-
| Ssr_unknown_diagnostic of int
193
-
194
-
type schedule_status_report_invocation = {
195
-
ssr_invoker_credentials : Common.credentials;
196
-
ssr_invoke_id : int;
197
-
ssr_reporting_cycle : int option;
198
-
}
199
-
200
-
type schedule_status_report_return = {
201
-
ssr_performer_credentials : Common.credentials;
202
-
ssr_invoke_id : int;
203
-
ssr_result : (unit, schedule_status_report_diagnostic) result;
204
-
}
205
-
206
-
(** {1 Service State Machine} *)
207
-
208
-
type state = Ready | Active | Stopping
209
-
210
-
type output =
211
-
| Send of bytes
212
-
| Frame_received of frame_or_notification
213
-
| Started
214
-
| Start_failed of start_diagnostic
215
-
| Stopped
216
-
| Parameter_value of get_parameter_return
217
-
| Status_report_scheduled
218
-
| Status_report_stopped
219
-
| Status_report_failed of schedule_status_report_diagnostic
220
-
| Status_report of status_report
221
-
222
-
type input =
223
-
| Initiate_start of start_invocation
224
-
| Start_response of start_return
225
-
| Initiate_stop of stop_invocation
226
-
| Stop_response of stop_return
227
-
| Transfer_data_received of transfer_data
228
-
| Sync_notification of frame_or_notification
229
-
| Initiate_get_parameter of get_parameter_invocation
230
-
| Get_parameter_response of get_parameter_return
231
-
| Initiate_schedule_status_report of schedule_status_report_invocation
232
-
| Schedule_status_report_response of schedule_status_report_return
233
-
| Status_report_received of status_report
234
-
235
-
type error =
236
-
| Invalid_state of { current : state; operation : string }
237
-
| Decode_error of string
238
-
239
-
(** {1 State Machine} *)
240
-
241
-
val initial : state
242
-
(** Initial RCF state (Ready). *)
243
-
244
-
val step : state -> input -> (state * output list, error) result
245
-
(** [step state input] processes an input and returns new state with outputs. *)
246
-
247
-
(** {1 Encoding} *)
248
-
249
-
val encode_start_invocation : start_invocation -> bytes
250
-
val encode_stop_invocation : stop_invocation -> bytes
251
-
val encode_get_parameter_invocation : get_parameter_invocation -> bytes
252
-
253
-
val encode_schedule_status_report_invocation :
254
-
schedule_status_report_invocation -> bytes
255
-
256
-
(** {1 Decoding} *)
257
-
258
-
val decode_start_return : bytes -> (start_return, error) result
259
-
val decode_stop_return : bytes -> (stop_return, error) result
260
-
val decode_transfer_data : bytes -> (transfer_data, error) result
261
-
262
-
val decode_schedule_status_report_return :
263
-
bytes -> (schedule_status_report_return, error) result
264
-
265
-
val decode_status_report : bytes -> (status_report, error) result
266
-
267
-
(** {1 Pretty-printers} *)
268
-
269
-
val pp_state : state Fmt.t
270
-
val pp_frame_quality : frame_quality Fmt.t
271
-
val pp_lock_status : lock_status Fmt.t
272
-
val pp_production_status : production_status Fmt.t
273
-
val pp_gvcid : gvcid Fmt.t
274
-
val pp_start_diagnostic : start_diagnostic Fmt.t
275
-
val pp_stop_diagnostic : stop_diagnostic Fmt.t
276
-
val pp_parameter_name : parameter_name Fmt.t
277
-
val pp_get_parameter_diagnostic : get_parameter_diagnostic Fmt.t
278
-
279
-
val pp_schedule_status_report_diagnostic :
280
-
schedule_status_report_diagnostic Fmt.t
281
-
282
-
val pp_status_report : status_report Fmt.t
283
-
val pp_error : error Fmt.t
-392
lib/sle/sle.ml
-392
lib/sle/sle.ml
···
1
-
(** SLE - Space Link Extension (CCSDS 913.1-B-2).
2
-
3
-
Pure core implementation of SLE protocols. No I/O effects - all operations
4
-
are state machines that take bytes in and produce bytes + state changes out.
5
-
6
-
Use {!Sle_eio} for the effectful shell that handles TCP connections. *)
7
-
8
-
module Common = Common
9
-
module Tml = Tml
10
-
module Isp1 = Isp1
11
-
module Bind = Bind
12
-
module Raf = Raf
13
-
module Rcf = Rcf
14
-
module Fcltu = Fcltu
15
-
16
-
(* {1 Unified RAF Session State} *)
17
-
18
-
type raf_state = { bind : Bind.state; raf : Raf.state; version : int }
19
-
(** Combined state for a complete RAF session (bind + service). *)
20
-
21
-
(** Session output. *)
22
-
type raf_output =
23
-
| Send_pdu of bytes (** BER-encoded PDU to send via TML *)
24
-
| Bound of int (** Session bound with version *)
25
-
| Bind_failed of Bind.bind_diagnostic
26
-
| Frame of Raf.frame_or_notification (** TM frame received *)
27
-
| Started (** Data delivery started *)
28
-
| Start_failed of Raf.start_diagnostic
29
-
| Stopped (** Data delivery stopped *)
30
-
| Parameter_value of Raf.get_parameter_return
31
-
| Status_report_scheduled
32
-
| Status_report_stopped
33
-
| Status_report_failed of Raf.schedule_status_report_diagnostic
34
-
| Status_report of Raf.status_report
35
-
| Unbound (** Session terminated *)
36
-
| Aborted of Bind.peer_abort_diagnostic
37
-
38
-
(** Session input. *)
39
-
type raf_input =
40
-
| Bind of Bind.bind_invocation
41
-
| Bind_return of bytes (** Raw PDU bytes *)
42
-
| Start of Raf.start_invocation
43
-
| Start_return of bytes
44
-
| Stop of Raf.stop_invocation
45
-
| Stop_return of bytes
46
-
| Transfer_data of bytes
47
-
| Get_parameter of Raf.get_parameter_invocation
48
-
| Get_parameter_return of bytes
49
-
| Schedule_status_report of Raf.schedule_status_report_invocation
50
-
| Schedule_status_report_return of bytes
51
-
| Status_report of bytes
52
-
| Unbind of Bind.unbind_invocation
53
-
| Unbind_return of bytes
54
-
| Peer_abort of bytes
55
-
56
-
type raf_error =
57
-
| Bind_error of Bind.error
58
-
| Raf_error of Raf.error
59
-
| Decode_error of string
60
-
61
-
(** Initial session state. *)
62
-
let raf_initial = { bind = Bind.initial; raf = Raf.initial; version = 2 }
63
-
64
-
(* Map RAF outputs to session outputs *)
65
-
let map_raf_output = function
66
-
| Raf.Send pdu -> Send_pdu pdu
67
-
| Raf.Frame_received f -> Frame f
68
-
| Raf.Started -> Started
69
-
| Raf.Start_failed d -> Start_failed d
70
-
| Raf.Stopped -> Stopped
71
-
| Raf.Parameter_value ret -> Parameter_value ret
72
-
| Raf.Status_report_scheduled -> Status_report_scheduled
73
-
| Raf.Status_report_stopped -> Status_report_stopped
74
-
| Raf.Status_report_failed d -> Status_report_failed d
75
-
| Raf.Status_report sr -> Status_report sr
76
-
77
-
(* Map Bind outputs to session outputs *)
78
-
let map_bind_output = function
79
-
| Bind.Send pdu -> Send_pdu pdu
80
-
| Bind.Bound_ok v -> Bound v
81
-
| Bind.Bound_failed d -> Bind_failed d
82
-
| Bind.Unbound_ok -> Unbound
83
-
| Bind.Aborted d -> Aborted d
84
-
85
-
(** Process session input, return new state and outputs. *)
86
-
let raf_step state input =
87
-
match input with
88
-
| Bind inv -> (
89
-
match Bind.step state.bind (Initiate_bind inv) with
90
-
| Ok (bind', outputs) ->
91
-
Ok ({ state with bind = bind' }, List.map map_bind_output outputs)
92
-
| Error e -> Error (Bind_error e))
93
-
| Bind_return pdu -> (
94
-
match Bind.decode_bind_return pdu with
95
-
| Ok ret -> (
96
-
match Bind.step state.bind (Bind_response ret) with
97
-
| Ok (bind', outputs) ->
98
-
let version =
99
-
match ret.result with Ok v -> v | Error _ -> state.version
100
-
in
101
-
Ok
102
-
( { state with bind = bind'; version },
103
-
List.map map_bind_output outputs )
104
-
| Error e -> Error (Bind_error e))
105
-
| Error e -> Error (Bind_error e))
106
-
| Start inv -> (
107
-
match Raf.step state.raf (Initiate_start inv) with
108
-
| Ok (raf', outputs) ->
109
-
Ok ({ state with raf = raf' }, List.map map_raf_output outputs)
110
-
| Error e -> Error (Raf_error e))
111
-
| Start_return pdu -> (
112
-
match Raf.decode_start_return pdu with
113
-
| Ok ret -> (
114
-
match Raf.step state.raf (Start_response ret) with
115
-
| Ok (raf', outputs) ->
116
-
Ok ({ state with raf = raf' }, List.map map_raf_output outputs)
117
-
| Error e -> Error (Raf_error e))
118
-
| Error e -> Error (Raf_error e))
119
-
| Transfer_data pdu -> (
120
-
match Raf.decode_transfer_data pdu with
121
-
| Ok td -> (
122
-
match Raf.step state.raf (Transfer_data_received td) with
123
-
| Ok (raf', outputs) ->
124
-
Ok ({ state with raf = raf' }, List.map map_raf_output outputs)
125
-
| Error e -> Error (Raf_error e))
126
-
| Error e -> Error (Raf_error e))
127
-
| Get_parameter inv -> (
128
-
match Raf.step state.raf (Initiate_get_parameter inv) with
129
-
| Ok (raf', outputs) ->
130
-
Ok ({ state with raf = raf' }, List.map map_raf_output outputs)
131
-
| Error e -> Error (Raf_error e))
132
-
| Get_parameter_return _pdu ->
133
-
(* GET-PARAMETER return decoding not yet implemented *)
134
-
Error (Decode_error "get_parameter_return decoding not implemented")
135
-
| Schedule_status_report inv -> (
136
-
match Raf.step state.raf (Initiate_schedule_status_report inv) with
137
-
| Ok (raf', outputs) ->
138
-
Ok ({ state with raf = raf' }, List.map map_raf_output outputs)
139
-
| Error e -> Error (Raf_error e))
140
-
| Schedule_status_report_return pdu -> (
141
-
match Raf.decode_schedule_status_report_return pdu with
142
-
| Ok ret -> (
143
-
match Raf.step state.raf (Schedule_status_report_response ret) with
144
-
| Ok (raf', outputs) ->
145
-
Ok ({ state with raf = raf' }, List.map map_raf_output outputs)
146
-
| Error e -> Error (Raf_error e))
147
-
| Error e -> Error (Raf_error e))
148
-
| Status_report pdu -> (
149
-
match Raf.decode_status_report pdu with
150
-
| Ok sr -> (
151
-
match Raf.step state.raf (Status_report_received sr) with
152
-
| Ok (raf', outputs) ->
153
-
Ok ({ state with raf = raf' }, List.map map_raf_output outputs)
154
-
| Error e -> Error (Raf_error e))
155
-
| Error e -> Error (Raf_error e))
156
-
| Stop inv -> (
157
-
match Raf.step state.raf (Initiate_stop inv) with
158
-
| Ok (raf', outputs) ->
159
-
Ok ({ state with raf = raf' }, List.map map_raf_output outputs)
160
-
| Error e -> Error (Raf_error e))
161
-
| Stop_return pdu -> (
162
-
match Raf.decode_stop_return pdu with
163
-
| Ok ret -> (
164
-
match Raf.step state.raf (Stop_response ret) with
165
-
| Ok (raf', outputs) ->
166
-
Ok ({ state with raf = raf' }, List.map map_raf_output outputs)
167
-
| Error e -> Error (Raf_error e))
168
-
| Error e -> Error (Raf_error e))
169
-
| Unbind inv -> (
170
-
match Bind.step state.bind (Initiate_unbind inv) with
171
-
| Ok (bind', outputs) ->
172
-
Ok ({ state with bind = bind' }, List.map map_bind_output outputs)
173
-
| Error e -> Error (Bind_error e))
174
-
| Unbind_return pdu -> (
175
-
match Bind.decode_unbind_return pdu with
176
-
| Ok ret -> (
177
-
match Bind.step state.bind (Unbind_response ret) with
178
-
| Ok (bind', outputs) ->
179
-
Ok ({ state with bind = bind' }, List.map map_bind_output outputs)
180
-
| Error e -> Error (Bind_error e))
181
-
| Error e -> Error (Bind_error e))
182
-
| Peer_abort pdu -> (
183
-
match Bind.decode_peer_abort pdu with
184
-
| Ok abort -> (
185
-
match Bind.step state.bind (Peer_abort_received abort) with
186
-
| Ok (bind', outputs) ->
187
-
Ok ({ state with bind = bind' }, List.map map_bind_output outputs)
188
-
| Error e -> Error (Bind_error e))
189
-
| Error e -> Error (Bind_error e))
190
-
191
-
(* {1 Pretty-printers} *)
192
-
193
-
let pp_raf_state ppf st =
194
-
Fmt.pf ppf "{ bind=%a; raf=%a; version=%d }" Bind.pp_state st.bind
195
-
Raf.pp_state st.raf st.version
196
-
197
-
let pp_raf_error ppf = function
198
-
| Bind_error e -> Fmt.pf ppf "bind: %a" Bind.pp_error e
199
-
| Raf_error e -> Fmt.pf ppf "raf: %a" Raf.pp_error e
200
-
| Decode_error s -> Fmt.pf ppf "decode: %s" s
201
-
202
-
(* {1 Unified RCF Session State} *)
203
-
204
-
type rcf_state = { rcf_bind : Bind.state; rcf : Rcf.state; rcf_version : int }
205
-
(** Combined state for a complete RCF session (bind + service). *)
206
-
207
-
(** RCF Session output. *)
208
-
type rcf_output =
209
-
| Rcf_send_pdu of bytes (** BER-encoded PDU to send via TML *)
210
-
| Rcf_bound of int (** Session bound with version *)
211
-
| Rcf_bind_failed of Bind.bind_diagnostic
212
-
| Rcf_frame of Rcf.frame_or_notification (** TM frame received *)
213
-
| Rcf_started (** Data delivery started *)
214
-
| Rcf_start_failed of Rcf.start_diagnostic
215
-
| Rcf_stopped (** Data delivery stopped *)
216
-
| Rcf_parameter_value of Rcf.get_parameter_return
217
-
| Rcf_status_report_scheduled
218
-
| Rcf_status_report_stopped
219
-
| Rcf_status_report_failed of Rcf.schedule_status_report_diagnostic
220
-
| Rcf_status_report of Rcf.status_report
221
-
| Rcf_unbound (** Session terminated *)
222
-
| Rcf_aborted of Bind.peer_abort_diagnostic
223
-
224
-
(** RCF Session input. *)
225
-
type rcf_input =
226
-
| Rcf_bind of Bind.bind_invocation
227
-
| Rcf_bind_return of bytes
228
-
| Rcf_start of Rcf.start_invocation
229
-
| Rcf_start_return of bytes
230
-
| Rcf_stop of Rcf.stop_invocation
231
-
| Rcf_stop_return of bytes
232
-
| Rcf_transfer_data of bytes
233
-
| Rcf_get_parameter of Rcf.get_parameter_invocation
234
-
| Rcf_get_parameter_return of bytes
235
-
| Rcf_schedule_status_report of Rcf.schedule_status_report_invocation
236
-
| Rcf_schedule_status_report_return of bytes
237
-
| Rcf_status_report of bytes
238
-
| Rcf_unbind of Bind.unbind_invocation
239
-
| Rcf_unbind_return of bytes
240
-
| Rcf_peer_abort of bytes
241
-
242
-
type rcf_error =
243
-
| Rcf_bind_error of Bind.error
244
-
| Rcf_rcf_error of Rcf.error
245
-
| Rcf_decode_error of string
246
-
247
-
(** Initial RCF session state. *)
248
-
let rcf_initial =
249
-
{ rcf_bind = Bind.initial; rcf = Rcf.initial; rcf_version = 2 }
250
-
251
-
(* Map RCF outputs to session outputs *)
252
-
let map_rcf_output = function
253
-
| Rcf.Send pdu -> Rcf_send_pdu pdu
254
-
| Rcf.Frame_received f -> Rcf_frame f
255
-
| Rcf.Started -> Rcf_started
256
-
| Rcf.Start_failed d -> Rcf_start_failed d
257
-
| Rcf.Stopped -> Rcf_stopped
258
-
| Rcf.Parameter_value ret -> Rcf_parameter_value ret
259
-
| Rcf.Status_report_scheduled -> Rcf_status_report_scheduled
260
-
| Rcf.Status_report_stopped -> Rcf_status_report_stopped
261
-
| Rcf.Status_report_failed d -> Rcf_status_report_failed d
262
-
| Rcf.Status_report sr -> Rcf_status_report sr
263
-
264
-
(* Map Bind outputs to RCF session outputs *)
265
-
let map_bind_to_rcf_output = function
266
-
| Bind.Send pdu -> Rcf_send_pdu pdu
267
-
| Bind.Bound_ok v -> Rcf_bound v
268
-
| Bind.Bound_failed d -> Rcf_bind_failed d
269
-
| Bind.Unbound_ok -> Rcf_unbound
270
-
| Bind.Aborted d -> Rcf_aborted d
271
-
272
-
(** Process RCF session input, return new state and outputs. *)
273
-
let rcf_step state input =
274
-
match input with
275
-
| Rcf_bind inv -> (
276
-
match Bind.step state.rcf_bind (Initiate_bind inv) with
277
-
| Ok (bind', outputs) ->
278
-
Ok
279
-
( { state with rcf_bind = bind' },
280
-
List.map map_bind_to_rcf_output outputs )
281
-
| Error e -> Error (Rcf_bind_error e))
282
-
| Rcf_bind_return pdu -> (
283
-
match Bind.decode_bind_return pdu with
284
-
| Ok ret -> (
285
-
match Bind.step state.rcf_bind (Bind_response ret) with
286
-
| Ok (bind', outputs) ->
287
-
let version =
288
-
match ret.result with Ok v -> v | Error _ -> state.rcf_version
289
-
in
290
-
Ok
291
-
( { state with rcf_bind = bind'; rcf_version = version },
292
-
List.map map_bind_to_rcf_output outputs )
293
-
| Error e -> Error (Rcf_bind_error e))
294
-
| Error e -> Error (Rcf_bind_error e))
295
-
| Rcf_start inv -> (
296
-
match Rcf.step state.rcf (Initiate_start inv) with
297
-
| Ok (rcf', outputs) ->
298
-
Ok ({ state with rcf = rcf' }, List.map map_rcf_output outputs)
299
-
| Error e -> Error (Rcf_rcf_error e))
300
-
| Rcf_start_return pdu -> (
301
-
match Rcf.decode_start_return pdu with
302
-
| Ok ret -> (
303
-
match Rcf.step state.rcf (Start_response ret) with
304
-
| Ok (rcf', outputs) ->
305
-
Ok ({ state with rcf = rcf' }, List.map map_rcf_output outputs)
306
-
| Error e -> Error (Rcf_rcf_error e))
307
-
| Error e -> Error (Rcf_rcf_error e))
308
-
| Rcf_transfer_data pdu -> (
309
-
match Rcf.decode_transfer_data pdu with
310
-
| Ok td -> (
311
-
match Rcf.step state.rcf (Transfer_data_received td) with
312
-
| Ok (rcf', outputs) ->
313
-
Ok ({ state with rcf = rcf' }, List.map map_rcf_output outputs)
314
-
| Error e -> Error (Rcf_rcf_error e))
315
-
| Error e -> Error (Rcf_rcf_error e))
316
-
| Rcf_get_parameter inv -> (
317
-
match Rcf.step state.rcf (Initiate_get_parameter inv) with
318
-
| Ok (rcf', outputs) ->
319
-
Ok ({ state with rcf = rcf' }, List.map map_rcf_output outputs)
320
-
| Error e -> Error (Rcf_rcf_error e))
321
-
| Rcf_get_parameter_return _pdu ->
322
-
Error (Rcf_decode_error "get_parameter_return decoding not implemented")
323
-
| Rcf_schedule_status_report inv -> (
324
-
match Rcf.step state.rcf (Initiate_schedule_status_report inv) with
325
-
| Ok (rcf', outputs) ->
326
-
Ok ({ state with rcf = rcf' }, List.map map_rcf_output outputs)
327
-
| Error e -> Error (Rcf_rcf_error e))
328
-
| Rcf_schedule_status_report_return pdu -> (
329
-
match Rcf.decode_schedule_status_report_return pdu with
330
-
| Ok ret -> (
331
-
match Rcf.step state.rcf (Schedule_status_report_response ret) with
332
-
| Ok (rcf', outputs) ->
333
-
Ok ({ state with rcf = rcf' }, List.map map_rcf_output outputs)
334
-
| Error e -> Error (Rcf_rcf_error e))
335
-
| Error e -> Error (Rcf_rcf_error e))
336
-
| Rcf_status_report pdu -> (
337
-
match Rcf.decode_status_report pdu with
338
-
| Ok sr -> (
339
-
match Rcf.step state.rcf (Status_report_received sr) with
340
-
| Ok (rcf', outputs) ->
341
-
Ok ({ state with rcf = rcf' }, List.map map_rcf_output outputs)
342
-
| Error e -> Error (Rcf_rcf_error e))
343
-
| Error e -> Error (Rcf_rcf_error e))
344
-
| Rcf_stop inv -> (
345
-
match Rcf.step state.rcf (Initiate_stop inv) with
346
-
| Ok (rcf', outputs) ->
347
-
Ok ({ state with rcf = rcf' }, List.map map_rcf_output outputs)
348
-
| Error e -> Error (Rcf_rcf_error e))
349
-
| Rcf_stop_return pdu -> (
350
-
match Rcf.decode_stop_return pdu with
351
-
| Ok ret -> (
352
-
match Rcf.step state.rcf (Stop_response ret) with
353
-
| Ok (rcf', outputs) ->
354
-
Ok ({ state with rcf = rcf' }, List.map map_rcf_output outputs)
355
-
| Error e -> Error (Rcf_rcf_error e))
356
-
| Error e -> Error (Rcf_rcf_error e))
357
-
| Rcf_unbind inv -> (
358
-
match Bind.step state.rcf_bind (Initiate_unbind inv) with
359
-
| Ok (bind', outputs) ->
360
-
Ok
361
-
( { state with rcf_bind = bind' },
362
-
List.map map_bind_to_rcf_output outputs )
363
-
| Error e -> Error (Rcf_bind_error e))
364
-
| Rcf_unbind_return pdu -> (
365
-
match Bind.decode_unbind_return pdu with
366
-
| Ok ret -> (
367
-
match Bind.step state.rcf_bind (Unbind_response ret) with
368
-
| Ok (bind', outputs) ->
369
-
Ok
370
-
( { state with rcf_bind = bind' },
371
-
List.map map_bind_to_rcf_output outputs )
372
-
| Error e -> Error (Rcf_bind_error e))
373
-
| Error e -> Error (Rcf_bind_error e))
374
-
| Rcf_peer_abort pdu -> (
375
-
match Bind.decode_peer_abort pdu with
376
-
| Ok abort -> (
377
-
match Bind.step state.rcf_bind (Peer_abort_received abort) with
378
-
| Ok (bind', outputs) ->
379
-
Ok
380
-
( { state with rcf_bind = bind' },
381
-
List.map map_bind_to_rcf_output outputs )
382
-
| Error e -> Error (Rcf_bind_error e))
383
-
| Error e -> Error (Rcf_bind_error e))
384
-
385
-
let pp_rcf_state ppf st =
386
-
Fmt.pf ppf "{ bind=%a; rcf=%a; version=%d }" Bind.pp_state st.rcf_bind
387
-
Rcf.pp_state st.rcf st.rcf_version
388
-
389
-
let pp_rcf_error ppf = function
390
-
| Rcf_bind_error e -> Fmt.pf ppf "bind: %a" Bind.pp_error e
391
-
| Rcf_rcf_error e -> Fmt.pf ppf "rcf: %a" Rcf.pp_error e
392
-
| Rcf_decode_error s -> Fmt.pf ppf "decode: %s" s
-152
lib/sle/sle.mli
-152
lib/sle/sle.mli
···
1
-
(** SLE - Space Link Extension (CCSDS 913.1-B-2).
2
-
3
-
Pure core implementation of SLE protocols. No I/O effects - all operations
4
-
are state machines that take bytes in and produce bytes + state changes out.
5
-
6
-
{1 Modules}
7
-
8
-
- {!Common}: Shared types (credentials, time, diagnostics)
9
-
- {!Tml}: Transport Mapping Layer framing
10
-
- {!Isp1}: ISP1 authentication
11
-
- {!Bind}: Session bind/unbind state machine
12
-
- {!Raf}: Return All Frames service
13
-
14
-
{1 Usage}
15
-
16
-
{[
17
-
(* Create initial state *)
18
-
let state = Sle.raf_initial in
19
-
20
-
(* Process bind invocation *)
21
-
let state, outputs = Sle.raf_step state (Bind inv) in
22
-
23
-
(* Handle outputs - Send_pdu goes to network via TML *)
24
-
List.iter
25
-
(function
26
-
| Sle.Send_pdu pdu -> send_via_tml pdu
27
-
| Sle.Bound v -> log "bound with version %d" v
28
-
| ...)
29
-
outputs
30
-
]}
31
-
32
-
For network I/O, use {!Sle_eio} which wraps this pure core. *)
33
-
34
-
module Common = Common
35
-
module Tml = Tml
36
-
module Isp1 = Isp1
37
-
module Bind = Bind
38
-
module Raf = Raf
39
-
module Rcf = Rcf
40
-
module Fcltu = Fcltu
41
-
42
-
(** {1 RAF Session} *)
43
-
44
-
type raf_state = { bind : Bind.state; raf : Raf.state; version : int }
45
-
(** Combined state for a complete RAF session. *)
46
-
47
-
(** Session output events. *)
48
-
type raf_output =
49
-
| Send_pdu of bytes (** BER-encoded PDU to send via TML *)
50
-
| Bound of int (** Session bound with SLE version *)
51
-
| Bind_failed of Bind.bind_diagnostic
52
-
| Frame of Raf.frame_or_notification (** TM frame received *)
53
-
| Started (** Data delivery started *)
54
-
| Start_failed of Raf.start_diagnostic
55
-
| Stopped (** Data delivery stopped *)
56
-
| Parameter_value of Raf.get_parameter_return (** GET-PARAMETER response *)
57
-
| Status_report_scheduled (** Status reporting started *)
58
-
| Status_report_stopped (** Status reporting stopped *)
59
-
| Status_report_failed of Raf.schedule_status_report_diagnostic
60
-
| Status_report of Raf.status_report (** Periodic status report *)
61
-
| Unbound (** Session terminated cleanly *)
62
-
| Aborted of Bind.peer_abort_diagnostic (** Session aborted *)
63
-
64
-
(** Session input events. *)
65
-
type raf_input =
66
-
| Bind of Bind.bind_invocation
67
-
| Bind_return of bytes
68
-
| Start of Raf.start_invocation
69
-
| Start_return of bytes
70
-
| Stop of Raf.stop_invocation
71
-
| Stop_return of bytes
72
-
| Transfer_data of bytes
73
-
| Get_parameter of Raf.get_parameter_invocation
74
-
| Get_parameter_return of bytes
75
-
| Schedule_status_report of Raf.schedule_status_report_invocation
76
-
| Schedule_status_report_return of bytes
77
-
| Status_report of bytes
78
-
| Unbind of Bind.unbind_invocation
79
-
| Unbind_return of bytes
80
-
| Peer_abort of bytes
81
-
82
-
type raf_error =
83
-
| Bind_error of Bind.error
84
-
| Raf_error of Raf.error
85
-
| Decode_error of string
86
-
87
-
val raf_initial : raf_state
88
-
(** Initial RAF session state (unbound). *)
89
-
90
-
val raf_step :
91
-
raf_state -> raf_input -> (raf_state * raf_output list, raf_error) result
92
-
(** Process input, return new state and outputs. *)
93
-
94
-
(** {1 Pretty-printers} *)
95
-
96
-
val pp_raf_state : raf_state Fmt.t
97
-
val pp_raf_error : raf_error Fmt.t
98
-
99
-
(** {1 RCF Session} *)
100
-
101
-
type rcf_state = { rcf_bind : Bind.state; rcf : Rcf.state; rcf_version : int }
102
-
(** Combined state for a complete RCF session. *)
103
-
104
-
(** RCF Session output events. *)
105
-
type rcf_output =
106
-
| Rcf_send_pdu of bytes
107
-
| Rcf_bound of int
108
-
| Rcf_bind_failed of Bind.bind_diagnostic
109
-
| Rcf_frame of Rcf.frame_or_notification
110
-
| Rcf_started
111
-
| Rcf_start_failed of Rcf.start_diagnostic
112
-
| Rcf_stopped
113
-
| Rcf_parameter_value of Rcf.get_parameter_return
114
-
| Rcf_status_report_scheduled
115
-
| Rcf_status_report_stopped
116
-
| Rcf_status_report_failed of Rcf.schedule_status_report_diagnostic
117
-
| Rcf_status_report of Rcf.status_report
118
-
| Rcf_unbound
119
-
| Rcf_aborted of Bind.peer_abort_diagnostic
120
-
121
-
(** RCF Session input events. *)
122
-
type rcf_input =
123
-
| Rcf_bind of Bind.bind_invocation
124
-
| Rcf_bind_return of bytes
125
-
| Rcf_start of Rcf.start_invocation
126
-
| Rcf_start_return of bytes
127
-
| Rcf_stop of Rcf.stop_invocation
128
-
| Rcf_stop_return of bytes
129
-
| Rcf_transfer_data of bytes
130
-
| Rcf_get_parameter of Rcf.get_parameter_invocation
131
-
| Rcf_get_parameter_return of bytes
132
-
| Rcf_schedule_status_report of Rcf.schedule_status_report_invocation
133
-
| Rcf_schedule_status_report_return of bytes
134
-
| Rcf_status_report of bytes
135
-
| Rcf_unbind of Bind.unbind_invocation
136
-
| Rcf_unbind_return of bytes
137
-
| Rcf_peer_abort of bytes
138
-
139
-
type rcf_error =
140
-
| Rcf_bind_error of Bind.error
141
-
| Rcf_rcf_error of Rcf.error
142
-
| Rcf_decode_error of string
143
-
144
-
val rcf_initial : rcf_state
145
-
(** Initial RCF session state (unbound). *)
146
-
147
-
val rcf_step :
148
-
rcf_state -> rcf_input -> (rcf_state * rcf_output list, rcf_error) result
149
-
(** Process RCF input, return new state and outputs. *)
150
-
151
-
val pp_rcf_state : rcf_state Fmt.t
152
-
val pp_rcf_error : rcf_error Fmt.t
-145
lib/sle/tml.ml
-145
lib/sle/tml.ml
···
1
-
(** Transport Mapping Layer (CCSDS 913.1-B-2 Section 4).
2
-
3
-
Pure module - no I/O effects. Handles TML message framing for SLE over TCP.
4
-
5
-
TML Header (8 bytes):
6
-
{v
7
-
+------+----------+----------+
8
-
| Type | Reserved | Length |
9
-
| 1B | 3B | 4B (BE) |
10
-
+------+----------+----------+
11
-
v}
12
-
13
-
Type values:
14
-
- 0x01: SLE PDU (BER-encoded SLE operation)
15
-
- 0x02: Context message (connection setup)
16
-
- 0x03: Heartbeat *)
17
-
18
-
(* {1 Types} *)
19
-
20
-
type msg_type = Sle_pdu | Context | Heartbeat
21
-
type message = { msg_type : msg_type; payload : bytes }
22
-
23
-
type context_message = {
24
-
protocol_id : int; (** ISP1 = 0x49535031 *)
25
-
version : int;
26
-
heartbeat_interval : int; (** Seconds, 0 = disabled *)
27
-
dead_factor : int; (** Missed heartbeats before disconnect *)
28
-
}
29
-
30
-
type error =
31
-
| Truncated of { need : int; have : int }
32
-
| Invalid_type of int
33
-
| Invalid_protocol_id of int
34
-
| Invalid_length of int
35
-
36
-
(* {1 Constants} *)
37
-
38
-
let header_len = 8
39
-
let type_sle_pdu = 0x01
40
-
let type_context = 0x02
41
-
let type_heartbeat = 0x03
42
-
43
-
(** ISP1 protocol identifier: "ISP1" in ASCII *)
44
-
let protocol_isp1 = 0x49535031
45
-
46
-
(* {1 Encoding} *)
47
-
48
-
let encode_type = function
49
-
| Sle_pdu -> type_sle_pdu
50
-
| Context -> type_context
51
-
| Heartbeat -> type_heartbeat
52
-
53
-
let encode msg =
54
-
let payload_len = Bytes.length msg.payload in
55
-
let buf = Bytes.create (header_len + payload_len) in
56
-
Bytes.set_uint8 buf 0 (encode_type msg.msg_type);
57
-
Bytes.set_uint8 buf 1 0;
58
-
Bytes.set_uint8 buf 2 0;
59
-
Bytes.set_uint8 buf 3 0;
60
-
Bytes.set_int32_be buf 4 (Int32.of_int payload_len);
61
-
Bytes.blit msg.payload 0 buf header_len payload_len;
62
-
buf
63
-
64
-
let encode_context ctx =
65
-
let payload = Bytes.create 12 in
66
-
Bytes.set_int32_be payload 0 (Int32.of_int ctx.protocol_id);
67
-
Bytes.set_int32_be payload 4 (Int32.of_int ctx.version);
68
-
(* Heartbeat interval (2 bytes) + dead factor (2 bytes) *)
69
-
Bytes.set_int16_be payload 8 ctx.heartbeat_interval;
70
-
Bytes.set_int16_be payload 10 ctx.dead_factor;
71
-
encode { msg_type = Context; payload }
72
-
73
-
let encode_heartbeat () = encode { msg_type = Heartbeat; payload = Bytes.empty }
74
-
75
-
let encode_sle_pdu pdu_bytes =
76
-
encode { msg_type = Sle_pdu; payload = pdu_bytes }
77
-
78
-
(* {1 Decoding} *)
79
-
80
-
let decode_type = function
81
-
| n when n = type_sle_pdu -> Ok Sle_pdu
82
-
| n when n = type_context -> Ok Context
83
-
| n when n = type_heartbeat -> Ok Heartbeat
84
-
| n -> Error (Invalid_type n)
85
-
86
-
(** Decode TML header. Returns (msg_type, payload_length) or error. *)
87
-
let decode_header buf =
88
-
let len = Bytes.length buf in
89
-
if len < header_len then Error (Truncated { need = header_len; have = len })
90
-
else
91
-
let type_byte = Bytes.get_uint8 buf 0 in
92
-
match decode_type type_byte with
93
-
| Error e -> Error e
94
-
| Ok msg_type ->
95
-
let payload_len = Int32.to_int (Bytes.get_int32_be buf 4) in
96
-
if payload_len < 0 then Error (Invalid_length payload_len)
97
-
else Ok (msg_type, payload_len)
98
-
99
-
(** Decode complete TML message. Returns message and remaining bytes. *)
100
-
let decode buf =
101
-
match decode_header buf with
102
-
| Error e -> Error e
103
-
| Ok (msg_type, payload_len) ->
104
-
let total_len = header_len + payload_len in
105
-
let buf_len = Bytes.length buf in
106
-
if buf_len < total_len then
107
-
Error (Truncated { need = total_len; have = buf_len })
108
-
else
109
-
let payload = Bytes.sub buf header_len payload_len in
110
-
let remaining = Bytes.sub buf total_len (buf_len - total_len) in
111
-
Ok ({ msg_type; payload }, remaining)
112
-
113
-
(** Decode context message payload. *)
114
-
let decode_context payload =
115
-
let len = Bytes.length payload in
116
-
if len < 12 then Error (Truncated { need = 12; have = len })
117
-
else
118
-
let protocol_id = Int32.to_int (Bytes.get_int32_be payload 0) in
119
-
if protocol_id <> protocol_isp1 then Error (Invalid_protocol_id protocol_id)
120
-
else
121
-
let version = Int32.to_int (Bytes.get_int32_be payload 4) in
122
-
let heartbeat_interval = Bytes.get_int16_be payload 8 in
123
-
let dead_factor = Bytes.get_int16_be payload 10 in
124
-
Ok { protocol_id; version; heartbeat_interval; dead_factor }
125
-
126
-
(* {1 Pretty-printers} *)
127
-
128
-
let pp_msg_type ppf = function
129
-
| Sle_pdu -> Fmt.string ppf "SLE-PDU"
130
-
| Context -> Fmt.string ppf "Context"
131
-
| Heartbeat -> Fmt.string ppf "Heartbeat"
132
-
133
-
let pp_message ppf msg =
134
-
Fmt.pf ppf "%a(%d bytes)" pp_msg_type msg.msg_type (Bytes.length msg.payload)
135
-
136
-
let pp_context ppf ctx =
137
-
Fmt.pf ppf "ISP1 v%d hb=%ds dead=%d" ctx.version ctx.heartbeat_interval
138
-
ctx.dead_factor
139
-
140
-
let pp_error ppf = function
141
-
| Truncated { need; have } ->
142
-
Fmt.pf ppf "truncated: need %d, have %d" need have
143
-
| Invalid_type n -> Fmt.pf ppf "invalid TML type: 0x%02x" n
144
-
| Invalid_protocol_id n -> Fmt.pf ppf "invalid protocol ID: 0x%08x" n
145
-
| Invalid_length n -> Fmt.pf ppf "invalid payload length: %d" n
-81
lib/sle/tml.mli
-81
lib/sle/tml.mli
···
1
-
(** Transport Mapping Layer (CCSDS 913.1-B-2 Section 4).
2
-
3
-
Pure module - no I/O effects. Handles TML message framing for SLE over TCP.
4
-
5
-
TML Header (8 bytes):
6
-
{v
7
-
+------+----------+----------+
8
-
| Type | Reserved | Length |
9
-
| 1B | 3B | 4B (BE) |
10
-
+------+----------+----------+
11
-
v}
12
-
13
-
Type values:
14
-
- 0x01: SLE PDU (BER-encoded SLE operation)
15
-
- 0x02: Context message (connection setup)
16
-
- 0x03: Heartbeat *)
17
-
18
-
(** {1 Types} *)
19
-
20
-
type msg_type = Sle_pdu | Context | Heartbeat
21
-
type message = { msg_type : msg_type; payload : bytes }
22
-
23
-
type context_message = {
24
-
protocol_id : int; (** ISP1 = 0x49535031 *)
25
-
version : int;
26
-
heartbeat_interval : int; (** Seconds, 0 = disabled *)
27
-
dead_factor : int; (** Missed heartbeats before disconnect *)
28
-
}
29
-
30
-
type error =
31
-
| Truncated of { need : int; have : int }
32
-
| Invalid_type of int
33
-
| Invalid_protocol_id of int
34
-
| Invalid_length of int
35
-
36
-
(** {1 Constants} *)
37
-
38
-
val header_len : int
39
-
val type_sle_pdu : int
40
-
val type_context : int
41
-
val type_heartbeat : int
42
-
43
-
val protocol_isp1 : int
44
-
(** ISP1 protocol identifier: "ISP1" in ASCII (0x49535031) *)
45
-
46
-
(** {1 Encoding} *)
47
-
48
-
val encode_type : msg_type -> int
49
-
(** [encode_type typ] returns the wire format byte for a message type. *)
50
-
51
-
val encode : message -> bytes
52
-
(** [encode msg] encodes a TML message with header and payload. *)
53
-
54
-
val encode_context : context_message -> bytes
55
-
(** [encode_context ctx] encodes a context message for connection setup. *)
56
-
57
-
val encode_heartbeat : unit -> bytes
58
-
(** [encode_heartbeat ()] encodes an empty heartbeat message. *)
59
-
60
-
val encode_sle_pdu : bytes -> bytes
61
-
(** [encode_sle_pdu pdu] wraps a BER-encoded SLE PDU in TML framing. *)
62
-
63
-
(** {1 Decoding} *)
64
-
65
-
val decode_header : bytes -> (msg_type * int, error) result
66
-
(** [decode_header buf] decodes TML header, returns (msg_type, payload_length).
67
-
*)
68
-
69
-
val decode : bytes -> (message * bytes, error) result
70
-
(** [decode buf] decodes complete TML message, returns message and remaining
71
-
bytes. *)
72
-
73
-
val decode_context : bytes -> (context_message, error) result
74
-
(** [decode_context payload] decodes context message payload. *)
75
-
76
-
(** {1 Pretty-printers} *)
77
-
78
-
val pp_msg_type : msg_type Fmt.t
79
-
val pp_message : message Fmt.t
80
-
val pp_context : context_message Fmt.t
81
-
val pp_error : error Fmt.t
-36
sle-eio.opam
-36
sle-eio.opam
···
1
-
# This file is generated by dune, edit dune-project instead
2
-
opam-version: "2.0"
3
-
synopsis: "Eio-based SLE client"
4
-
description:
5
-
"Effectful SLE client using Eio for TCP communication. Wraps the pure SLE library with I/O handling for TML framing and heartbeats."
6
-
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
7
-
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
8
-
license: "ISC"
9
-
homepage: "https://github.com/tarides/ocaml-sle"
10
-
bug-reports: "https://github.com/tarides/ocaml-sle/issues"
11
-
depends: [
12
-
"dune" {>= "3.0"}
13
-
"ocaml" {>= "5.1"}
14
-
"sle" {= version}
15
-
"eio" {>= "1.0"}
16
-
"cstruct" {>= "6.0"}
17
-
"mirage-crypto" {>= "1.0"}
18
-
"mirage-crypto-rng" {>= "1.0"}
19
-
"alcotest" {with-test}
20
-
"odoc" {with-doc}
21
-
]
22
-
build: [
23
-
["dune" "subst"] {dev}
24
-
[
25
-
"dune"
26
-
"build"
27
-
"-p"
28
-
name
29
-
"-j"
30
-
jobs
31
-
"@install"
32
-
"@runtest" {with-test}
33
-
"@doc" {with-doc}
34
-
]
35
-
]
36
-
dev-repo: "git+https://github.com/tarides/ocaml-sle.git"
-35
sle.opam
-35
sle.opam
···
1
-
# This file is generated by dune, edit dune-project instead
2
-
opam-version: "2.0"
3
-
synopsis: "CCSDS Space Link Extension (SLE) protocols"
4
-
description:
5
-
"Pure OCaml implementation of CCSDS Space Link Extension protocols for ground station communication. Includes RAF (Return All Frames), RCF (Return Channel Frames), and FCLTU (Forward CLTU) services."
6
-
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
7
-
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
8
-
license: "ISC"
9
-
homepage: "https://github.com/tarides/ocaml-sle"
10
-
bug-reports: "https://github.com/tarides/ocaml-sle/issues"
11
-
depends: [
12
-
"dune" {>= "3.0"}
13
-
"ocaml" {>= "5.1"}
14
-
"asn1-combinators" {>= "0.3"}
15
-
"digestif" {>= "1.0"}
16
-
"fmt" {>= "0.9"}
17
-
"logs" {>= "0.7"}
18
-
"alcotest" {with-test}
19
-
"odoc" {with-doc}
20
-
]
21
-
build: [
22
-
["dune" "subst"] {dev}
23
-
[
24
-
"dune"
25
-
"build"
26
-
"-p"
27
-
name
28
-
"-j"
29
-
jobs
30
-
"@install"
31
-
"@runtest" {with-test}
32
-
"@doc" {with-doc}
33
-
]
34
-
]
35
-
dev-repo: "git+https://github.com/tarides/ocaml-sle.git"