CCSDS 521.0-B-1 Mission Operations Message Abstraction Layer (MAL)
Remove renamed packages, add new CCSDS standards
Remove ocaml-ccsds-122 and ocaml-ccsds-123 (renamed to ocaml-idc and
ocaml-hcomp). Add ocaml-csts, ocaml-mal, ocaml-spacefibre packages.
Update ocaml-xmlt, ocaml-contact, ocaml-crypto (pure AES + JS stubs).
+1488
+35
README.md
+35
README.md
···
1
+
# mal
2
+
3
+
Pure OCaml implementation of the CCSDS Mission Operations Abstraction Layer
4
+
(MAL), as defined in CCSDS 521.0-B-1.
5
+
6
+
## Overview
7
+
8
+
MAL is a service-oriented architecture framework for mission operations. It
9
+
provides a standard set of interaction patterns and data types that decouple
10
+
service consumers from service providers, allowing mission operations services
11
+
to be deployed over different transport technologies.
12
+
13
+
MAL is the foundation of the CCSDS Mission Operations (MO) services framework,
14
+
used in:
15
+
16
+
- Spacecraft monitoring and control
17
+
- Mission planning and scheduling
18
+
- Space data management
19
+
- Navigation and orbit determination
20
+
21
+
## Features
22
+
23
+
- Six interaction patterns: Send, Submit, Request, Invoke, Progress, Pub-Sub
24
+
- Complete MAL data type system (Blob, Duration, FineTime, Identifier, etc.)
25
+
- Service area, service, and operation definitions
26
+
- Abstract transport binding interface
27
+
- Message header with full routing metadata
28
+
- In-memory transport for testing and local use
29
+
30
+
## References
31
+
32
+
- [CCSDS 521.0-B-1](https://public.ccsds.org/Pubs/521x0b2e1.pdf) - Mission
33
+
Operations Message Abstraction Layer
34
+
- [CCSDS 520.0-G](https://public.ccsds.org/Pubs/520x0g4.pdf) - Mission
35
+
Operations Services Concept (Green Book)
+6
dune-project
+6
dune-project
+408
lib/mal.ml
+408
lib/mal.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Mission Operations Message Abstraction Layer (CCSDS 521.0-B). *)
7
+
8
+
(* {1 MAL Data Types} *)
9
+
10
+
type blob = string
11
+
type identifier = string
12
+
type uri = string
13
+
type time = { t_seconds : int64 }
14
+
type fine_time = { ft_seconds : int64; ft_picos : int64 }
15
+
type duration = { d_seconds : int64; d_picos : int64 }
16
+
17
+
let pp_time fmt t = Fmt.pf fmt "%Ld" t.t_seconds
18
+
let pp_fine_time fmt t = Fmt.pf fmt "%Ld.%012Ld" t.ft_seconds t.ft_picos
19
+
let pp_duration fmt d = Fmt.pf fmt "%Ld.%012Lds" d.d_seconds d.d_picos
20
+
21
+
(* {1 Session Types} *)
22
+
23
+
type session_type = Live | Simulation | Replay
24
+
25
+
let pp_session_type fmt = function
26
+
| Live -> Fmt.string fmt "LIVE"
27
+
| Simulation -> Fmt.string fmt "SIMULATION"
28
+
| Replay -> Fmt.string fmt "REPLAY"
29
+
30
+
let int_of_session_type = function Live -> 1 | Simulation -> 2 | Replay -> 3
31
+
32
+
let session_type_of_int = function
33
+
| 1 -> Ok Live
34
+
| 2 -> Ok Simulation
35
+
| 3 -> Ok Replay
36
+
| n -> Error n
37
+
38
+
(* {1 QoS Levels} *)
39
+
40
+
type qos = Best_effort | Assured | Queued | Timely
41
+
42
+
let pp_qos fmt = function
43
+
| Best_effort -> Fmt.string fmt "BEST_EFFORT"
44
+
| Assured -> Fmt.string fmt "ASSURED"
45
+
| Queued -> Fmt.string fmt "QUEUED"
46
+
| Timely -> Fmt.string fmt "TIMELY"
47
+
48
+
let int_of_qos = function
49
+
| Best_effort -> 1
50
+
| Assured -> 2
51
+
| Queued -> 3
52
+
| Timely -> 4
53
+
54
+
let qos_of_int = function
55
+
| 1 -> Ok Best_effort
56
+
| 2 -> Ok Assured
57
+
| 3 -> Ok Queued
58
+
| 4 -> Ok Timely
59
+
| n -> Error n
60
+
61
+
(* {1 Interaction Patterns} *)
62
+
63
+
type interaction_type = Send | Submit | Request | Invoke | Progress | Pub_sub
64
+
65
+
let pp_interaction_type fmt = function
66
+
| Send -> Fmt.string fmt "SEND"
67
+
| Submit -> Fmt.string fmt "SUBMIT"
68
+
| Request -> Fmt.string fmt "REQUEST"
69
+
| Invoke -> Fmt.string fmt "INVOKE"
70
+
| Progress -> Fmt.string fmt "PROGRESS"
71
+
| Pub_sub -> Fmt.string fmt "PUBSUB"
72
+
73
+
let int_of_interaction_type = function
74
+
| Send -> 1
75
+
| Submit -> 2
76
+
| Request -> 3
77
+
| Invoke -> 4
78
+
| Progress -> 5
79
+
| Pub_sub -> 6
80
+
81
+
let interaction_type_of_int = function
82
+
| 1 -> Ok Send
83
+
| 2 -> Ok Submit
84
+
| 3 -> Ok Request
85
+
| 4 -> Ok Invoke
86
+
| 5 -> Ok Progress
87
+
| 6 -> Ok Pub_sub
88
+
| n -> Error n
89
+
90
+
(* {1 Message Stages} *)
91
+
92
+
type stage =
93
+
| Send_stage
94
+
| Submit_stage
95
+
| Submit_ack
96
+
| Request_stage
97
+
| Request_response
98
+
| Invoke_stage
99
+
| Invoke_ack
100
+
| Invoke_response
101
+
| Progress_stage
102
+
| Progress_ack
103
+
| Progress_update
104
+
| Progress_response
105
+
| Pubsub_register
106
+
| Pubsub_register_ack
107
+
| Pubsub_publish_register
108
+
| Pubsub_publish_register_ack
109
+
| Pubsub_publish
110
+
| Pubsub_notify
111
+
| Pubsub_deregister
112
+
| Pubsub_deregister_ack
113
+
| Pubsub_publish_deregister
114
+
| Pubsub_publish_deregister_ack
115
+
116
+
let pp_stage fmt = function
117
+
| Send_stage -> Fmt.string fmt "SEND"
118
+
| Submit_stage -> Fmt.string fmt "SUBMIT"
119
+
| Submit_ack -> Fmt.string fmt "SUBMIT_ACK"
120
+
| Request_stage -> Fmt.string fmt "REQUEST"
121
+
| Request_response -> Fmt.string fmt "REQUEST_RESPONSE"
122
+
| Invoke_stage -> Fmt.string fmt "INVOKE"
123
+
| Invoke_ack -> Fmt.string fmt "INVOKE_ACK"
124
+
| Invoke_response -> Fmt.string fmt "INVOKE_RESPONSE"
125
+
| Progress_stage -> Fmt.string fmt "PROGRESS"
126
+
| Progress_ack -> Fmt.string fmt "PROGRESS_ACK"
127
+
| Progress_update -> Fmt.string fmt "PROGRESS_UPDATE"
128
+
| Progress_response -> Fmt.string fmt "PROGRESS_RESPONSE"
129
+
| Pubsub_register -> Fmt.string fmt "REGISTER"
130
+
| Pubsub_register_ack -> Fmt.string fmt "REGISTER_ACK"
131
+
| Pubsub_publish_register -> Fmt.string fmt "PUBLISH_REGISTER"
132
+
| Pubsub_publish_register_ack -> Fmt.string fmt "PUBLISH_REGISTER_ACK"
133
+
| Pubsub_publish -> Fmt.string fmt "PUBLISH"
134
+
| Pubsub_notify -> Fmt.string fmt "NOTIFY"
135
+
| Pubsub_deregister -> Fmt.string fmt "DEREGISTER"
136
+
| Pubsub_deregister_ack -> Fmt.string fmt "DEREGISTER_ACK"
137
+
| Pubsub_publish_deregister -> Fmt.string fmt "PUBLISH_DEREGISTER"
138
+
| Pubsub_publish_deregister_ack -> Fmt.string fmt "PUBLISH_DEREGISTER_ACK"
139
+
140
+
let interaction_type_of_stage = function
141
+
| Send_stage -> Send
142
+
| Submit_stage | Submit_ack -> Submit
143
+
| Request_stage | Request_response -> Request
144
+
| Invoke_stage | Invoke_ack | Invoke_response -> Invoke
145
+
| Progress_stage | Progress_ack | Progress_update | Progress_response ->
146
+
Progress
147
+
| Pubsub_register | Pubsub_register_ack | Pubsub_publish_register
148
+
| Pubsub_publish_register_ack | Pubsub_publish | Pubsub_notify
149
+
| Pubsub_deregister | Pubsub_deregister_ack | Pubsub_publish_deregister
150
+
| Pubsub_publish_deregister_ack ->
151
+
Pub_sub
152
+
153
+
let validate_stage ip stage = interaction_type_of_stage stage = ip
154
+
155
+
(* {1 Message Header} *)
156
+
157
+
type header = {
158
+
uri_from : uri;
159
+
authentication_id : blob;
160
+
uri_to : uri;
161
+
timestamp : fine_time;
162
+
qos : qos;
163
+
priority : int;
164
+
domain : identifier list;
165
+
network_zone : identifier;
166
+
session : session_type;
167
+
session_name : identifier;
168
+
interaction_type : interaction_type;
169
+
stage : stage;
170
+
transaction_id : int64;
171
+
area : int;
172
+
area_version : int;
173
+
service : int;
174
+
operation : int;
175
+
is_error : bool;
176
+
body : blob;
177
+
}
178
+
179
+
let pp_header fmt h =
180
+
Fmt.pf fmt
181
+
"@[<v>from: %s@,\
182
+
to: %s@,\
183
+
interaction: %a@,\
184
+
stage: %a@,\
185
+
transaction: %Ld@,\
186
+
area: %d (v%d)@,\
187
+
service: %d@,\
188
+
operation: %d@,\
189
+
error: %b@,\
190
+
body: %d bytes@]"
191
+
h.uri_from h.uri_to pp_interaction_type h.interaction_type pp_stage h.stage
192
+
h.transaction_id h.area h.area_version h.service h.operation h.is_error
193
+
(String.length h.body)
194
+
195
+
(* {1 Errors} *)
196
+
197
+
type error_code =
198
+
| Delivery_failed
199
+
| Delivery_timedout
200
+
| Delivery_delayed
201
+
| Destination_unknown
202
+
| Destination_transient
203
+
| Destination_lost
204
+
| Authentication_fail
205
+
| Authorisation_fail
206
+
| Encryption_fail
207
+
| Unsupported_area
208
+
| Unsupported_area_version
209
+
| Unsupported_service
210
+
| Unsupported_operation
211
+
| Bad_encoding
212
+
| Internal
213
+
| Unknown
214
+
215
+
let pp_error_code fmt = function
216
+
| Delivery_failed -> Fmt.string fmt "DELIVERY_FAILED"
217
+
| Delivery_timedout -> Fmt.string fmt "DELIVERY_TIMEDOUT"
218
+
| Delivery_delayed -> Fmt.string fmt "DELIVERY_DELAYED"
219
+
| Destination_unknown -> Fmt.string fmt "DESTINATION_UNKNOWN"
220
+
| Destination_transient -> Fmt.string fmt "DESTINATION_TRANSIENT"
221
+
| Destination_lost -> Fmt.string fmt "DESTINATION_LOST"
222
+
| Authentication_fail -> Fmt.string fmt "AUTHENTICATION_FAIL"
223
+
| Authorisation_fail -> Fmt.string fmt "AUTHORISATION_FAIL"
224
+
| Encryption_fail -> Fmt.string fmt "ENCRYPTION_FAIL"
225
+
| Unsupported_area -> Fmt.string fmt "UNSUPPORTED_AREA"
226
+
| Unsupported_area_version -> Fmt.string fmt "UNSUPPORTED_AREA_VERSION"
227
+
| Unsupported_service -> Fmt.string fmt "UNSUPPORTED_SERVICE"
228
+
| Unsupported_operation -> Fmt.string fmt "UNSUPPORTED_OPERATION"
229
+
| Bad_encoding -> Fmt.string fmt "BAD_ENCODING"
230
+
| Internal -> Fmt.string fmt "INTERNAL"
231
+
| Unknown -> Fmt.string fmt "UNKNOWN"
232
+
233
+
(* {1 Service Definitions} *)
234
+
235
+
type operation_def = {
236
+
op_name : identifier;
237
+
op_number : int;
238
+
op_interaction : interaction_type;
239
+
}
240
+
241
+
let pp_operation_def fmt op =
242
+
Fmt.pf fmt "%s (#%d, %a)" op.op_name op.op_number pp_interaction_type
243
+
op.op_interaction
244
+
245
+
type service_def = {
246
+
svc_name : identifier;
247
+
svc_number : int;
248
+
svc_operations : operation_def list;
249
+
}
250
+
251
+
let pp_service_def fmt svc =
252
+
Fmt.pf fmt "@[<v>%s (#%d):@,%a@]" svc.svc_name svc.svc_number
253
+
Fmt.(list ~sep:cut pp_operation_def)
254
+
svc.svc_operations
255
+
256
+
type area_def = {
257
+
area_name : identifier;
258
+
area_number : int;
259
+
area_version : int;
260
+
area_services : service_def list;
261
+
}
262
+
263
+
let pp_area_def fmt area =
264
+
Fmt.pf fmt "@[<v>%s (#%d v%d):@,%a@]" area.area_name area.area_number
265
+
area.area_version
266
+
Fmt.(list ~sep:cut pp_service_def)
267
+
area.area_services
268
+
269
+
(* {1 Service Registry} *)
270
+
271
+
type handler = header -> (header, error_code) result
272
+
273
+
(* Internal key for operation lookup. *)
274
+
module Op_key = struct
275
+
type t = int * int * int (* area, service, operation *)
276
+
277
+
let compare (a1, s1, o1) (a2, s2, o2) =
278
+
let c = compare a1 a2 in
279
+
if c <> 0 then c
280
+
else
281
+
let c = compare s1 s2 in
282
+
if c <> 0 then c else compare o1 o2
283
+
end
284
+
285
+
module Op_map = Map.Make (Op_key)
286
+
287
+
type registry = {
288
+
mutable operations : operation_def Op_map.t;
289
+
mutable handlers : handler Op_map.t;
290
+
mutable areas : area_def list;
291
+
}
292
+
293
+
let create_registry () =
294
+
{ operations = Op_map.empty; handlers = Op_map.empty; areas = [] }
295
+
296
+
let register_area reg area =
297
+
reg.areas <- area :: reg.areas;
298
+
List.iter
299
+
(fun svc ->
300
+
List.iter
301
+
(fun op ->
302
+
let key = (area.area_number, svc.svc_number, op.op_number) in
303
+
reg.operations <- Op_map.add key op reg.operations)
304
+
svc.svc_operations)
305
+
area.area_services
306
+
307
+
let register_handler reg ~area ~service ~operation h =
308
+
let key = (area, service, operation) in
309
+
reg.handlers <- Op_map.add key h reg.handlers
310
+
311
+
let lookup_operation reg ~area ~service ~operation =
312
+
Op_map.find_opt (area, service, operation) reg.operations
313
+
314
+
let lookup_handler reg ~area ~service ~operation =
315
+
Op_map.find_opt (area, service, operation) reg.handlers
316
+
317
+
let dispatch reg msg =
318
+
let area = msg.area and service = msg.service and operation = msg.operation in
319
+
(* Check that the area is registered *)
320
+
let area_found = List.exists (fun a -> a.area_number = area) reg.areas in
321
+
if not area_found then Error Unsupported_area
322
+
else
323
+
(* Check that the service is registered *)
324
+
let svc_found =
325
+
List.exists
326
+
(fun a ->
327
+
a.area_number = area
328
+
&& List.exists (fun s -> s.svc_number = service) a.area_services)
329
+
reg.areas
330
+
in
331
+
if not svc_found then Error Unsupported_service
332
+
else
333
+
match lookup_handler reg ~area ~service ~operation with
334
+
| None -> Error Unsupported_operation
335
+
| Some h -> h msg
336
+
337
+
(* {1 Transport} *)
338
+
339
+
module type Transport = sig
340
+
type t
341
+
342
+
val send : t -> header -> (unit, error_code) result
343
+
val recv : t -> (header, error_code) result
344
+
val close : t -> unit
345
+
end
346
+
347
+
(* {1 In-Memory Transport} *)
348
+
349
+
module Mem_transport = struct
350
+
(* Global table of endpoints, keyed by URI. *)
351
+
let endpoints : (uri, header Queue.t) Hashtbl.t = Hashtbl.create 16
352
+
353
+
type t = { uri : uri; inbox : header Queue.t }
354
+
355
+
let create u =
356
+
let inbox = Queue.create () in
357
+
Hashtbl.replace endpoints u inbox;
358
+
{ uri = u; inbox }
359
+
360
+
let uri t = t.uri
361
+
362
+
let send _t msg =
363
+
match Hashtbl.find_opt endpoints msg.uri_to with
364
+
| None -> Error Destination_unknown
365
+
| Some q ->
366
+
Queue.push msg q;
367
+
Ok ()
368
+
369
+
let recv t =
370
+
if Queue.is_empty t.inbox then Error Delivery_failed
371
+
else Ok (Queue.pop t.inbox)
372
+
373
+
let close t = Hashtbl.remove endpoints t.uri
374
+
let reset () = Hashtbl.clear endpoints
375
+
end
376
+
377
+
(* {1 Interaction Helpers} *)
378
+
379
+
let _transaction_counter = ref 0L
380
+
381
+
let next_transaction_id () =
382
+
let id = !_transaction_counter in
383
+
_transaction_counter := Int64.add id 1L;
384
+
id
385
+
386
+
let make_header ~uri_from ~uri_to ~interaction_type ~stage ~transaction_id ~area
387
+
~service ~operation ~body () =
388
+
{
389
+
uri_from;
390
+
authentication_id = "";
391
+
uri_to;
392
+
timestamp = { ft_seconds = 0L; ft_picos = 0L };
393
+
qos = Best_effort;
394
+
priority = 0;
395
+
domain = [];
396
+
network_zone = "";
397
+
session = Live;
398
+
session_name = "LIVE";
399
+
interaction_type;
400
+
stage;
401
+
transaction_id;
402
+
area;
403
+
area_version = 1;
404
+
service;
405
+
operation;
406
+
is_error = false;
407
+
body;
408
+
}
+349
lib/mal.mli
+349
lib/mal.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Mission Operations Message Abstraction Layer (CCSDS 521.0-B).
7
+
8
+
MAL defines a service-oriented architecture for mission operations.
9
+
Consumers and providers interact through typed {e interaction patterns},
10
+
each of which prescribes a fixed sequence of messages. The framework is
11
+
transport-agnostic: an abstract {!Transport} interface lets the same service
12
+
definitions run over different wire protocols.
13
+
14
+
{b Interaction patterns}
15
+
{v
16
+
Send: SEND ->
17
+
Submit: SUBMIT -> ACK
18
+
Request: REQUEST -> RESPONSE
19
+
Invoke: INVOKE -> ACK -> RESPONSE
20
+
Progress: PROGRESS -> ACK -> UPDATE* -> RESPONSE
21
+
Pub-Sub: REGISTER -> REGISTER_ACK
22
+
PUBLISH_REGISTER -> PUBLISH_REGISTER_ACK
23
+
PUBLISH -> NOTIFY
24
+
DEREGISTER -> DEREGISTER_ACK
25
+
PUBLISH_DEREGISTER -> PUBLISH_DEREGISTER_ACK
26
+
v}
27
+
28
+
{b References}
29
+
- {{:https://public.ccsds.org/Pubs/521x0b2e1.pdf}CCSDS 521.0-B-1} - Mission
30
+
Operations Message Abstraction Layer *)
31
+
32
+
(** {1 MAL Data Types}
33
+
34
+
CCSDS 521.0-B Section 5 defines the standard data types used in message
35
+
bodies and service definitions. *)
36
+
37
+
type blob = string
38
+
(** Opaque byte sequence. *)
39
+
40
+
type identifier = string
41
+
(** A named identifier string. *)
42
+
43
+
type uri = string
44
+
(** Uniform resource identifier for endpoint addressing. *)
45
+
46
+
type time = { t_seconds : int64 }
47
+
(** Timestamp with second resolution (CCSDS epoch: 1958-01-01). *)
48
+
49
+
type fine_time = { ft_seconds : int64; ft_picos : int64 }
50
+
(** Timestamp with sub-second resolution (CCSDS epoch: 1958-01-01). *)
51
+
52
+
type duration = { d_seconds : int64; d_picos : int64 }
53
+
(** Duration in seconds and fractional picoseconds. *)
54
+
55
+
val pp_time : time Fmt.t
56
+
val pp_fine_time : fine_time Fmt.t
57
+
val pp_duration : duration Fmt.t
58
+
59
+
(** {1 Session Types} *)
60
+
61
+
type session_type =
62
+
| Live (** Real-time session. *)
63
+
| Simulation (** Simulation session. *)
64
+
| Replay (** Replay of recorded data. *)
65
+
66
+
val pp_session_type : session_type Fmt.t
67
+
68
+
val int_of_session_type : session_type -> int
69
+
(** [int_of_session_type s] returns the integer code for [s]. *)
70
+
71
+
val session_type_of_int : int -> (session_type, int) result
72
+
(** [session_type_of_int n] decodes a session type from its integer code. *)
73
+
74
+
(** {1 QoS Levels} *)
75
+
76
+
type qos =
77
+
| Best_effort (** Delivery not guaranteed. *)
78
+
| Assured (** Delivery guaranteed but unordered. *)
79
+
| Queued (** Delivery guaranteed and ordered. *)
80
+
| Timely (** Delivery within a deadline. *)
81
+
82
+
val pp_qos : qos Fmt.t
83
+
84
+
val int_of_qos : qos -> int
85
+
(** [int_of_qos q] returns the integer code for [q]. *)
86
+
87
+
val qos_of_int : int -> (qos, int) result
88
+
(** [qos_of_int n] decodes a QoS level from its integer code. *)
89
+
90
+
(** {1 Interaction Patterns} *)
91
+
92
+
(** The six MAL interaction patterns (CCSDS 521.0-B Section 3.3). *)
93
+
type interaction_type =
94
+
| Send (** One-way message, no reply. *)
95
+
| Submit (** Request with acknowledgement. *)
96
+
| Request (** Request expecting a single response. *)
97
+
| Invoke (** Request with acknowledgement then response. *)
98
+
| Progress
99
+
(** Request with acknowledgement, zero or more updates, then response. *)
100
+
| Pub_sub (** Publish-subscribe pattern. *)
101
+
102
+
val pp_interaction_type : interaction_type Fmt.t
103
+
104
+
val int_of_interaction_type : interaction_type -> int
105
+
(** [int_of_interaction_type ip] returns the integer code. *)
106
+
107
+
val interaction_type_of_int : int -> (interaction_type, int) result
108
+
(** [interaction_type_of_int n] decodes from its integer code. *)
109
+
110
+
(** {1 Message Stages}
111
+
112
+
Each interaction pattern defines specific message stages that must occur in
113
+
order. *)
114
+
115
+
type stage =
116
+
| Send_stage (** Send: the single message. *)
117
+
| Submit_stage (** Submit: the initial request. *)
118
+
| Submit_ack (** Submit: acknowledgement. *)
119
+
| Request_stage (** Request: the initial request. *)
120
+
| Request_response (** Request: the response. *)
121
+
| Invoke_stage (** Invoke: the initial request. *)
122
+
| Invoke_ack (** Invoke: acknowledgement. *)
123
+
| Invoke_response (** Invoke: the response. *)
124
+
| Progress_stage (** Progress: the initial request. *)
125
+
| Progress_ack (** Progress: acknowledgement. *)
126
+
| Progress_update (** Progress: an intermediate update. *)
127
+
| Progress_response (** Progress: the final response. *)
128
+
| Pubsub_register (** Pub-Sub: subscription registration. *)
129
+
| Pubsub_register_ack (** Pub-Sub: registration acknowledgement. *)
130
+
| Pubsub_publish_register (** Pub-Sub: publisher registration. *)
131
+
| Pubsub_publish_register_ack (** Pub-Sub: publisher registration ack. *)
132
+
| Pubsub_publish (** Pub-Sub: publish a value. *)
133
+
| Pubsub_notify (** Pub-Sub: notification to subscriber. *)
134
+
| Pubsub_deregister (** Pub-Sub: subscription cancellation. *)
135
+
| Pubsub_deregister_ack (** Pub-Sub: cancellation acknowledgement. *)
136
+
| Pubsub_publish_deregister (** Pub-Sub: publisher deregistration. *)
137
+
| Pubsub_publish_deregister_ack (** Pub-Sub: publisher deregistration ack. *)
138
+
139
+
val pp_stage : stage Fmt.t
140
+
141
+
val interaction_type_of_stage : stage -> interaction_type
142
+
(** [interaction_type_of_stage s] returns the interaction pattern that [s]
143
+
belongs to. *)
144
+
145
+
(** {1 Message Header}
146
+
147
+
Every MAL message carries a header with routing and identification metadata
148
+
(CCSDS 521.0-B Section 4.3). *)
149
+
150
+
type header = {
151
+
uri_from : uri; (** Source endpoint. *)
152
+
authentication_id : blob; (** Opaque authentication token. *)
153
+
uri_to : uri; (** Destination endpoint. *)
154
+
timestamp : fine_time; (** Message creation time. *)
155
+
qos : qos; (** Quality of service level. *)
156
+
priority : int; (** Message priority (0 = highest). *)
157
+
domain : identifier list; (** Hierarchical domain path. *)
158
+
network_zone : identifier; (** Network zone identifier. *)
159
+
session : session_type; (** Session type. *)
160
+
session_name : identifier; (** Session name. *)
161
+
interaction_type : interaction_type; (** Interaction pattern. *)
162
+
stage : stage; (** Current stage within the interaction. *)
163
+
transaction_id : int64; (** Unique transaction identifier. *)
164
+
area : int; (** Service area number. *)
165
+
area_version : int; (** Service area version. *)
166
+
service : int; (** Service number within the area. *)
167
+
operation : int; (** Operation number within the service. *)
168
+
is_error : bool; (** Whether this message carries an error. *)
169
+
body : blob; (** Opaque message body. *)
170
+
}
171
+
(** A complete MAL message header. *)
172
+
173
+
val pp_header : header Fmt.t
174
+
(** [pp_header ppf h] pretty-prints the header. *)
175
+
176
+
(** {1 Errors} *)
177
+
178
+
(** Standard MAL error codes (CCSDS 521.0-B Section 3.5.3). *)
179
+
type error_code =
180
+
| Delivery_failed (** Transport could not deliver the message. *)
181
+
| Delivery_timedout (** Delivery exceeded the QoS time limit. *)
182
+
| Delivery_delayed (** Delivery was delayed beyond acceptable bounds. *)
183
+
| Destination_unknown (** The destination URI is not known. *)
184
+
| Destination_transient (** The destination is temporarily unreachable. *)
185
+
| Destination_lost (** The destination was lost during the interaction. *)
186
+
| Authentication_fail (** Authentication of the sender failed. *)
187
+
| Authorisation_fail (** The sender is not authorised for this operation. *)
188
+
| Encryption_fail (** Message encryption/decryption failed. *)
189
+
| Unsupported_area (** The requested service area is not supported. *)
190
+
| Unsupported_area_version (** The area version is not supported. *)
191
+
| Unsupported_service (** The requested service is not supported. *)
192
+
| Unsupported_operation (** The requested operation is not supported. *)
193
+
| Bad_encoding (** The message body encoding is invalid. *)
194
+
| Internal (** An internal error occurred in the provider. *)
195
+
| Unknown (** An unknown error occurred. *)
196
+
197
+
val pp_error_code : error_code Fmt.t
198
+
199
+
(** {1 Service Definitions}
200
+
201
+
A MAL {e service area} groups related services. Each {e service} contains
202
+
{e operations} that define the interaction pattern and message types. *)
203
+
204
+
type operation_def = {
205
+
op_name : identifier; (** Operation name. *)
206
+
op_number : int; (** Numeric operation identifier. *)
207
+
op_interaction : interaction_type; (** Interaction pattern used. *)
208
+
}
209
+
(** An operation definition within a service. *)
210
+
211
+
val pp_operation_def : operation_def Fmt.t
212
+
213
+
type service_def = {
214
+
svc_name : identifier; (** Service name. *)
215
+
svc_number : int; (** Numeric service identifier. *)
216
+
svc_operations : operation_def list; (** Operations in this service. *)
217
+
}
218
+
(** A service definition within an area. *)
219
+
220
+
val pp_service_def : service_def Fmt.t
221
+
222
+
type area_def = {
223
+
area_name : identifier; (** Area name. *)
224
+
area_number : int; (** Numeric area identifier. *)
225
+
area_version : int; (** Area version. *)
226
+
area_services : service_def list; (** Services in this area. *)
227
+
}
228
+
(** A service area definition. *)
229
+
230
+
val pp_area_def : area_def Fmt.t
231
+
232
+
(** {1 Service Registry}
233
+
234
+
The registry maps (area, service, operation) tuples to their definitions and
235
+
allows provider handlers to be registered for dispatch. *)
236
+
237
+
type handler = header -> (header, error_code) result
238
+
(** A message handler: receives a request header and returns a response header
239
+
or an error code. *)
240
+
241
+
type registry
242
+
(** A mutable service registry. *)
243
+
244
+
val create_registry : unit -> registry
245
+
(** [create_registry ()] creates an empty service registry. *)
246
+
247
+
val register_area : registry -> area_def -> unit
248
+
(** [register_area reg area] registers all services and operations in [area]. *)
249
+
250
+
val register_handler :
251
+
registry -> area:int -> service:int -> operation:int -> handler -> unit
252
+
(** [register_handler reg ~area ~service ~operation h] registers [h] as the
253
+
handler for the given operation. *)
254
+
255
+
val lookup_operation :
256
+
registry -> area:int -> service:int -> operation:int -> operation_def option
257
+
(** [lookup_operation reg ~area ~service ~operation] returns the operation
258
+
definition, if registered. *)
259
+
260
+
val lookup_handler :
261
+
registry -> area:int -> service:int -> operation:int -> handler option
262
+
(** [lookup_handler reg ~area ~service ~operation] returns the handler for the
263
+
given operation, if one has been registered. *)
264
+
265
+
val dispatch : registry -> header -> (header, error_code) result
266
+
(** [dispatch reg msg] routes [msg] to the registered handler based on its area,
267
+
service, and operation fields. Returns [Error Unsupported_area] if the area
268
+
is not registered, [Error Unsupported_operation] if the operation has no
269
+
handler, etc. *)
270
+
271
+
(** {1 Transport}
272
+
273
+
The abstract transport interface (CCSDS 521.0-B Section 6). A transport
274
+
binding delivers MAL messages between endpoints. *)
275
+
276
+
(** Abstract transport binding interface. *)
277
+
module type Transport = sig
278
+
type t
279
+
(** Transport state. *)
280
+
281
+
val send : t -> header -> (unit, error_code) result
282
+
(** [send t msg] transmits [msg] through the transport. *)
283
+
284
+
val recv : t -> (header, error_code) result
285
+
(** [recv t] blocks until a message arrives. *)
286
+
287
+
val close : t -> unit
288
+
(** [close t] releases transport resources. *)
289
+
end
290
+
291
+
(** {1 In-Memory Transport}
292
+
293
+
A simple in-memory transport for testing and local use. Messages are queued
294
+
between endpoints identified by URI strings. *)
295
+
296
+
module Mem_transport : sig
297
+
type t
298
+
(** In-memory transport state. *)
299
+
300
+
val create : uri -> t
301
+
(** [create uri] creates a new in-memory transport endpoint bound to [uri]. *)
302
+
303
+
val uri : t -> uri
304
+
(** [uri t] returns the URI this endpoint is bound to. *)
305
+
306
+
val send : t -> header -> (unit, error_code) result
307
+
(** [send t msg] delivers [msg] to the destination endpoint (identified by
308
+
[msg.uri_to]). Returns [Error Destination_unknown] if no endpoint is bound
309
+
to that URI. *)
310
+
311
+
val recv : t -> (header, error_code) result
312
+
(** [recv t] returns the next queued message for this endpoint, or
313
+
[Error Delivery_failed] if the queue is empty. *)
314
+
315
+
val close : t -> unit
316
+
(** [close t] removes this endpoint from the global endpoint table. *)
317
+
318
+
val reset : unit -> unit
319
+
(** [reset ()] clears all endpoints. Useful between tests. *)
320
+
end
321
+
322
+
(** {1 Interaction Helpers}
323
+
324
+
Convenience functions that implement the message flows for each interaction
325
+
pattern. *)
326
+
327
+
val make_header :
328
+
uri_from:uri ->
329
+
uri_to:uri ->
330
+
interaction_type:interaction_type ->
331
+
stage:stage ->
332
+
transaction_id:int64 ->
333
+
area:int ->
334
+
service:int ->
335
+
operation:int ->
336
+
body:blob ->
337
+
unit ->
338
+
header
339
+
(** [make_header ~uri_from ~uri_to ~interaction_type ~stage ~transaction_id
340
+
~area ~service ~operation ~body ()] creates a header with default values
341
+
for QoS, priority, domain, session, etc. *)
342
+
343
+
val next_transaction_id : unit -> int64
344
+
(** [next_transaction_id ()] returns a fresh, globally unique transaction
345
+
identifier. *)
346
+
347
+
val validate_stage : interaction_type -> stage -> bool
348
+
(** [validate_stage ip stage] returns [true] if [stage] is a valid stage for the
349
+
interaction pattern [ip]. *)
+1
test/test.ml
+1
test/test.ml
···
1
+
let () = Alcotest.run "mal" [ Test_mal.suite ]
+680
test/test_mal.ml
+680
test/test_mal.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Tests for MAL (CCSDS 521.0-B) *)
7
+
8
+
let is_infix ~affix s =
9
+
let al = String.length affix and sl = String.length s in
10
+
if al > sl then false
11
+
else
12
+
let rec loop i =
13
+
if i > sl - al then false
14
+
else if String.sub s i al = affix then true
15
+
else loop (i + 1)
16
+
in
17
+
loop 0
18
+
19
+
let error_code_testable = Alcotest.testable Mal.pp_error_code ( = )
20
+
let header_testable = Alcotest.testable Mal.pp_header ( = )
21
+
22
+
(* {1 Session and QoS roundtrips} *)
23
+
24
+
let test_session_type_roundtrip () =
25
+
List.iter
26
+
(fun s ->
27
+
let n = Mal.int_of_session_type s in
28
+
Alcotest.(check (result (of_pp Mal.pp_session_type) int))
29
+
(Fmt.str "%a" Mal.pp_session_type s)
30
+
(Ok s)
31
+
(Mal.session_type_of_int n))
32
+
[ Mal.Live; Mal.Simulation; Mal.Replay ];
33
+
Alcotest.(check (result (of_pp Mal.pp_session_type) int))
34
+
"invalid session" (Error 99)
35
+
(Mal.session_type_of_int 99)
36
+
37
+
let test_qos_roundtrip () =
38
+
List.iter
39
+
(fun q ->
40
+
let n = Mal.int_of_qos q in
41
+
Alcotest.(check (result (of_pp Mal.pp_qos) int))
42
+
(Fmt.str "%a" Mal.pp_qos q)
43
+
(Ok q) (Mal.qos_of_int n))
44
+
[ Mal.Best_effort; Mal.Assured; Mal.Queued; Mal.Timely ];
45
+
Alcotest.(check (result (of_pp Mal.pp_qos) int))
46
+
"invalid qos" (Error 0) (Mal.qos_of_int 0)
47
+
48
+
let test_interaction_type_roundtrip () =
49
+
List.iter
50
+
(fun ip ->
51
+
let n = Mal.int_of_interaction_type ip in
52
+
Alcotest.(check (result (of_pp Mal.pp_interaction_type) int))
53
+
(Fmt.str "%a" Mal.pp_interaction_type ip)
54
+
(Ok ip)
55
+
(Mal.interaction_type_of_int n))
56
+
[ Mal.Send; Mal.Submit; Mal.Request; Mal.Invoke; Mal.Progress; Mal.Pub_sub ];
57
+
Alcotest.(check (result (of_pp Mal.pp_interaction_type) int))
58
+
"invalid interaction" (Error 0)
59
+
(Mal.interaction_type_of_int 0)
60
+
61
+
(* {1 Stage validation} *)
62
+
63
+
let test_stage_validation () =
64
+
(* Send stages *)
65
+
Alcotest.(check bool)
66
+
"Send_stage is Send" true
67
+
(Mal.validate_stage Mal.Send Mal.Send_stage);
68
+
Alcotest.(check bool)
69
+
"Submit_stage is not Send" false
70
+
(Mal.validate_stage Mal.Send Mal.Submit_stage);
71
+
(* Submit stages *)
72
+
Alcotest.(check bool)
73
+
"Submit_stage is Submit" true
74
+
(Mal.validate_stage Mal.Submit Mal.Submit_stage);
75
+
Alcotest.(check bool)
76
+
"Submit_ack is Submit" true
77
+
(Mal.validate_stage Mal.Submit Mal.Submit_ack);
78
+
Alcotest.(check bool)
79
+
"Request_stage is not Submit" false
80
+
(Mal.validate_stage Mal.Submit Mal.Request_stage);
81
+
(* Request stages *)
82
+
Alcotest.(check bool)
83
+
"Request_stage is Request" true
84
+
(Mal.validate_stage Mal.Request Mal.Request_stage);
85
+
Alcotest.(check bool)
86
+
"Request_response is Request" true
87
+
(Mal.validate_stage Mal.Request Mal.Request_response);
88
+
(* Invoke stages *)
89
+
Alcotest.(check bool)
90
+
"Invoke_stage is Invoke" true
91
+
(Mal.validate_stage Mal.Invoke Mal.Invoke_stage);
92
+
Alcotest.(check bool)
93
+
"Invoke_ack is Invoke" true
94
+
(Mal.validate_stage Mal.Invoke Mal.Invoke_ack);
95
+
Alcotest.(check bool)
96
+
"Invoke_response is Invoke" true
97
+
(Mal.validate_stage Mal.Invoke Mal.Invoke_response);
98
+
(* Progress stages *)
99
+
Alcotest.(check bool)
100
+
"Progress_stage is Progress" true
101
+
(Mal.validate_stage Mal.Progress Mal.Progress_stage);
102
+
Alcotest.(check bool)
103
+
"Progress_ack is Progress" true
104
+
(Mal.validate_stage Mal.Progress Mal.Progress_ack);
105
+
Alcotest.(check bool)
106
+
"Progress_update is Progress" true
107
+
(Mal.validate_stage Mal.Progress Mal.Progress_update);
108
+
Alcotest.(check bool)
109
+
"Progress_response is Progress" true
110
+
(Mal.validate_stage Mal.Progress Mal.Progress_response);
111
+
(* Pub-Sub stages *)
112
+
Alcotest.(check bool)
113
+
"Pubsub_register is Pub_sub" true
114
+
(Mal.validate_stage Mal.Pub_sub Mal.Pubsub_register);
115
+
Alcotest.(check bool)
116
+
"Pubsub_notify is Pub_sub" true
117
+
(Mal.validate_stage Mal.Pub_sub Mal.Pubsub_notify);
118
+
Alcotest.(check bool)
119
+
"Pubsub_publish is Pub_sub" true
120
+
(Mal.validate_stage Mal.Pub_sub Mal.Pubsub_publish);
121
+
Alcotest.(check bool)
122
+
"Send_stage is not Pub_sub" false
123
+
(Mal.validate_stage Mal.Pub_sub Mal.Send_stage)
124
+
125
+
let test_interaction_type_of_stage () =
126
+
Alcotest.(check (of_pp Mal.pp_interaction_type))
127
+
"Send_stage -> Send" Mal.Send
128
+
(Mal.interaction_type_of_stage Mal.Send_stage);
129
+
Alcotest.(check (of_pp Mal.pp_interaction_type))
130
+
"Submit_ack -> Submit" Mal.Submit
131
+
(Mal.interaction_type_of_stage Mal.Submit_ack);
132
+
Alcotest.(check (of_pp Mal.pp_interaction_type))
133
+
"Request_response -> Request" Mal.Request
134
+
(Mal.interaction_type_of_stage Mal.Request_response);
135
+
Alcotest.(check (of_pp Mal.pp_interaction_type))
136
+
"Invoke_response -> Invoke" Mal.Invoke
137
+
(Mal.interaction_type_of_stage Mal.Invoke_response);
138
+
Alcotest.(check (of_pp Mal.pp_interaction_type))
139
+
"Progress_update -> Progress" Mal.Progress
140
+
(Mal.interaction_type_of_stage Mal.Progress_update);
141
+
Alcotest.(check (of_pp Mal.pp_interaction_type))
142
+
"Pubsub_notify -> Pub_sub" Mal.Pub_sub
143
+
(Mal.interaction_type_of_stage Mal.Pubsub_notify)
144
+
145
+
(* {1 Message header roundtrip} *)
146
+
147
+
let test_header_roundtrip () =
148
+
let h =
149
+
Mal.make_header ~uri_from:"mal:provider/1" ~uri_to:"mal:consumer/2"
150
+
~interaction_type:Mal.Request ~stage:Mal.Request_stage ~transaction_id:42L
151
+
~area:1 ~service:2 ~operation:3 ~body:"hello" ()
152
+
in
153
+
Alcotest.(check string) "uri_from" "mal:provider/1" h.uri_from;
154
+
Alcotest.(check string) "uri_to" "mal:consumer/2" h.uri_to;
155
+
Alcotest.(check (of_pp Mal.pp_interaction_type))
156
+
"interaction" Mal.Request h.interaction_type;
157
+
Alcotest.(check (of_pp Mal.pp_stage)) "stage" Mal.Request_stage h.stage;
158
+
Alcotest.(check int64) "transaction_id" 42L h.transaction_id;
159
+
Alcotest.(check int) "area" 1 h.area;
160
+
Alcotest.(check int) "service" 2 h.service;
161
+
Alcotest.(check int) "operation" 3 h.operation;
162
+
Alcotest.(check string) "body" "hello" h.body;
163
+
Alcotest.(check bool) "is_error" false h.is_error;
164
+
(* Pretty-print should contain key fields *)
165
+
let s = Fmt.str "%a" Mal.pp_header h in
166
+
Alcotest.(check bool)
167
+
"pp contains from" true
168
+
(String.length s > 0 && is_infix ~affix:"mal:provider/1" s);
169
+
Alcotest.(check bool) "pp contains REQUEST" true (is_infix ~affix:"REQUEST" s)
170
+
171
+
let test_header_equality () =
172
+
let h1 =
173
+
Mal.make_header ~uri_from:"mal:a" ~uri_to:"mal:b" ~interaction_type:Mal.Send
174
+
~stage:Mal.Send_stage ~transaction_id:1L ~area:1 ~service:1 ~operation:1
175
+
~body:"" ()
176
+
in
177
+
let h2 =
178
+
Mal.make_header ~uri_from:"mal:a" ~uri_to:"mal:b" ~interaction_type:Mal.Send
179
+
~stage:Mal.Send_stage ~transaction_id:1L ~area:1 ~service:1 ~operation:1
180
+
~body:"" ()
181
+
in
182
+
Alcotest.(check header_testable) "identical headers" h1 h2
183
+
184
+
(* {1 Send interaction} *)
185
+
186
+
let test_send_pattern () =
187
+
Mal.Mem_transport.reset ();
188
+
let consumer = Mal.Mem_transport.create "mal:consumer" in
189
+
let provider = Mal.Mem_transport.create "mal:provider" in
190
+
let msg =
191
+
Mal.make_header ~uri_from:"mal:provider" ~uri_to:"mal:consumer"
192
+
~interaction_type:Mal.Send ~stage:Mal.Send_stage ~transaction_id:1L
193
+
~area:1 ~service:1 ~operation:1 ~body:"fire-and-forget" ()
194
+
in
195
+
(* Provider sends, consumer receives *)
196
+
Alcotest.(check (result unit error_code_testable))
197
+
"send ok" (Ok ())
198
+
(Mal.Mem_transport.send provider msg);
199
+
match Mal.Mem_transport.recv consumer with
200
+
| Ok received ->
201
+
Alcotest.(check string) "body" "fire-and-forget" received.body;
202
+
Alcotest.(check (of_pp Mal.pp_stage))
203
+
"stage" Mal.Send_stage received.stage
204
+
| Error e -> Alcotest.failf "recv failed: %a" Mal.pp_error_code e
205
+
206
+
(* {1 Submit interaction} *)
207
+
208
+
let test_submit_pattern () =
209
+
Mal.Mem_transport.reset ();
210
+
let consumer = Mal.Mem_transport.create "mal:consumer" in
211
+
let provider = Mal.Mem_transport.create "mal:provider" in
212
+
let tid = Mal.next_transaction_id () in
213
+
(* Consumer submits *)
214
+
let submit =
215
+
Mal.make_header ~uri_from:"mal:consumer" ~uri_to:"mal:provider"
216
+
~interaction_type:Mal.Submit ~stage:Mal.Submit_stage ~transaction_id:tid
217
+
~area:1 ~service:1 ~operation:1 ~body:"submit-request" ()
218
+
in
219
+
Alcotest.(check (result unit error_code_testable))
220
+
"submit ok" (Ok ())
221
+
(Mal.Mem_transport.send consumer submit);
222
+
(* Provider receives and sends ACK *)
223
+
let received =
224
+
match Mal.Mem_transport.recv provider with
225
+
| Ok h -> h
226
+
| Error e -> Alcotest.failf "recv failed: %a" Mal.pp_error_code e
227
+
in
228
+
Alcotest.(check (of_pp Mal.pp_stage))
229
+
"received stage" Mal.Submit_stage received.stage;
230
+
let ack =
231
+
Mal.make_header ~uri_from:"mal:provider" ~uri_to:"mal:consumer"
232
+
~interaction_type:Mal.Submit ~stage:Mal.Submit_ack ~transaction_id:tid
233
+
~area:1 ~service:1 ~operation:1 ~body:"" ()
234
+
in
235
+
Alcotest.(check (result unit error_code_testable))
236
+
"ack ok" (Ok ())
237
+
(Mal.Mem_transport.send provider ack);
238
+
(* Consumer receives ACK *)
239
+
let ack_received =
240
+
match Mal.Mem_transport.recv consumer with
241
+
| Ok h -> h
242
+
| Error e -> Alcotest.failf "recv ack failed: %a" Mal.pp_error_code e
243
+
in
244
+
Alcotest.(check (of_pp Mal.pp_stage))
245
+
"ack stage" Mal.Submit_ack ack_received.stage;
246
+
Alcotest.(check int64) "ack tid" tid ack_received.transaction_id
247
+
248
+
(* {1 Request interaction} *)
249
+
250
+
let test_request_pattern () =
251
+
Mal.Mem_transport.reset ();
252
+
let consumer = Mal.Mem_transport.create "mal:consumer" in
253
+
let provider = Mal.Mem_transport.create "mal:provider" in
254
+
let tid = Mal.next_transaction_id () in
255
+
(* Consumer sends request *)
256
+
let req =
257
+
Mal.make_header ~uri_from:"mal:consumer" ~uri_to:"mal:provider"
258
+
~interaction_type:Mal.Request ~stage:Mal.Request_stage ~transaction_id:tid
259
+
~area:2 ~service:1 ~operation:1 ~body:"get-something" ()
260
+
in
261
+
Alcotest.(check (result unit error_code_testable))
262
+
"request ok" (Ok ())
263
+
(Mal.Mem_transport.send consumer req);
264
+
(* Provider receives and sends response *)
265
+
let _received =
266
+
match Mal.Mem_transport.recv provider with
267
+
| Ok h -> h
268
+
| Error e -> Alcotest.failf "recv failed: %a" Mal.pp_error_code e
269
+
in
270
+
let resp =
271
+
Mal.make_header ~uri_from:"mal:provider" ~uri_to:"mal:consumer"
272
+
~interaction_type:Mal.Request ~stage:Mal.Request_response
273
+
~transaction_id:tid ~area:2 ~service:1 ~operation:1 ~body:"here-it-is" ()
274
+
in
275
+
Alcotest.(check (result unit error_code_testable))
276
+
"response ok" (Ok ())
277
+
(Mal.Mem_transport.send provider resp);
278
+
(* Consumer receives response *)
279
+
let resp_received =
280
+
match Mal.Mem_transport.recv consumer with
281
+
| Ok h -> h
282
+
| Error e -> Alcotest.failf "recv response failed: %a" Mal.pp_error_code e
283
+
in
284
+
Alcotest.(check (of_pp Mal.pp_stage))
285
+
"response stage" Mal.Request_response resp_received.stage;
286
+
Alcotest.(check string) "response body" "here-it-is" resp_received.body;
287
+
Alcotest.(check int64) "response tid" tid resp_received.transaction_id
288
+
289
+
(* {1 Invoke interaction} *)
290
+
291
+
let test_invoke_pattern () =
292
+
Mal.Mem_transport.reset ();
293
+
let consumer = Mal.Mem_transport.create "mal:consumer" in
294
+
let provider = Mal.Mem_transport.create "mal:provider" in
295
+
let tid = Mal.next_transaction_id () in
296
+
let mk stage body =
297
+
Mal.make_header ~uri_from:"mal:consumer" ~uri_to:"mal:provider"
298
+
~interaction_type:Mal.Invoke ~stage ~transaction_id:tid ~area:1 ~service:1
299
+
~operation:1 ~body ()
300
+
in
301
+
let mk_resp stage body =
302
+
Mal.make_header ~uri_from:"mal:provider" ~uri_to:"mal:consumer"
303
+
~interaction_type:Mal.Invoke ~stage ~transaction_id:tid ~area:1 ~service:1
304
+
~operation:1 ~body ()
305
+
in
306
+
(* Consumer invokes *)
307
+
Alcotest.(check (result unit error_code_testable))
308
+
"invoke ok" (Ok ())
309
+
(Mal.Mem_transport.send consumer (mk Mal.Invoke_stage "invoke-request"));
310
+
let _ = Mal.Mem_transport.recv provider in
311
+
(* Provider sends ACK *)
312
+
Alcotest.(check (result unit error_code_testable))
313
+
"ack ok" (Ok ())
314
+
(Mal.Mem_transport.send provider (mk_resp Mal.Invoke_ack ""));
315
+
let ack =
316
+
match Mal.Mem_transport.recv consumer with
317
+
| Ok h -> h
318
+
| Error e -> Alcotest.failf "recv ack failed: %a" Mal.pp_error_code e
319
+
in
320
+
Alcotest.(check (of_pp Mal.pp_stage)) "ack stage" Mal.Invoke_ack ack.stage;
321
+
(* Provider sends response *)
322
+
Alcotest.(check (result unit error_code_testable))
323
+
"response ok" (Ok ())
324
+
(Mal.Mem_transport.send provider
325
+
(mk_resp Mal.Invoke_response "invoke-result"));
326
+
let resp =
327
+
match Mal.Mem_transport.recv consumer with
328
+
| Ok h -> h
329
+
| Error e -> Alcotest.failf "recv response failed: %a" Mal.pp_error_code e
330
+
in
331
+
Alcotest.(check (of_pp Mal.pp_stage))
332
+
"response stage" Mal.Invoke_response resp.stage;
333
+
Alcotest.(check string) "response body" "invoke-result" resp.body
334
+
335
+
(* {1 Progress interaction} *)
336
+
337
+
let test_progress_pattern () =
338
+
Mal.Mem_transport.reset ();
339
+
let consumer = Mal.Mem_transport.create "mal:consumer" in
340
+
let provider = Mal.Mem_transport.create "mal:provider" in
341
+
let tid = Mal.next_transaction_id () in
342
+
let mk_consumer stage body =
343
+
Mal.make_header ~uri_from:"mal:consumer" ~uri_to:"mal:provider"
344
+
~interaction_type:Mal.Progress ~stage ~transaction_id:tid ~area:1
345
+
~service:1 ~operation:1 ~body ()
346
+
in
347
+
let mk_provider stage body =
348
+
Mal.make_header ~uri_from:"mal:provider" ~uri_to:"mal:consumer"
349
+
~interaction_type:Mal.Progress ~stage ~transaction_id:tid ~area:1
350
+
~service:1 ~operation:1 ~body ()
351
+
in
352
+
(* Consumer initiates progress *)
353
+
Alcotest.(check (result unit error_code_testable))
354
+
"progress ok" (Ok ())
355
+
(Mal.Mem_transport.send consumer
356
+
(mk_consumer Mal.Progress_stage "start-task"));
357
+
let _ = Mal.Mem_transport.recv provider in
358
+
(* Provider sends ACK *)
359
+
Alcotest.(check (result unit error_code_testable))
360
+
"ack ok" (Ok ())
361
+
(Mal.Mem_transport.send provider (mk_provider Mal.Progress_ack ""));
362
+
let _ = Mal.Mem_transport.recv consumer in
363
+
(* Provider sends 3 updates *)
364
+
for i = 1 to 3 do
365
+
Alcotest.(check (result unit error_code_testable))
366
+
(Fmt.str "update %d ok" i) (Ok ())
367
+
(Mal.Mem_transport.send provider
368
+
(mk_provider Mal.Progress_update (Fmt.str "update-%d" i)))
369
+
done;
370
+
(* Consumer reads all 3 updates *)
371
+
for i = 1 to 3 do
372
+
let update =
373
+
match Mal.Mem_transport.recv consumer with
374
+
| Ok h -> h
375
+
| Error e ->
376
+
Alcotest.failf "recv update %d failed: %a" i Mal.pp_error_code e
377
+
in
378
+
Alcotest.(check (of_pp Mal.pp_stage))
379
+
(Fmt.str "update %d stage" i)
380
+
Mal.Progress_update update.stage;
381
+
Alcotest.(check string)
382
+
(Fmt.str "update %d body" i)
383
+
(Fmt.str "update-%d" i) update.body
384
+
done;
385
+
(* Provider sends final response *)
386
+
Alcotest.(check (result unit error_code_testable))
387
+
"response ok" (Ok ())
388
+
(Mal.Mem_transport.send provider (mk_provider Mal.Progress_response "done"));
389
+
let resp =
390
+
match Mal.Mem_transport.recv consumer with
391
+
| Ok h -> h
392
+
| Error e -> Alcotest.failf "recv response failed: %a" Mal.pp_error_code e
393
+
in
394
+
Alcotest.(check (of_pp Mal.pp_stage))
395
+
"response stage" Mal.Progress_response resp.stage;
396
+
Alcotest.(check string) "response body" "done" resp.body
397
+
398
+
(* {1 Pub-Sub interaction} *)
399
+
400
+
let test_pubsub_pattern () =
401
+
Mal.Mem_transport.reset ();
402
+
let subscriber = Mal.Mem_transport.create "mal:subscriber" in
403
+
let broker = Mal.Mem_transport.create "mal:broker" in
404
+
let publisher = Mal.Mem_transport.create "mal:publisher" in
405
+
let tid_sub = Mal.next_transaction_id () in
406
+
let tid_pub = Mal.next_transaction_id () in
407
+
let mk from_uri to_uri stage tid body =
408
+
Mal.make_header ~uri_from:from_uri ~uri_to:to_uri
409
+
~interaction_type:Mal.Pub_sub ~stage ~transaction_id:tid ~area:1
410
+
~service:1 ~operation:1 ~body ()
411
+
in
412
+
(* Subscriber registers *)
413
+
Alcotest.(check (result unit error_code_testable))
414
+
"register ok" (Ok ())
415
+
(Mal.Mem_transport.send subscriber
416
+
(mk "mal:subscriber" "mal:broker" Mal.Pubsub_register tid_sub "topic-A"));
417
+
let _ = Mal.Mem_transport.recv broker in
418
+
Alcotest.(check (result unit error_code_testable))
419
+
"register ack ok" (Ok ())
420
+
(Mal.Mem_transport.send broker
421
+
(mk "mal:broker" "mal:subscriber" Mal.Pubsub_register_ack tid_sub ""));
422
+
let reg_ack =
423
+
match Mal.Mem_transport.recv subscriber with
424
+
| Ok h -> h
425
+
| Error e ->
426
+
Alcotest.failf "recv register ack failed: %a" Mal.pp_error_code e
427
+
in
428
+
Alcotest.(check (of_pp Mal.pp_stage))
429
+
"register ack stage" Mal.Pubsub_register_ack reg_ack.stage;
430
+
(* Publisher registers *)
431
+
Alcotest.(check (result unit error_code_testable))
432
+
"publish register ok" (Ok ())
433
+
(Mal.Mem_transport.send publisher
434
+
(mk "mal:publisher" "mal:broker" Mal.Pubsub_publish_register tid_pub
435
+
"topic-A"));
436
+
let _ = Mal.Mem_transport.recv broker in
437
+
Alcotest.(check (result unit error_code_testable))
438
+
"publish register ack ok" (Ok ())
439
+
(Mal.Mem_transport.send broker
440
+
(mk "mal:broker" "mal:publisher" Mal.Pubsub_publish_register_ack tid_pub
441
+
""));
442
+
let _ = Mal.Mem_transport.recv publisher in
443
+
(* Publisher publishes, broker notifies subscriber *)
444
+
Alcotest.(check (result unit error_code_testable))
445
+
"publish ok" (Ok ())
446
+
(Mal.Mem_transport.send publisher
447
+
(mk "mal:publisher" "mal:broker" Mal.Pubsub_publish tid_pub "event-data"));
448
+
let _ = Mal.Mem_transport.recv broker in
449
+
Alcotest.(check (result unit error_code_testable))
450
+
"notify ok" (Ok ())
451
+
(Mal.Mem_transport.send broker
452
+
(mk "mal:broker" "mal:subscriber" Mal.Pubsub_notify tid_sub "event-data"));
453
+
let notification =
454
+
match Mal.Mem_transport.recv subscriber with
455
+
| Ok h -> h
456
+
| Error e -> Alcotest.failf "recv notify failed: %a" Mal.pp_error_code e
457
+
in
458
+
Alcotest.(check (of_pp Mal.pp_stage))
459
+
"notify stage" Mal.Pubsub_notify notification.stage;
460
+
Alcotest.(check string) "notify body" "event-data" notification.body;
461
+
(* Subscriber deregisters *)
462
+
Alcotest.(check (result unit error_code_testable))
463
+
"deregister ok" (Ok ())
464
+
(Mal.Mem_transport.send subscriber
465
+
(mk "mal:subscriber" "mal:broker" Mal.Pubsub_deregister tid_sub ""));
466
+
let _ = Mal.Mem_transport.recv broker in
467
+
Alcotest.(check (result unit error_code_testable))
468
+
"deregister ack ok" (Ok ())
469
+
(Mal.Mem_transport.send broker
470
+
(mk "mal:broker" "mal:subscriber" Mal.Pubsub_deregister_ack tid_sub ""));
471
+
let dereg =
472
+
match Mal.Mem_transport.recv subscriber with
473
+
| Ok h -> h
474
+
| Error e ->
475
+
Alcotest.failf "recv deregister ack failed: %a" Mal.pp_error_code e
476
+
in
477
+
Alcotest.(check (of_pp Mal.pp_stage))
478
+
"deregister ack stage" Mal.Pubsub_deregister_ack dereg.stage
479
+
480
+
(* {1 Service registration and dispatch} *)
481
+
482
+
let test_service_registration () =
483
+
let reg = Mal.create_registry () in
484
+
let area =
485
+
{
486
+
Mal.area_name = "COM";
487
+
area_number = 2;
488
+
area_version = 1;
489
+
area_services =
490
+
[
491
+
{
492
+
Mal.svc_name = "EventService";
493
+
svc_number = 1;
494
+
svc_operations =
495
+
[
496
+
{
497
+
Mal.op_name = "monitorValue";
498
+
op_number = 1;
499
+
op_interaction = Mal.Pub_sub;
500
+
};
501
+
{
502
+
Mal.op_name = "enableGeneration";
503
+
op_number = 2;
504
+
op_interaction = Mal.Request;
505
+
};
506
+
];
507
+
};
508
+
];
509
+
}
510
+
in
511
+
Mal.register_area reg area;
512
+
(* Lookup registered operation *)
513
+
let op = Mal.lookup_operation reg ~area:2 ~service:1 ~operation:1 in
514
+
Alcotest.(check bool) "operation found" true (Option.is_some op);
515
+
let op = Option.get op in
516
+
Alcotest.(check string) "op_name" "monitorValue" op.op_name;
517
+
Alcotest.(check (of_pp Mal.pp_interaction_type))
518
+
"op_interaction" Mal.Pub_sub op.op_interaction;
519
+
(* Lookup unregistered operation *)
520
+
let missing = Mal.lookup_operation reg ~area:2 ~service:1 ~operation:99 in
521
+
Alcotest.(check bool) "missing operation" true (Option.is_none missing);
522
+
(* Pretty-print check *)
523
+
let s = Fmt.str "%a" Mal.pp_area_def area in
524
+
Alcotest.(check bool) "pp contains COM" true (is_infix ~affix:"COM" s);
525
+
Alcotest.(check bool)
526
+
"pp contains EventService" true
527
+
(is_infix ~affix:"EventService" s)
528
+
529
+
let test_dispatch () =
530
+
let reg = Mal.create_registry () in
531
+
let area =
532
+
{
533
+
Mal.area_name = "MC";
534
+
area_number = 4;
535
+
area_version = 1;
536
+
area_services =
537
+
[
538
+
{
539
+
Mal.svc_name = "ParameterService";
540
+
svc_number = 1;
541
+
svc_operations =
542
+
[
543
+
{
544
+
Mal.op_name = "getValue";
545
+
op_number = 1;
546
+
op_interaction = Mal.Request;
547
+
};
548
+
];
549
+
};
550
+
];
551
+
}
552
+
in
553
+
Mal.register_area reg area;
554
+
(* Register a handler *)
555
+
let handler msg =
556
+
Ok
557
+
{
558
+
msg with
559
+
Mal.uri_from = msg.Mal.uri_to;
560
+
Mal.uri_to = msg.Mal.uri_from;
561
+
Mal.stage = Mal.Request_response;
562
+
Mal.body = "value=42";
563
+
}
564
+
in
565
+
Mal.register_handler reg ~area:4 ~service:1 ~operation:1 handler;
566
+
(* Dispatch a message *)
567
+
let req =
568
+
Mal.make_header ~uri_from:"mal:consumer" ~uri_to:"mal:provider"
569
+
~interaction_type:Mal.Request ~stage:Mal.Request_stage
570
+
~transaction_id:100L ~area:4 ~service:1 ~operation:1 ~body:"get-param" ()
571
+
in
572
+
let result = Mal.dispatch reg req in
573
+
(match result with
574
+
| Ok resp ->
575
+
Alcotest.(check string) "response body" "value=42" resp.body;
576
+
Alcotest.(check (of_pp Mal.pp_stage))
577
+
"response stage" Mal.Request_response resp.stage;
578
+
Alcotest.(check string) "response from" "mal:provider" resp.uri_from;
579
+
Alcotest.(check string) "response to" "mal:consumer" resp.uri_to
580
+
| Error e -> Alcotest.failf "dispatch failed: %a" Mal.pp_error_code e);
581
+
(* Dispatch to unknown area *)
582
+
let bad_area =
583
+
Mal.make_header ~uri_from:"mal:c" ~uri_to:"mal:p"
584
+
~interaction_type:Mal.Request ~stage:Mal.Request_stage
585
+
~transaction_id:101L ~area:99 ~service:1 ~operation:1 ~body:"" ()
586
+
in
587
+
Alcotest.(check (result header_testable error_code_testable))
588
+
"unknown area" (Error Mal.Unsupported_area)
589
+
(Mal.dispatch reg bad_area);
590
+
(* Dispatch to unknown service *)
591
+
let bad_svc =
592
+
Mal.make_header ~uri_from:"mal:c" ~uri_to:"mal:p"
593
+
~interaction_type:Mal.Request ~stage:Mal.Request_stage
594
+
~transaction_id:102L ~area:4 ~service:99 ~operation:1 ~body:"" ()
595
+
in
596
+
Alcotest.(check (result header_testable error_code_testable))
597
+
"unknown service" (Error Mal.Unsupported_service) (Mal.dispatch reg bad_svc);
598
+
(* Dispatch to unhandled operation *)
599
+
let bad_op =
600
+
Mal.make_header ~uri_from:"mal:c" ~uri_to:"mal:p"
601
+
~interaction_type:Mal.Request ~stage:Mal.Request_stage
602
+
~transaction_id:103L ~area:4 ~service:1 ~operation:99 ~body:"" ()
603
+
in
604
+
Alcotest.(check (result header_testable error_code_testable))
605
+
"unhandled operation" (Error Mal.Unsupported_operation)
606
+
(Mal.dispatch reg bad_op)
607
+
608
+
(* {1 Mem_transport edge cases} *)
609
+
610
+
let test_mem_transport_unknown_dest () =
611
+
Mal.Mem_transport.reset ();
612
+
let sender = Mal.Mem_transport.create "mal:sender" in
613
+
let msg =
614
+
Mal.make_header ~uri_from:"mal:sender" ~uri_to:"mal:nonexistent"
615
+
~interaction_type:Mal.Send ~stage:Mal.Send_stage ~transaction_id:1L
616
+
~area:1 ~service:1 ~operation:1 ~body:"" ()
617
+
in
618
+
Alcotest.(check (result unit error_code_testable))
619
+
"unknown dest" (Error Mal.Destination_unknown)
620
+
(Mal.Mem_transport.send sender msg)
621
+
622
+
let test_mem_transport_empty_recv () =
623
+
Mal.Mem_transport.reset ();
624
+
let ep = Mal.Mem_transport.create "mal:empty" in
625
+
Alcotest.(check (result header_testable error_code_testable))
626
+
"empty recv" (Error Mal.Delivery_failed)
627
+
(Mal.Mem_transport.recv ep)
628
+
629
+
let test_mem_transport_close () =
630
+
Mal.Mem_transport.reset ();
631
+
let ep = Mal.Mem_transport.create "mal:closing" in
632
+
let sender = Mal.Mem_transport.create "mal:sender2" in
633
+
Mal.Mem_transport.close ep;
634
+
let msg =
635
+
Mal.make_header ~uri_from:"mal:sender2" ~uri_to:"mal:closing"
636
+
~interaction_type:Mal.Send ~stage:Mal.Send_stage ~transaction_id:1L
637
+
~area:1 ~service:1 ~operation:1 ~body:"" ()
638
+
in
639
+
Alcotest.(check (result unit error_code_testable))
640
+
"send to closed" (Error Mal.Destination_unknown)
641
+
(Mal.Mem_transport.send sender msg)
642
+
643
+
let test_transaction_id_uniqueness () =
644
+
let id1 = Mal.next_transaction_id () in
645
+
let id2 = Mal.next_transaction_id () in
646
+
let id3 = Mal.next_transaction_id () in
647
+
Alcotest.(check bool) "id1 <> id2" true (id1 <> id2);
648
+
Alcotest.(check bool) "id2 <> id3" true (id2 <> id3);
649
+
Alcotest.(check bool) "id1 < id3" true (id1 < id3)
650
+
651
+
(* {1 Test suite} *)
652
+
653
+
let suite =
654
+
( "mal",
655
+
[
656
+
Alcotest.test_case "session type roundtrip" `Quick
657
+
test_session_type_roundtrip;
658
+
Alcotest.test_case "qos roundtrip" `Quick test_qos_roundtrip;
659
+
Alcotest.test_case "interaction type roundtrip" `Quick
660
+
test_interaction_type_roundtrip;
661
+
Alcotest.test_case "stage validation" `Quick test_stage_validation;
662
+
Alcotest.test_case "interaction type of stage" `Quick
663
+
test_interaction_type_of_stage;
664
+
Alcotest.test_case "header roundtrip" `Quick test_header_roundtrip;
665
+
Alcotest.test_case "header equality" `Quick test_header_equality;
666
+
Alcotest.test_case "send pattern" `Quick test_send_pattern;
667
+
Alcotest.test_case "submit pattern" `Quick test_submit_pattern;
668
+
Alcotest.test_case "request pattern" `Quick test_request_pattern;
669
+
Alcotest.test_case "invoke pattern" `Quick test_invoke_pattern;
670
+
Alcotest.test_case "progress pattern" `Quick test_progress_pattern;
671
+
Alcotest.test_case "pub-sub pattern" `Quick test_pubsub_pattern;
672
+
Alcotest.test_case "service registration" `Quick test_service_registration;
673
+
Alcotest.test_case "dispatch" `Quick test_dispatch;
674
+
Alcotest.test_case "unknown destination" `Quick
675
+
test_mem_transport_unknown_dest;
676
+
Alcotest.test_case "empty recv" `Quick test_mem_transport_empty_recv;
677
+
Alcotest.test_case "close endpoint" `Quick test_mem_transport_close;
678
+
Alcotest.test_case "transaction id uniqueness" `Quick
679
+
test_transaction_id_uniqueness;
680
+
] )