Pure OCaml ARP table lookup - reads /proc/net/arp on Linux and arp -a on macOS/BSD
Merge commit '16b0aaa2c7a2350a423e70b93fb2895a8e74dc2b'
+5886
-164
+59
README.md
+59
README.md
···
1
+
# ocaml-sle
2
+
3
+
Pure OCaml implementation of CCSDS Space Link Extension (SLE) protocols for
4
+
ground station communication.
5
+
6
+
## Features
7
+
8
+
- **RAF** - Return All Frames (downlink telemetry)
9
+
- **RCF** - Return Channel Frames (filtered downlink)
10
+
- **FCLTU** - Forward CLTU (uplink telecommands)
11
+
- **TML** - Transport Mapping Layer framing
12
+
- **ISP1** - Authentication
13
+
14
+
## Installation
15
+
16
+
```
17
+
opam install sle sle-eio
18
+
```
19
+
20
+
## Usage
21
+
22
+
The `sle` package provides a pure functional state machine with no I/O effects.
23
+
The `sle-eio` package wraps it with Eio for TCP communication.
24
+
25
+
```ocaml
26
+
Eio_main.run @@ fun env ->
27
+
Eio.Switch.run @@ fun sw ->
28
+
let config = Sle_eio.default_config ~host:"sle-provider.example.com" ~port:5100 in
29
+
match Sle_eio.connect ~sw ~net:(Eio.Stdenv.net env) ~clock:(Eio.Stdenv.clock env) config with
30
+
| Error e -> Fmt.epr "Connection failed: %a@." Sle_eio.pp_error e
31
+
| Ok client ->
32
+
match Sle_eio.bind client ~initiator_id:"user" ~responder_port_id:"RAF"
33
+
~service_type:Sle.Bind.Raf_all ~version:5
34
+
~service_instance_id:"sagr=1.spack=..." with
35
+
| Error e -> Fmt.epr "Bind failed: %a@." Sle_eio.pp_error e
36
+
| Ok _version ->
37
+
match Sle_eio.start_raf client ~start_time:None ~stop_time:None
38
+
~requested_quality:Sle.Common.Good with
39
+
| Error e -> Fmt.epr "Start failed: %a@." Sle_eio.pp_error e
40
+
| Ok () ->
41
+
(* Receive frames *)
42
+
let rec loop () =
43
+
match Sle_eio.recv_frame client with
44
+
| Error Sle_eio.Closed -> ()
45
+
| Error e -> Fmt.epr "Error: %a@." Sle_eio.pp_error e
46
+
| Ok frame ->
47
+
process_frame frame.data;
48
+
loop ()
49
+
in
50
+
loop ()
51
+
```
52
+
53
+
## References
54
+
55
+
- [CCSDS 913.1-B-2](https://public.ccsds.org/Pubs/913x1b2.pdf) - Space Link Extension Services
56
+
57
+
## License
58
+
59
+
ISC
-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
-
]
+36
-7
dune-project
+36
-7
dune-project
···
1
1
(lang dune 3.0)
2
-
(name arp)
2
+
3
+
(name sle)
3
4
4
5
(generate_opam_files true)
5
6
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
+
6
16
(package
7
-
(name arp)
8
-
(synopsis "Pure OCaml ARP table lookup")
17
+
(name sle)
18
+
(synopsis "CCSDS Space Link Extension (SLE) protocols")
19
+
(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.")
21
+
(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")
9
33
(description
10
-
"Read the system ARP cache without external dependencies. Uses /proc/net/arp on Linux and arp -a on macOS/BSD.")
34
+
"Effectful SLE client using Eio for TCP communication. Wraps the pure SLE library with I/O handling for TML framing and heartbeats.")
11
35
(depends
12
-
(ocaml (>= 4.14.0))
13
-
(dune (>= 3.0))
14
-
(alcotest :with-test)))
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)))
-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"