CCSDS Space Data Link Security (355.0-B-2)
Port remaining borealis libraries to monorepo
New packages:
- ocaml-fsr: Frame Security Report (Wire codec for 32-bit FSR word)
- ocaml-hkdf: HMAC-based Key Derivation (RFC 5869)
- ocaml-ccsds-time: CCSDS time formats (CUC, CDS) with Wire codecs
- ocaml-transport: CLTU/ASM framing and COP-1 state machine
- ocaml-chunk: Zstd compression and application-layer chunking
- ocaml-sdls: Space Data Link Security (AES-GCM/CCM/CMAC frame
protection, SA management, key lifecycle, EP/MC protocols)
All binary protocol headers use Wire codecs. Dependencies on
borealis Binary module replaced with Bytesrw or Wire. Uses
ocaml-crypto instead of mirage-crypto.
+7210
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version = 0.28.1
+20
dune-project
+20
dune-project
···
1
+
(lang dune 3.21)
2
+
(name sdls)
3
+
(generate_opam_files true)
4
+
(license ISC)
5
+
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
6
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
7
+
(source (tangled gazagnaire.org/ocaml-sdls))
8
+
(package
9
+
(name sdls)
10
+
(synopsis "CCSDS Space Data Link Security (355.0-B-2)")
11
+
(depends
12
+
(ocaml (>= 5.1))
13
+
(crypto (>= 0.1))
14
+
(fmt (>= 0.9))
15
+
(logs (>= 0.7))
16
+
(digestif (>= 1.0))
17
+
(eqaf (>= 0.9))
18
+
(bitv (>= 1.0))
19
+
(wire (>= 0.9))
20
+
(alcotest :with-test)))
+136
lib/binary.ml
+136
lib/binary.ml
···
1
+
(** Minimal binary reader/writer for SDLS protocol headers.
2
+
3
+
Provides sequential reading and writing of integers and byte sequences. This
4
+
is a self-contained replacement for the borealis Binary module, without the
5
+
bytesrw dependency. *)
6
+
7
+
(* {1 Reader} *)
8
+
9
+
module Reader = struct
10
+
type t = { buf : bytes; mutable pos : int; len : int }
11
+
12
+
let of_bytes ?(off = 0) buf = { buf; pos = off; len = Bytes.length buf }
13
+
let of_string s = of_bytes (Bytes.of_string s)
14
+
let pos r = r.pos
15
+
let length r = r.len
16
+
let remaining r = r.len - r.pos
17
+
let at_end r = r.pos >= r.len
18
+
19
+
let seek r n =
20
+
if n >= 0 && n <= r.len then r.pos <- n
21
+
else invalid_arg "Binary.Reader.seek: out of bounds"
22
+
23
+
type truncated = { need : int; have : int }
24
+
25
+
let ensure r n =
26
+
if remaining r >= n then Ok ()
27
+
else Error (`Truncated { need = n; have = remaining r })
28
+
29
+
let uint8 r =
30
+
let v = Bytes.get_uint8 r.buf r.pos in
31
+
r.pos <- r.pos + 1;
32
+
v
33
+
34
+
let uint16_be r =
35
+
let v = Bytes.get_uint16_be r.buf r.pos in
36
+
r.pos <- r.pos + 2;
37
+
v
38
+
39
+
let uint32_be r =
40
+
let v = Bytes.get_int32_be r.buf r.pos in
41
+
r.pos <- r.pos + 4;
42
+
Int32.to_int v
43
+
44
+
let uint64_be r =
45
+
let v = Bytes.get_int64_be r.buf r.pos in
46
+
r.pos <- r.pos + 8;
47
+
v
48
+
49
+
let bytes r n =
50
+
let b = Bytes.sub r.buf r.pos n in
51
+
r.pos <- r.pos + n;
52
+
b
53
+
54
+
let rest r =
55
+
let n = remaining r in
56
+
bytes r n
57
+
58
+
let try_uint8 r =
59
+
match ensure r 1 with
60
+
| Error (`Truncated t) -> Error (`Truncated t)
61
+
| Ok () -> Ok (uint8 r)
62
+
63
+
let try_uint16_be r =
64
+
match ensure r 2 with
65
+
| Error (`Truncated t) -> Error (`Truncated t)
66
+
| Ok () -> Ok (uint16_be r)
67
+
68
+
let try_uint32_be r =
69
+
match ensure r 4 with
70
+
| Error (`Truncated t) -> Error (`Truncated t)
71
+
| Ok () -> Ok (uint32_be r)
72
+
73
+
let try_uint64_be r =
74
+
match ensure r 8 with
75
+
| Error (`Truncated t) -> Error (`Truncated t)
76
+
| Ok () -> Ok (uint64_be r)
77
+
78
+
let try_bytes r n =
79
+
match ensure r n with
80
+
| Error (`Truncated t) -> Error (`Truncated t)
81
+
| Ok () -> Ok (bytes r n)
82
+
end
83
+
84
+
(* {1 Writer} *)
85
+
86
+
module Writer = struct
87
+
type t = { mutable buf : bytes; mutable pos : int }
88
+
89
+
let create n = { buf = Bytes.create (max n 16); pos = 0 }
90
+
91
+
let grow w need =
92
+
let old_len = Bytes.length w.buf in
93
+
let new_len = ref old_len in
94
+
while !new_len < w.pos + need do
95
+
new_len := !new_len * 2
96
+
done;
97
+
if !new_len > old_len then begin
98
+
let buf = Bytes.create !new_len in
99
+
Bytes.blit w.buf 0 buf 0 w.pos;
100
+
w.buf <- buf
101
+
end
102
+
103
+
let uint8 w v =
104
+
grow w 1;
105
+
Bytes.set_uint8 w.buf w.pos v;
106
+
w.pos <- w.pos + 1
107
+
108
+
let uint16_be w v =
109
+
grow w 2;
110
+
Bytes.set_uint16_be w.buf w.pos v;
111
+
w.pos <- w.pos + 2
112
+
113
+
let uint32_be w v =
114
+
grow w 4;
115
+
Bytes.set_int32_be w.buf w.pos (Int32.of_int v);
116
+
w.pos <- w.pos + 4
117
+
118
+
let uint64_be w v =
119
+
grow w 8;
120
+
Bytes.set_int64_be w.buf w.pos v;
121
+
w.pos <- w.pos + 8
122
+
123
+
let bytes w b =
124
+
let n = Bytes.length b in
125
+
grow w n;
126
+
Bytes.blit b 0 w.buf w.pos n;
127
+
w.pos <- w.pos + n
128
+
129
+
let string w s =
130
+
let n = String.length s in
131
+
grow w n;
132
+
Bytes.blit_string s 0 w.buf w.pos n;
133
+
w.pos <- w.pos + n
134
+
135
+
let contents w = Bytes.sub w.buf 0 w.pos
136
+
end
+377
lib/cbor.ml
+377
lib/cbor.ml
···
1
+
(** Minimal CBOR codec (RFC 8949).
2
+
3
+
{b Encoding format}
4
+
{v
5
+
Initial byte: [major_type (3 bits) | additional_info (5 bits)]
6
+
7
+
Major types:
8
+
0 = unsigned int 4 = array
9
+
1 = negative int 5 = map
10
+
2 = byte string 6 = tag
11
+
3 = text string 7 = simple/float
12
+
13
+
Additional info:
14
+
0-23 = value literal
15
+
24 = 1-byte uint follows
16
+
25 = 2-byte uint follows (big-endian)
17
+
26 = 4-byte uint follows (big-endian)
18
+
27 = 8-byte uint follows (big-endian)
19
+
31 = indefinite length (arrays/maps/strings)
20
+
0xff = break (ends indefinite item)
21
+
v} *)
22
+
23
+
open Binary
24
+
25
+
(* {1 Types} *)
26
+
27
+
type t =
28
+
| Uint of int64
29
+
| Bytes of bytes
30
+
| Text of string
31
+
| Array of t list
32
+
| Iarray of t list
33
+
| Map of (t * t) list
34
+
| Tag of int * t
35
+
| False
36
+
| True
37
+
| Null
38
+
| Undefined
39
+
40
+
type error =
41
+
| Truncated of { need : int; have : int }
42
+
| Invalid_initial_byte of int
43
+
| Unsupported_type of string
44
+
| Invalid_utf8
45
+
| Unexpected_break
46
+
| Missing_break
47
+
| Depth_limit_exceeded of int
48
+
| Items_limit_exceeded of int
49
+
50
+
let pp_error fmt = function
51
+
| Truncated { need; have } ->
52
+
Format.fprintf fmt "truncated: need %d bytes, have %d" need have
53
+
| Invalid_initial_byte b ->
54
+
Format.fprintf fmt "invalid initial byte: 0x%02X" b
55
+
| Unsupported_type s -> Format.fprintf fmt "unsupported type: %s" s
56
+
| Invalid_utf8 -> Format.fprintf fmt "invalid UTF-8 in text string"
57
+
| Unexpected_break -> Format.fprintf fmt "unexpected break (0xff)"
58
+
| Missing_break -> Format.fprintf fmt "missing break in indefinite item"
59
+
| Depth_limit_exceeded d -> Format.fprintf fmt "depth limit exceeded: %d" d
60
+
| Items_limit_exceeded n -> Format.fprintf fmt "items limit exceeded: %d" n
61
+
62
+
type limits = { max_depth : int; max_items : int }
63
+
64
+
let default_limits = { max_depth = 128; max_items = 65536 }
65
+
66
+
(* {1 Constants} *)
67
+
68
+
let major_uint = 0
69
+
let major_bytes = 2
70
+
let major_text = 3
71
+
let major_array = 4
72
+
let major_map = 5
73
+
let major_tag = 6
74
+
let major_simple = 7
75
+
let simple_false = 20
76
+
let simple_true = 21
77
+
let simple_null = 22
78
+
let simple_undefined = 23
79
+
let break_byte = 0xff
80
+
81
+
(* {1 Encoding} *)
82
+
83
+
let ( << ) a b = Int64.unsigned_compare a b < 0
84
+
85
+
let arg_len n =
86
+
if n << 24L then 0
87
+
else if n << 0x100L then 1
88
+
else if n << 0x10000L then 2
89
+
else if n << 0x100000000L then 4
90
+
else 8
91
+
92
+
let head_len arg = 1 + arg_len arg
93
+
94
+
let rec encoded_len = function
95
+
| Uint n -> head_len n
96
+
| Bytes b -> head_len (Int64.of_int (Bytes.length b)) + Bytes.length b
97
+
| Text s -> head_len (Int64.of_int (String.length s)) + String.length s
98
+
| Array items ->
99
+
head_len (Int64.of_int (List.length items))
100
+
+ List.fold_left (fun acc x -> acc + encoded_len x) 0 items
101
+
| Iarray items ->
102
+
1 + List.fold_left (fun acc x -> acc + encoded_len x) 0 items + 1
103
+
| Map pairs ->
104
+
head_len (Int64.of_int (List.length pairs))
105
+
+ List.fold_left
106
+
(fun acc (k, v) -> acc + encoded_len k + encoded_len v)
107
+
0 pairs
108
+
| Tag (n, v) -> head_len (Int64.of_int n) + encoded_len v
109
+
| False | True | Null | Undefined -> 1
110
+
111
+
let encode_head major arg (w : Writer.t) =
112
+
let base = major lsl 5 in
113
+
if arg << 24L then Writer.uint8 w (base lor Int64.to_int arg)
114
+
else if arg << 0x100L then (
115
+
Writer.uint8 w (base lor 24);
116
+
Writer.uint8 w (Int64.to_int arg))
117
+
else if arg << 0x10000L then (
118
+
Writer.uint8 w (base lor 25);
119
+
Writer.uint16_be w (Int64.to_int arg))
120
+
else if arg << 0x100000000L then (
121
+
Writer.uint8 w (base lor 26);
122
+
Writer.uint32_be w (Int64.to_int arg))
123
+
else (
124
+
Writer.uint8 w (base lor 27);
125
+
Writer.uint64_be w arg)
126
+
127
+
let rec write w = function
128
+
| Uint n -> encode_head major_uint n w
129
+
| Bytes b ->
130
+
encode_head major_bytes (Int64.of_int (Bytes.length b)) w;
131
+
Writer.bytes w b
132
+
| Text s ->
133
+
encode_head major_text (Int64.of_int (String.length s)) w;
134
+
Writer.string w s
135
+
| Array items ->
136
+
encode_head major_array (Int64.of_int (List.length items)) w;
137
+
List.iter (write w) items
138
+
| Iarray items ->
139
+
Writer.uint8 w ((major_array lsl 5) lor 31);
140
+
List.iter (write w) items;
141
+
Writer.uint8 w break_byte
142
+
| Map pairs ->
143
+
encode_head major_map (Int64.of_int (List.length pairs)) w;
144
+
List.iter
145
+
(fun (k, v) ->
146
+
write w k;
147
+
write w v)
148
+
pairs
149
+
| Tag (n, v) ->
150
+
encode_head major_tag (Int64.of_int n) w;
151
+
write w v
152
+
| False -> Writer.uint8 w ((major_simple lsl 5) lor simple_false)
153
+
| True -> Writer.uint8 w ((major_simple lsl 5) lor simple_true)
154
+
| Null -> Writer.uint8 w ((major_simple lsl 5) lor simple_null)
155
+
| Undefined -> Writer.uint8 w ((major_simple lsl 5) lor simple_undefined)
156
+
157
+
(* {1 Decoding} *)
158
+
159
+
let truncated r need =
160
+
let have = Reader.pos r + Reader.remaining r in
161
+
Error (Truncated { need; have })
162
+
163
+
let decode_arg info (r : Reader.t) =
164
+
if info < 24 then Ok (Int64.of_int info)
165
+
else if info = 24 then
166
+
match Reader.try_uint8 r with
167
+
| Ok v -> Ok (Int64.of_int v)
168
+
| Error (`Truncated { need; _ }) -> truncated r (Reader.pos r + need)
169
+
else if info = 25 then
170
+
match Reader.try_uint16_be r with
171
+
| Ok v -> Ok (Int64.of_int v)
172
+
| Error (`Truncated { need; _ }) -> truncated r (Reader.pos r + need)
173
+
else if info = 26 then
174
+
match Reader.try_uint32_be r with
175
+
| Ok v -> Ok (Int64.logand 0xffffffffL (Int64.of_int v))
176
+
| Error (`Truncated { need; _ }) -> truncated r (Reader.pos r + need)
177
+
else if info = 27 then
178
+
match Reader.try_uint64_be r with
179
+
| Ok v -> Ok v
180
+
| Error (`Truncated { need; _ }) -> truncated r (Reader.pos r + need)
181
+
else Error (Invalid_initial_byte ((info lsl 5) lor info))
182
+
183
+
let rec read_lim lim depth (r : Reader.t) =
184
+
if depth > lim.max_depth then Error (Depth_limit_exceeded depth)
185
+
else
186
+
match Reader.try_uint8 r with
187
+
| Error (`Truncated { need; _ }) -> truncated r (Reader.pos r + need)
188
+
| Ok b -> (
189
+
if b = break_byte then Error Unexpected_break
190
+
else
191
+
let major = b lsr 5 in
192
+
let info = b land 0x1f in
193
+
match major with
194
+
| 0 -> decode_uint info r
195
+
| 1 -> Error (Unsupported_type "negative integer")
196
+
| 2 -> decode_bytes info r
197
+
| 3 -> decode_text info r
198
+
| 4 -> decode_array lim depth info r
199
+
| 5 -> decode_map lim depth info r
200
+
| 6 -> decode_tag lim depth info r
201
+
| 7 -> decode_simple info r
202
+
| _ -> Error (Invalid_initial_byte b))
203
+
204
+
and decode_uint info r =
205
+
match decode_arg info r with Error e -> Error e | Ok n -> Ok (Uint n)
206
+
207
+
and decode_bytes info r =
208
+
if info = 31 then Error (Unsupported_type "indefinite-length byte string")
209
+
else
210
+
match decode_arg info r with
211
+
| Error e -> Error e
212
+
| Ok n -> (
213
+
let n = Int64.to_int n in
214
+
match Reader.try_bytes r n with
215
+
| Ok b -> Ok (Bytes b)
216
+
| Error (`Truncated { need; _ }) -> truncated r (Reader.pos r + need))
217
+
218
+
and decode_text info r =
219
+
if info = 31 then Error (Unsupported_type "indefinite-length text string")
220
+
else
221
+
match decode_arg info r with
222
+
| Error e -> Error e
223
+
| Ok n -> (
224
+
let n = Int64.to_int n in
225
+
match Reader.try_bytes r n with
226
+
| Ok b -> Ok (Text (Bytes.unsafe_to_string b))
227
+
| Error (`Truncated { need; _ }) -> truncated r (Reader.pos r + need))
228
+
229
+
and decode_array lim depth info r =
230
+
if info = 31 then decode_iarray lim depth r 0 []
231
+
else
232
+
match decode_arg info r with
233
+
| Error e -> Error e
234
+
| Ok n ->
235
+
let n = Int64.to_int n in
236
+
if n > lim.max_items then Error (Items_limit_exceeded n)
237
+
else decode_n_items lim depth n r []
238
+
239
+
and decode_iarray lim depth r count acc =
240
+
if count > lim.max_items then Error (Items_limit_exceeded count)
241
+
else
242
+
match Reader.try_uint8 r with
243
+
| Error (`Truncated { need; _ }) -> truncated r (Reader.pos r + need)
244
+
| Ok b when b = break_byte -> Ok (Iarray (List.rev acc))
245
+
| Ok _ -> (
246
+
Reader.seek r (Reader.pos r - 1);
247
+
match read_lim lim (depth + 1) r with
248
+
| Error e -> Error e
249
+
| Ok item -> decode_iarray lim depth r (count + 1) (item :: acc))
250
+
251
+
and decode_n_items lim depth n r acc =
252
+
if n = 0 then Ok (Array (List.rev acc))
253
+
else
254
+
match read_lim lim (depth + 1) r with
255
+
| Error e -> Error e
256
+
| Ok item -> decode_n_items lim depth (n - 1) r (item :: acc)
257
+
258
+
and decode_map lim depth info r =
259
+
if info = 31 then Error (Unsupported_type "indefinite-length map")
260
+
else
261
+
match decode_arg info r with
262
+
| Error e -> Error e
263
+
| Ok n ->
264
+
let n = Int64.to_int n in
265
+
if n > lim.max_items then Error (Items_limit_exceeded n)
266
+
else decode_n_pairs lim depth n r []
267
+
268
+
and decode_n_pairs lim depth n r acc =
269
+
if n = 0 then Ok (Map (List.rev acc))
270
+
else
271
+
match read_lim lim (depth + 1) r with
272
+
| Error e -> Error e
273
+
| Ok k -> (
274
+
match read_lim lim (depth + 1) r with
275
+
| Error e -> Error e
276
+
| Ok v -> decode_n_pairs lim depth (n - 1) r ((k, v) :: acc))
277
+
278
+
and decode_tag lim depth info r =
279
+
match decode_arg info r with
280
+
| Error e -> Error e
281
+
| Ok n -> (
282
+
match read_lim lim (depth + 1) r with
283
+
| Error e -> Error e
284
+
| Ok v -> Ok (Tag (Int64.to_int n, v)))
285
+
286
+
and decode_simple info _r =
287
+
match info with
288
+
| 20 -> Ok False
289
+
| 21 -> Ok True
290
+
| 22 -> Ok Null
291
+
| 23 -> Ok Undefined
292
+
| n when n < 24 -> Error (Unsupported_type (Format.sprintf "simple(%d)" n))
293
+
| 24 -> Error (Unsupported_type "simple (1-byte)")
294
+
| 25 -> Error (Unsupported_type "float16")
295
+
| 26 -> Error (Unsupported_type "float32")
296
+
| 27 -> Error (Unsupported_type "float64")
297
+
| _ -> Error (Invalid_initial_byte ((major_simple lsl 5) lor info))
298
+
299
+
let read_with_limits lim r = read_lim lim 0 r
300
+
let read r = read_with_limits default_limits r
301
+
302
+
let decode_all buf =
303
+
let r = Reader.of_bytes buf in
304
+
let rec loop acc =
305
+
if Reader.at_end r then Ok (List.rev acc)
306
+
else match read r with Error e -> Error e | Ok v -> loop (v :: acc)
307
+
in
308
+
loop []
309
+
310
+
(* {1 Constructors} *)
311
+
312
+
let uint n =
313
+
if n < 0 then invalid_arg "Cbor.uint: negative";
314
+
Uint (Int64.of_int n)
315
+
316
+
let int64 n =
317
+
if n < 0L then invalid_arg "Cbor.int64: negative";
318
+
Uint n
319
+
320
+
let bytes b = Bytes b
321
+
let text s = Text s
322
+
let array items = Array items
323
+
let iarray items = Iarray items
324
+
let map pairs = Map pairs
325
+
326
+
let tag n v =
327
+
if n < 0 then invalid_arg "Cbor.tag: negative tag";
328
+
Tag (n, v)
329
+
330
+
(* {1 Accessors} *)
331
+
332
+
let to_uint = function Uint n -> Some n | _ -> None
333
+
334
+
let to_int = function
335
+
| Uint n when n <= Int64.of_int max_int -> Some (Int64.to_int n)
336
+
| _ -> None
337
+
338
+
let to_bytes = function Bytes b -> Some b | _ -> None
339
+
let to_text = function Text s -> Some s | _ -> None
340
+
let to_array = function Array items | Iarray items -> Some items | _ -> None
341
+
let to_map = function Map pairs -> Some pairs | _ -> None
342
+
let to_tag = function Tag (n, v) -> Some (n, v) | _ -> None
343
+
let is_null = function Null -> true | _ -> false
344
+
345
+
(* {1 Pretty-printing} *)
346
+
347
+
let rec pp fmt = function
348
+
| Uint n -> Format.fprintf fmt "%Ld" n
349
+
| Bytes b ->
350
+
Format.fprintf fmt "h'";
351
+
Bytes.iter (fun c -> Format.fprintf fmt "%02x" (Char.code c)) b;
352
+
Format.fprintf fmt "'"
353
+
| Text s -> Format.fprintf fmt "\"%s\"" (String.escaped s)
354
+
| Array items ->
355
+
Format.fprintf fmt "@[<hv 1>[%a]@]"
356
+
(Format.pp_print_list
357
+
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
358
+
pp)
359
+
items
360
+
| Iarray items ->
361
+
Format.fprintf fmt "@[<hv 1>[_@ %a]@]"
362
+
(Format.pp_print_list
363
+
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
364
+
pp)
365
+
items
366
+
| Map pairs ->
367
+
let pp_pair fmt (k, v) = Format.fprintf fmt "%a:@ %a" pp k pp v in
368
+
Format.fprintf fmt "@[<hv 1>{%a}@]"
369
+
(Format.pp_print_list
370
+
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
371
+
pp_pair)
372
+
pairs
373
+
| Tag (n, v) -> Format.fprintf fmt "%d(%a)" n pp v
374
+
| False -> Format.pp_print_string fmt "false"
375
+
| True -> Format.pp_print_string fmt "true"
376
+
| Null -> Format.pp_print_string fmt "null"
377
+
| Undefined -> Format.pp_print_string fmt "undefined"
+76
lib/cbor.mli
+76
lib/cbor.mli
···
1
+
(** Minimal CBOR codec (RFC 8949).
2
+
3
+
This module implements a subset of CBOR sufficient for SDLS SA
4
+
serialization. It follows the "core deterministic encoding requirements"
5
+
from RFC 8949 Section 4.2.1, with the exception that indefinite-length
6
+
arrays are supported. *)
7
+
8
+
(* {1 Types} *)
9
+
10
+
type t =
11
+
| Uint of int64
12
+
| Bytes of bytes
13
+
| Text of string
14
+
| Array of t list
15
+
| Iarray of t list
16
+
| Map of (t * t) list
17
+
| Tag of int * t
18
+
| False
19
+
| True
20
+
| Null
21
+
| Undefined
22
+
23
+
type error =
24
+
| Truncated of { need : int; have : int }
25
+
| Invalid_initial_byte of int
26
+
| Unsupported_type of string
27
+
| Invalid_utf8
28
+
| Unexpected_break
29
+
| Missing_break
30
+
| Depth_limit_exceeded of int
31
+
| Items_limit_exceeded of int
32
+
33
+
val pp_error : error Fmt.t
34
+
35
+
(* {1 Limits} *)
36
+
37
+
type limits = { max_depth : int; max_items : int }
38
+
39
+
val default_limits : limits
40
+
41
+
(* {1 Reading} *)
42
+
43
+
val read : Binary.Reader.t -> (t, error) result
44
+
val read_with_limits : limits -> Binary.Reader.t -> (t, error) result
45
+
val decode_all : bytes -> (t list, error) result
46
+
47
+
(* {1 Writing} *)
48
+
49
+
val write : Binary.Writer.t -> t -> unit
50
+
val encoded_len : t -> int
51
+
52
+
(* {1 Constructors} *)
53
+
54
+
val uint : int -> t
55
+
val int64 : int64 -> t
56
+
val bytes : bytes -> t
57
+
val text : string -> t
58
+
val array : t list -> t
59
+
val iarray : t list -> t
60
+
val map : (t * t) list -> t
61
+
val tag : int -> t -> t
62
+
63
+
(* {1 Accessors} *)
64
+
65
+
val to_uint : t -> int64 option
66
+
val to_int : t -> int option
67
+
val to_bytes : t -> bytes option
68
+
val to_text : t -> string option
69
+
val to_array : t -> t list option
70
+
val to_map : t -> (t * t) list option
71
+
val to_tag : t -> (int * t) option
72
+
val is_null : t -> bool
73
+
74
+
(* {1 Pretty-printing} *)
75
+
76
+
val pp : t Fmt.t
+128
lib/cmac.ml
+128
lib/cmac.ml
···
1
+
(** AES-CMAC implementation (NIST SP 800-38B).
2
+
3
+
{b Security note:} This implementation zeroizes sensitive intermediate
4
+
values (subkeys K1/K2, L, and CBC state) after use. This follows the same
5
+
defense-in-depth approach as mirage-crypto: while OCaml's GC may retain
6
+
copies, explicit zeroization reduces the window of exposure. The underlying
7
+
AES operations use crypto's native implementation. *)
8
+
9
+
module C = Crypto.AES
10
+
11
+
type error = Invalid_key_length | Internal_error of string
12
+
13
+
let pp_error fmt = function
14
+
| Invalid_key_length ->
15
+
Format.fprintf fmt "invalid key length (must be 16, 24, or 32 bytes)"
16
+
| Internal_error msg -> Format.fprintf fmt "internal error: %s" msg
17
+
18
+
let mac_len = 16
19
+
20
+
(* Rb constant for 128-bit block size *)
21
+
let rb_128 = 0x87
22
+
23
+
(* Zeroize a bytes buffer to reduce sensitive data exposure.
24
+
Same approach as mirage-crypto: explicit zeroing as defense-in-depth,
25
+
though OCaml's GC may still retain copies in memory. *)
26
+
let zeroize buf = Bytes.fill buf 0 (Bytes.length buf) '\x00'
27
+
28
+
(* Left-shift a 16-byte block by one bit, returning the overflow bit *)
29
+
let lshift_block (block : bytes) : int =
30
+
let overflow = ref 0 in
31
+
for i = 15 downto 0 do
32
+
let b = Char.code (Bytes.get block i) in
33
+
let new_overflow = (b lsr 7) land 1 in
34
+
let shifted = (b lsl 1) lor !overflow land 0xFF in
35
+
Bytes.set block i (Char.chr shifted);
36
+
overflow := new_overflow
37
+
done;
38
+
!overflow
39
+
40
+
(* XOR two 16-byte blocks: dst := dst XOR src *)
41
+
let xor_block (dst : bytes) (src : bytes) : unit =
42
+
for i = 0 to 15 do
43
+
let d = Char.code (Bytes.get dst i) in
44
+
let s = Char.code (Bytes.get src i) in
45
+
Bytes.set dst i (Char.chr (d lxor s))
46
+
done
47
+
48
+
(* Generate CMAC subkeys K1 and K2 from the AES key *)
49
+
let subkeys (key : C.ECB.key) : bytes * bytes =
50
+
(* Step 1: L = AES_K(0^128) *)
51
+
let zero = Bytes.make 16 '\x00' in
52
+
let l = C.ECB.encrypt ~key (Bytes.to_string zero) in
53
+
let l = Bytes.of_string l in
54
+
(* Step 2: K1 = L << 1; if MSB(L) = 1 then K1 = K1 XOR Rb *)
55
+
let k1 = Bytes.copy l in
56
+
let msb = lshift_block k1 in
57
+
if msb = 1 then
58
+
Bytes.set k1 15 (Char.chr (Char.code (Bytes.get k1 15) lxor rb_128));
59
+
(* Step 3: K2 = K1 << 1; if MSB(K1) = 1 then K2 = K2 XOR Rb *)
60
+
let k2 = Bytes.copy k1 in
61
+
let msb = lshift_block k2 in
62
+
if msb = 1 then
63
+
Bytes.set k2 15 (Char.chr (Char.code (Bytes.get k2 15) lxor rb_128));
64
+
(* Zeroize intermediate L value *)
65
+
zeroize l;
66
+
(k1, k2)
67
+
68
+
(* Core CMAC computation with zeroization of sensitive intermediates *)
69
+
let compute ~(key : C.ECB.key) (data : bytes) : bytes =
70
+
let k1, k2 = subkeys key in
71
+
let len = Bytes.length data in
72
+
(* Number of blocks (at least 1) *)
73
+
let n = if len = 0 then 1 else (len + 15) / 16 in
74
+
let last_block_complete = len > 0 && len mod 16 = 0 in
75
+
(* Process blocks 1 to n-1 *)
76
+
let x = Bytes.make 16 '\x00' in
77
+
for i = 0 to n - 2 do
78
+
let block = Bytes.sub data (i * 16) 16 in
79
+
xor_block x block;
80
+
let encrypted = C.ECB.encrypt ~key (Bytes.to_string x) in
81
+
Bytes.blit_string encrypted 0 x 0 16
82
+
done;
83
+
(* Process last block *)
84
+
let last_block =
85
+
if last_block_complete then (
86
+
(* Complete block: XOR with K1 *)
87
+
let block = Bytes.sub data ((n - 1) * 16) 16 in
88
+
xor_block block k1;
89
+
block)
90
+
else
91
+
(* Incomplete: pad with 10* and XOR with K2 *)
92
+
let remaining = len - ((n - 1) * 16) in
93
+
let block = Bytes.make 16 '\x00' in
94
+
if remaining > 0 then Bytes.blit data ((n - 1) * 16) block 0 remaining;
95
+
Bytes.set block remaining '\x80';
96
+
xor_block block k2;
97
+
block
98
+
in
99
+
xor_block x last_block;
100
+
let result = C.ECB.encrypt ~key (Bytes.to_string x) in
101
+
(* Zeroize sensitive intermediate values *)
102
+
zeroize k1;
103
+
zeroize k2;
104
+
zeroize x;
105
+
zeroize last_block;
106
+
Bytes.of_string result
107
+
108
+
(* Constant-time comparison using eqaf *)
109
+
let ct_equal (a : bytes) (b : bytes) : bool =
110
+
Eqaf.equal (Bytes.unsafe_to_string a) (Bytes.unsafe_to_string b)
111
+
112
+
let validate_key_length key =
113
+
let len = Bytes.length key in
114
+
if len = 16 || len = 24 || len = 32 then Ok () else Error Invalid_key_length
115
+
116
+
let mac ~key data =
117
+
match validate_key_length key with
118
+
| Error e -> Error e
119
+
| Ok () -> (
120
+
try
121
+
let ecb_key = C.ECB.of_secret (Bytes.to_string key) in
122
+
Ok (compute ~key:ecb_key data)
123
+
with exn -> Error (Internal_error (Printexc.to_string exn)))
124
+
125
+
let verify ~key ~mac:expected data =
126
+
match mac ~key data with
127
+
| Error e -> Error e
128
+
| Ok computed -> Ok (ct_equal expected computed)
+29
lib/cmac.mli
+29
lib/cmac.mli
···
1
+
(** AES-CMAC (NIST SP 800-38B).
2
+
3
+
Cipher-based Message Authentication Code using AES. Provides 128-bit
4
+
(16-byte) authentication tags.
5
+
6
+
@see <https://csrc.nist.gov/publications/detail/sp/800-38b/final>
7
+
NIST SP 800-38B *)
8
+
9
+
(** {1 Errors} *)
10
+
11
+
type error =
12
+
| Invalid_key_length (** Key must be 16, 24, or 32 bytes *)
13
+
| Internal_error of string
14
+
15
+
val pp_error : error Fmt.t
16
+
17
+
(** {1 Operations} *)
18
+
19
+
val mac_len : int
20
+
(** MAC length in bytes (always 16). *)
21
+
22
+
val mac : key:bytes -> bytes -> (bytes, error) result
23
+
(** [mac ~key data] computes AES-CMAC over [data].
24
+
@param key 16/24/32 bytes (AES-128/192/256)
25
+
@return 16-byte MAC *)
26
+
27
+
val verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
28
+
(** [verify ~key ~mac data] checks if [mac] is valid for [data]. Uses
29
+
constant-time comparison. *)
+4
lib/dune
+4
lib/dune
+328
lib/ep.ml
+328
lib/ep.ml
···
1
+
(** SDLS Extended Procedures PDU (CCSDS 355.1-B-1).
2
+
3
+
This module implements the PDU header parsing and encoding for SDLS Extended
4
+
Procedures, including:
5
+
- SA management (Create, Delete, Rekey, Status)
6
+
- Key management (OTAR, Key Verification, Key Inventory)
7
+
- Monitoring and Control (Status, Dump, Self-test)
8
+
9
+
{b PDU Structure}
10
+
11
+
All EP PDUs use a Type-Length-Value (TLV) format:
12
+
{v
13
+
+------+----+----+-----+---------+--------+
14
+
| Type | UF | SG | PID | PDU_LEN | Data |
15
+
| 1bit | 1b | 2b | 4b | 16bit | (var) |
16
+
+------+----+----+-----+---------+--------+
17
+
v}
18
+
19
+
@see <https://public.ccsds.org/Pubs/355x1b1.pdf> CCSDS 355.1-B-1 *)
20
+
21
+
(* {1 Service Groups}
22
+
23
+
Per CCSDS 355.1-B-1 Section 5.3.2.2.2.3:
24
+
- 00 = Key Management
25
+
- 01 = SA Management (Initiator to Recipient direction)
26
+
- 10 = SA Management (Recipient to Initiator direction)
27
+
- 11 = Security Monitoring & Control *)
28
+
29
+
type service_group =
30
+
| SG_key_management (** 00 - Key management procedures *)
31
+
| SG_sa_management_ir (** 01 - SA management (Initiator -> Recipient) *)
32
+
| SG_sa_management_ri (** 10 - SA management (Recipient -> Initiator) *)
33
+
| SG_sec_mon_ctrl (** 11 - Security monitoring & control *)
34
+
35
+
let int_of_service_group = function
36
+
| SG_key_management -> 0
37
+
| SG_sa_management_ir -> 1
38
+
| SG_sa_management_ri -> 2
39
+
| SG_sec_mon_ctrl -> 3
40
+
41
+
let service_group_of_int = function
42
+
| 0 -> Some SG_key_management
43
+
| 1 -> Some SG_sa_management_ir
44
+
| 2 -> Some SG_sa_management_ri
45
+
| 3 -> Some SG_sec_mon_ctrl
46
+
| _ -> None
47
+
48
+
let pp_service_group ppf = function
49
+
| SG_key_management -> Fmt.pf ppf "KEY_MGMT"
50
+
| SG_sa_management_ir -> Fmt.pf ppf "SA_MGMT_IR"
51
+
| SG_sa_management_ri -> Fmt.pf ppf "SA_MGMT_RI"
52
+
| SG_sec_mon_ctrl -> Fmt.pf ppf "SEC_MON_CTRL"
53
+
54
+
(* {1 Key Management Procedure IDs}
55
+
56
+
Per CCSDS 355.1-B-1 Table 5-1 (SG=00):
57
+
- 0001 (1) = OTAR
58
+
- 0010 (2) = Key Activation
59
+
- 0011 (3) = Key Deactivation
60
+
- 0100 (4) = Key Verification
61
+
- 0110 (6) = Key Destruction
62
+
- 0111 (7) = Key Inventory *)
63
+
64
+
type key_procedure =
65
+
| Key_otar (** PID=1: Over-the-air rekeying *)
66
+
| Key_activation (** PID=2: Activate pending key *)
67
+
| Key_deactivation (** PID=3: Deactivate key *)
68
+
| Key_verification (** PID=4: Challenge/response verification *)
69
+
| Key_destruction (** PID=6: Securely destroy key *)
70
+
| Key_inventory (** PID=7: List key IDs *)
71
+
72
+
let int_of_key_procedure = function
73
+
| Key_otar -> 1
74
+
| Key_activation -> 2
75
+
| Key_deactivation -> 3
76
+
| Key_verification -> 4
77
+
| Key_destruction -> 6
78
+
| Key_inventory -> 7
79
+
80
+
let key_procedure_of_int = function
81
+
| 1 -> Some Key_otar
82
+
| 2 -> Some Key_activation
83
+
| 3 -> Some Key_deactivation
84
+
| 4 -> Some Key_verification
85
+
| 6 -> Some Key_destruction
86
+
| 7 -> Some Key_inventory
87
+
| _ -> None
88
+
89
+
let pp_key_procedure ppf = function
90
+
| Key_otar -> Fmt.pf ppf "OTAR"
91
+
| Key_activation -> Fmt.pf ppf "KEY_ACTIVATION"
92
+
| Key_deactivation -> Fmt.pf ppf "KEY_DEACTIVATION"
93
+
| Key_verification -> Fmt.pf ppf "KEY_VERIFICATION"
94
+
| Key_destruction -> Fmt.pf ppf "KEY_DESTRUCTION"
95
+
| Key_inventory -> Fmt.pf ppf "KEY_INVENTORY"
96
+
97
+
(* {1 SA Management Procedure IDs}
98
+
99
+
Per CCSDS 355.1-B-1 Table 5-1 (SG=01 or 10):
100
+
- 0000 (0) = Read Anti-Replay Sequence Number
101
+
- 0001 (1) = Create SA
102
+
- 0100 (4) = Delete SA
103
+
- 0101 (5) = Set Anti-Replay Sequence Number Window
104
+
- 0110 (6) = Rekey SA
105
+
- 1001 (9) = Expire SA
106
+
- 1010 (10) = Set Anti-Replay Sequence Number
107
+
- 1011 (11) = Start SA
108
+
- 1110 (14) = Stop SA
109
+
- 1111 (15) = SA Status Request *)
110
+
111
+
type sa_procedure =
112
+
| SA_read_arsn (** PID=0: Read current ARSN *)
113
+
| SA_create (** PID=1: Create new SA *)
114
+
| SA_delete (** PID=4: Delete SA *)
115
+
| SA_set_arsnw (** PID=5: Set anti-replay window size *)
116
+
| SA_rekey (** PID=6: Rekey SA *)
117
+
| SA_expire (** PID=9: Expire SA *)
118
+
| SA_set_arsn (** PID=10: Set anti-replay sequence number *)
119
+
| SA_start (** PID=11: Activate SA *)
120
+
| SA_stop (** PID=14: Deactivate SA *)
121
+
| SA_status (** PID=15: Query SA status *)
122
+
123
+
let int_of_sa_procedure = function
124
+
| SA_read_arsn -> 0
125
+
| SA_create -> 1
126
+
| SA_delete -> 4
127
+
| SA_set_arsnw -> 5
128
+
| SA_rekey -> 6
129
+
| SA_expire -> 9
130
+
| SA_set_arsn -> 10
131
+
| SA_start -> 11
132
+
| SA_stop -> 14
133
+
| SA_status -> 15
134
+
135
+
let sa_procedure_of_int = function
136
+
| 0 -> Some SA_read_arsn
137
+
| 1 -> Some SA_create
138
+
| 4 -> Some SA_delete
139
+
| 5 -> Some SA_set_arsnw
140
+
| 6 -> Some SA_rekey
141
+
| 9 -> Some SA_expire
142
+
| 10 -> Some SA_set_arsn
143
+
| 11 -> Some SA_start
144
+
| 14 -> Some SA_stop
145
+
| 15 -> Some SA_status
146
+
| _ -> None
147
+
148
+
let pp_sa_procedure ppf = function
149
+
| SA_read_arsn -> Fmt.pf ppf "SA_READ_ARSN"
150
+
| SA_create -> Fmt.pf ppf "SA_CREATE"
151
+
| SA_delete -> Fmt.pf ppf "SA_DELETE"
152
+
| SA_set_arsnw -> Fmt.pf ppf "SA_SET_ARSNW"
153
+
| SA_rekey -> Fmt.pf ppf "SA_REKEY"
154
+
| SA_expire -> Fmt.pf ppf "SA_EXPIRE"
155
+
| SA_set_arsn -> Fmt.pf ppf "SA_SET_ARSN"
156
+
| SA_start -> Fmt.pf ppf "SA_START"
157
+
| SA_stop -> Fmt.pf ppf "SA_STOP"
158
+
| SA_status -> Fmt.pf ppf "SA_STATUS"
159
+
160
+
(* {1 Monitoring Procedure IDs}
161
+
162
+
Per CCSDS 355.1-B-1 Table 5-1 (SG=11):
163
+
- 0001 (1) = Ping
164
+
- 0010 (2) = Log Status Request
165
+
- 0011 (3) = Dump Log
166
+
- 0100 (4) = Erase Log
167
+
- 0101 (5) = Self-Test
168
+
- 0111 (7) = Reset Alarm Flag *)
169
+
170
+
type monitoring_procedure =
171
+
| MC_ping (** PID=1: Connectivity test *)
172
+
| MC_log_status (** PID=2: Query log status *)
173
+
| MC_dump_log (** PID=3: Dump security event log *)
174
+
| MC_erase_log (** PID=4: Erase log *)
175
+
| MC_self_test (** PID=5: Run self-test *)
176
+
| MC_alarm_reset (** PID=7: Reset alarm flag *)
177
+
178
+
let int_of_monitoring_procedure = function
179
+
| MC_ping -> 1
180
+
| MC_log_status -> 2
181
+
| MC_dump_log -> 3
182
+
| MC_erase_log -> 4
183
+
| MC_self_test -> 5
184
+
| MC_alarm_reset -> 7
185
+
186
+
let monitoring_procedure_of_int = function
187
+
| 1 -> Some MC_ping
188
+
| 2 -> Some MC_log_status
189
+
| 3 -> Some MC_dump_log
190
+
| 4 -> Some MC_erase_log
191
+
| 5 -> Some MC_self_test
192
+
| 7 -> Some MC_alarm_reset
193
+
| _ -> None
194
+
195
+
let pp_monitoring_procedure ppf = function
196
+
| MC_ping -> Fmt.pf ppf "MC_PING"
197
+
| MC_log_status -> Fmt.pf ppf "MC_LOG_STATUS"
198
+
| MC_dump_log -> Fmt.pf ppf "MC_DUMP_LOG"
199
+
| MC_erase_log -> Fmt.pf ppf "MC_ERASE_LOG"
200
+
| MC_self_test -> Fmt.pf ppf "MC_SELF_TEST"
201
+
| MC_alarm_reset -> Fmt.pf ppf "MC_ALARM_RESET"
202
+
203
+
(* {1 PDU Header}
204
+
205
+
Header structure (3 bytes):
206
+
Byte 0: Type (1b) | UF (1b) | SG (2b) | PID (4b)
207
+
Bytes 1-2: PDU_LEN (16b) *)
208
+
209
+
let _header_len = 3
210
+
211
+
type header = {
212
+
is_reply : bool;
213
+
user_flag : bool;
214
+
service_group : service_group;
215
+
procedure_id : int;
216
+
pdu_len : int;
217
+
}
218
+
219
+
(* {2 Wire Codec}
220
+
221
+
The header is a fixed 3-byte structure using bitfields. *)
222
+
223
+
let bits8 n = Wire.bits ~width:n Wire.U8
224
+
let bool8 = Wire.bool (bits8 1)
225
+
let w_type = Wire.Field.v "Type" bool8
226
+
let w_uf = Wire.Field.v "UF" bool8
227
+
let w_sg = Wire.Field.v "SG" (bits8 2)
228
+
let w_pid = Wire.Field.v "PID" (bits8 4)
229
+
let w_pdu_len = Wire.Field.v "PDU_LEN" Wire.uint16be
230
+
231
+
let codec =
232
+
Wire.Codec.v "EP_Header"
233
+
(fun is_reply user_flag sg pid pdu_len ->
234
+
let service_group =
235
+
match service_group_of_int sg with
236
+
| Some sg -> sg
237
+
| None -> SG_key_management (* validated after decode *)
238
+
in
239
+
{ is_reply; user_flag; service_group; procedure_id = pid; pdu_len })
240
+
Wire.Codec.
241
+
[
242
+
(w_type $ fun t -> t.is_reply);
243
+
(w_uf $ fun t -> t.user_flag);
244
+
(w_sg $ fun t -> int_of_service_group t.service_group);
245
+
(w_pid $ fun t -> t.procedure_id);
246
+
(w_pdu_len $ fun t -> t.pdu_len);
247
+
]
248
+
249
+
let wire_size = Wire.Codec.wire_size codec
250
+
251
+
let encode_header hdr =
252
+
let buf = Bytes.create wire_size in
253
+
Wire.Codec.encode codec hdr buf 0;
254
+
buf
255
+
256
+
let decode_header buf off =
257
+
if Bytes.length buf - off < wire_size then Error `Truncated
258
+
else
259
+
let raw_b0 = Char.code (Bytes.get buf off) in
260
+
let sg_bits = (raw_b0 lsr 4) land 0x3 in
261
+
match service_group_of_int sg_bits with
262
+
| None -> Error `Invalid_sg
263
+
| Some _ -> (
264
+
match Wire.Codec.decode codec buf off with
265
+
| Ok hdr -> Ok hdr
266
+
| Error _ -> Error `Truncated)
267
+
268
+
let decode_header_string s off = decode_header (Bytes.unsafe_of_string s) off
269
+
270
+
let pp_header ppf hdr =
271
+
Fmt.pf ppf "@[<hov 2>{ %s;@ uf=%b;@ sg=%a;@ pid=%d;@ len=%d }@]"
272
+
(if hdr.is_reply then "REPLY" else "CMD")
273
+
hdr.user_flag pp_service_group hdr.service_group hdr.procedure_id
274
+
hdr.pdu_len
275
+
276
+
(* {1 MC Status Reply}
277
+
278
+
MC Status Reply: flags(1) + key_count(2) + sa_count(2) = 5 bytes *)
279
+
280
+
type mc_status_reply = { operational : bool; key_count : int; sa_count : int }
281
+
282
+
let pp_mc_status_reply ppf r =
283
+
Fmt.pf ppf "MC_STATUS_REPLY { op=%b; keys=%d; sas=%d }" r.operational
284
+
r.key_count r.sa_count
285
+
286
+
let mc_status_reply_size = 5
287
+
288
+
let encode_mc_status_reply r =
289
+
let buf = Bytes.create mc_status_reply_size in
290
+
Bytes.set buf 0 (Char.chr (if r.operational then 1 else 0));
291
+
Bytes.set buf 1 (Char.chr ((r.key_count lsr 8) land 0xFF));
292
+
Bytes.set buf 2 (Char.chr (r.key_count land 0xFF));
293
+
Bytes.set buf 3 (Char.chr ((r.sa_count lsr 8) land 0xFF));
294
+
Bytes.set buf 4 (Char.chr (r.sa_count land 0xFF));
295
+
buf
296
+
297
+
let decode_mc_status_reply buf off =
298
+
if Bytes.length buf - off < mc_status_reply_size then Error `Truncated
299
+
else
300
+
let flags = Char.code (Bytes.get buf off) in
301
+
let key_count =
302
+
(Char.code (Bytes.get buf (off + 1)) lsl 8)
303
+
lor Char.code (Bytes.get buf (off + 2))
304
+
in
305
+
let sa_count =
306
+
(Char.code (Bytes.get buf (off + 3)) lsl 8)
307
+
lor Char.code (Bytes.get buf (off + 4))
308
+
in
309
+
let operational = flags land 1 = 1 in
310
+
Ok { operational; key_count; sa_count }
311
+
312
+
(* {1 Error Type} *)
313
+
314
+
type error =
315
+
| Truncated of { need : int; have : int }
316
+
| Invalid_service_group of int
317
+
| Invalid_procedure_id of { sg : service_group; pid : int }
318
+
| Invalid_pdu_format of string
319
+
| Unsupported_pdu
320
+
321
+
let pp_error ppf = function
322
+
| Truncated { need; have } ->
323
+
Fmt.pf ppf "truncated: need %d bytes, have %d" need have
324
+
| Invalid_service_group sg -> Fmt.pf ppf "invalid service group: %d" sg
325
+
| Invalid_procedure_id { sg; pid } ->
326
+
Fmt.pf ppf "invalid procedure ID %d for %a" pid pp_service_group sg
327
+
| Invalid_pdu_format msg -> Fmt.pf ppf "invalid PDU format: %s" msg
328
+
| Unsupported_pdu -> Fmt.pf ppf "unsupported PDU type"
+149
lib/ep.mli
+149
lib/ep.mli
···
1
+
(** SDLS Extended Procedures PDU (CCSDS 355.1-B-1).
2
+
3
+
This module implements the PDU header parsing and encoding for SDLS Extended
4
+
Procedures, including:
5
+
- SA management (Create, Delete, Rekey, Status)
6
+
- Key management (OTAR, Key Verification, Key Inventory)
7
+
- Monitoring and Control (Status, Dump, Self-test)
8
+
9
+
{b PDU Structure}
10
+
11
+
All EP PDUs use a Type-Length-Value (TLV) format:
12
+
{v
13
+
+------+----+----+-----+---------+--------+
14
+
| Type | UF | SG | PID | PDU_LEN | Data |
15
+
| 1bit | 1b | 2b | 4b | 16bit | (var) |
16
+
+------+----+----+-----+---------+--------+
17
+
v}
18
+
19
+
@see <https://public.ccsds.org/Pubs/355x1b1.pdf> CCSDS 355.1-B-1 *)
20
+
21
+
(** {1 Service Groups} *)
22
+
23
+
(** Service Group (SG) - 2 bits per CCSDS 355.0-B-2 Table 5-1.
24
+
25
+
Note: SA management has two values (01 and 10) to distinguish direction:
26
+
- 01: Initiator -> Recipient direction (e.g., SA create request)
27
+
- 10: Recipient -> Initiator direction (e.g., SA create response) *)
28
+
type service_group =
29
+
| SG_key_management
30
+
(** 00 - Key management procedures (OTAR, verify, etc.) *)
31
+
| SG_sa_management_ir (** 01 - SA management (Initiator -> Recipient) *)
32
+
| SG_sa_management_ri (** 10 - SA management (Recipient -> Initiator) *)
33
+
| SG_sec_mon_ctrl (** 11 - Security monitoring & control *)
34
+
35
+
val int_of_service_group : service_group -> int
36
+
val service_group_of_int : int -> service_group option
37
+
val pp_service_group : service_group Fmt.t
38
+
39
+
(** {1 Procedure IDs} *)
40
+
41
+
(** Key Management Procedure IDs (SG=00) per CCSDS 355.1-B-1 Table 5-1. *)
42
+
type key_procedure =
43
+
| Key_otar (** PID=1: Over-the-air rekeying *)
44
+
| Key_activation (** PID=2: Activate pending key *)
45
+
| Key_deactivation (** PID=3: Deactivate key *)
46
+
| Key_verification (** PID=4: Key verification challenge/response *)
47
+
| Key_destruction (** PID=6: Securely destroy key *)
48
+
| Key_inventory (** PID=7: List key IDs *)
49
+
50
+
val int_of_key_procedure : key_procedure -> int
51
+
val key_procedure_of_int : int -> key_procedure option
52
+
val pp_key_procedure : key_procedure Fmt.t
53
+
54
+
(** SA Management Procedure IDs (SG=01 or 10) per CCSDS 355.1-B-1 Table 5-1. *)
55
+
type sa_procedure =
56
+
| SA_read_arsn (** PID=0: Read current ARSN *)
57
+
| SA_create (** PID=1: Create new SA *)
58
+
| SA_delete (** PID=4: Delete SA *)
59
+
| SA_set_arsnw (** PID=5: Set anti-replay window size *)
60
+
| SA_rekey (** PID=6: Rekey SA *)
61
+
| SA_expire (** PID=9: Expire SA *)
62
+
| SA_set_arsn (** PID=10: Set anti-replay sequence number *)
63
+
| SA_start (** PID=11: Activate SA *)
64
+
| SA_stop (** PID=14: Deactivate SA *)
65
+
| SA_status (** PID=15: Query SA status *)
66
+
67
+
val int_of_sa_procedure : sa_procedure -> int
68
+
val sa_procedure_of_int : int -> sa_procedure option
69
+
val pp_sa_procedure : sa_procedure Fmt.t
70
+
71
+
(** Monitoring Procedure IDs (SG=11) per CCSDS 355.1-B-1 Table 5-1. *)
72
+
type monitoring_procedure =
73
+
| MC_ping (** PID=1: Connectivity test *)
74
+
| MC_log_status (** PID=2: Query log status *)
75
+
| MC_dump_log (** PID=3: Dump security event log *)
76
+
| MC_erase_log (** PID=4: Erase log *)
77
+
| MC_self_test (** PID=5: Run self-test *)
78
+
| MC_alarm_reset (** PID=7: Reset alarm flag *)
79
+
80
+
val int_of_monitoring_procedure : monitoring_procedure -> int
81
+
val monitoring_procedure_of_int : int -> monitoring_procedure option
82
+
val pp_monitoring_procedure : monitoring_procedure Fmt.t
83
+
84
+
(** {1 PDU Header} *)
85
+
86
+
type header = {
87
+
is_reply : bool; (** Type flag: false=command, true=reply *)
88
+
user_flag : bool; (** User-defined flag *)
89
+
service_group : service_group; (** Service group (2 bits) *)
90
+
procedure_id : int; (** Procedure ID within service group (4 bits) *)
91
+
pdu_len : int; (** Length of data field in bytes *)
92
+
}
93
+
(** TLV PDU header (3 bytes). *)
94
+
95
+
val codec : header Wire.Codec.t
96
+
(** Wire codec for the 3-byte EP header. *)
97
+
98
+
val wire_size : int
99
+
(** Size of the EP header in bytes (3). *)
100
+
101
+
val encode_header : header -> bytes
102
+
(** [encode_header hdr] encodes the header into a fresh 3-byte buffer. *)
103
+
104
+
val decode_header :
105
+
bytes -> int -> (header, [ `Truncated | `Invalid_sg ]) result
106
+
(** [decode_header buf off] decodes a header from [buf] at offset [off]. *)
107
+
108
+
val decode_header_string :
109
+
string -> int -> (header, [ `Truncated | `Invalid_sg ]) result
110
+
(** [decode_header_string s off] decodes a header from string [s] at offset
111
+
[off]. *)
112
+
113
+
val pp_header : header Fmt.t
114
+
115
+
(** {1 MC Status Reply}
116
+
117
+
MC Status Reply PDU data: flags(1) + key_count(2) + sa_count(2) = 5 bytes.
118
+
Used with monitoring procedure MC_ping (SG=11, PID=2). *)
119
+
120
+
type mc_status_reply = {
121
+
operational : bool; (** Engine is operational *)
122
+
key_count : int; (** Number of active keys *)
123
+
sa_count : int; (** Number of active SAs *)
124
+
}
125
+
(** Status reply - SDLS engine status. *)
126
+
127
+
val mc_status_reply_size : int
128
+
(** Size of the MC status reply data in bytes (5). *)
129
+
130
+
val encode_mc_status_reply : mc_status_reply -> bytes
131
+
(** [encode_mc_status_reply r] encodes the status reply into a fresh buffer. *)
132
+
133
+
val decode_mc_status_reply :
134
+
bytes -> int -> (mc_status_reply, [ `Truncated ]) result
135
+
(** [decode_mc_status_reply buf off] decodes a status reply from [buf] at offset
136
+
[off]. *)
137
+
138
+
val pp_mc_status_reply : mc_status_reply Fmt.t
139
+
140
+
(** {1 Errors} *)
141
+
142
+
type error =
143
+
| Truncated of { need : int; have : int }
144
+
| Invalid_service_group of int
145
+
| Invalid_procedure_id of { sg : service_group; pid : int }
146
+
| Invalid_pdu_format of string
147
+
| Unsupported_pdu
148
+
149
+
val pp_error : error Fmt.t
+51
lib/hex.ml
+51
lib/hex.ml
···
1
+
(** Hexadecimal encoding/decoding utilities. *)
2
+
3
+
let encode b =
4
+
let hex = Bytes.create (Bytes.length b * 2) in
5
+
for i = 0 to Bytes.length b - 1 do
6
+
let c = Char.code (Bytes.get b i) in
7
+
let hi = c lsr 4 and lo = c land 0xf in
8
+
let to_hex n = Char.chr (if n < 10 then n + 48 else n + 87) in
9
+
Bytes.set hex (i * 2) (to_hex hi);
10
+
Bytes.set hex ((i * 2) + 1) (to_hex lo)
11
+
done;
12
+
Bytes.to_string hex
13
+
14
+
let from_hex c =
15
+
match c with
16
+
| '0' .. '9' -> Some (Char.code c - 48)
17
+
| 'a' .. 'f' -> Some (Char.code c - 87)
18
+
| 'A' .. 'F' -> Some (Char.code c - 55)
19
+
| _ -> None
20
+
21
+
let is_whitespace = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false
22
+
23
+
let decode ?(skip_whitespace = false) s =
24
+
let s =
25
+
if skip_whitespace then
26
+
String.to_seq s
27
+
|> Seq.filter (fun c -> not (is_whitespace c))
28
+
|> String.of_seq
29
+
else s
30
+
in
31
+
let len = String.length s in
32
+
if len mod 2 <> 0 then None
33
+
else
34
+
let b = Bytes.create (len / 2) in
35
+
let rec go i =
36
+
if i >= len / 2 then Some b
37
+
else
38
+
match (from_hex s.[i * 2], from_hex s.[(i * 2) + 1]) with
39
+
| Some hi, Some lo ->
40
+
Bytes.set b i (Char.chr ((hi lsl 4) lor lo));
41
+
go (i + 1)
42
+
| _ -> None
43
+
in
44
+
go 0
45
+
46
+
let decode_exn ?skip_whitespace s =
47
+
match decode ?skip_whitespace s with
48
+
| Some b -> b
49
+
| None -> invalid_arg ("Hex.decode_exn: invalid hex string: " ^ s)
50
+
51
+
let pp ppf b = Format.pp_print_string ppf (encode b)
+26
lib/hex.mli
+26
lib/hex.mli
···
1
+
(** Hexadecimal encoding/decoding utilities.
2
+
3
+
Provides conversion between binary data and hexadecimal string
4
+
representation. Useful for logging, configuration files, and debugging. *)
5
+
6
+
val encode : bytes -> string
7
+
(** [encode b] converts bytes to lowercase hex string. Example:
8
+
[encode (Bytes.of_string "\x01\xAB")] returns ["01ab"]. *)
9
+
10
+
val decode : ?skip_whitespace:bool -> string -> bytes option
11
+
(** [decode ?skip_whitespace s] parses hex string to bytes. Returns [None] if
12
+
[s] has odd length (after filtering) or contains non-hex characters. Accepts
13
+
both upper and lowercase.
14
+
15
+
@param skip_whitespace
16
+
If [true], spaces, tabs, and newlines are ignored. Useful for parsing
17
+
formatted hex dumps. Default is [false].
18
+
19
+
Example: [decode "01AB"] returns [Some (Bytes.of_string "\x01\xAB")].
20
+
Example: [decode ~skip_whitespace:true "01 AB"] returns [Some ...]. *)
21
+
22
+
val decode_exn : ?skip_whitespace:bool -> string -> bytes
23
+
(** [decode_exn s] is like [decode] but raises [Invalid_argument] on error. *)
24
+
25
+
val pp : bytes Fmt.t
26
+
(** [pp ppf b] pretty-prints bytes as hex string. *)
+81
lib/hmac.ml
+81
lib/hmac.ml
···
1
+
(** HMAC implementation using digestif.
2
+
3
+
Uses digestif for SHA-256 and SHA-512 hash functions. *)
4
+
5
+
type error = Invalid_key_length | Internal_error of string
6
+
7
+
let pp_error fmt = function
8
+
| Invalid_key_length -> Format.fprintf fmt "invalid key length (must be >= 1)"
9
+
| Internal_error msg -> Format.fprintf fmt "internal error: %s" msg
10
+
11
+
(* {1 Constants} *)
12
+
13
+
let sha256_mac_len = 32
14
+
let sha384_mac_len = 48
15
+
let sha512_mac_len = 64
16
+
17
+
(* {1 Helpers} *)
18
+
19
+
(* Constant-time comparison using eqaf *)
20
+
let ct_equal (a : bytes) (b : bytes) : bool =
21
+
Eqaf.equal (Bytes.unsafe_to_string a) (Bytes.unsafe_to_string b)
22
+
23
+
let validate_key key =
24
+
if Bytes.length key >= 1 then Ok () else Error Invalid_key_length
25
+
26
+
(* {1 HMAC-SHA-256} *)
27
+
28
+
let sha256 ~key data =
29
+
match validate_key key with
30
+
| Error e -> Error e
31
+
| Ok () -> (
32
+
try
33
+
let key = Bytes.unsafe_to_string key in
34
+
let digest =
35
+
Digestif.SHA256.hmac_string ~key (Bytes.unsafe_to_string data)
36
+
in
37
+
Ok (Bytes.of_string (Digestif.SHA256.to_raw_string digest))
38
+
with exn -> Error (Internal_error (Printexc.to_string exn)))
39
+
40
+
let sha256_verify ~key ~mac data =
41
+
match sha256 ~key data with
42
+
| Error e -> Error e
43
+
| Ok computed -> Ok (ct_equal mac computed)
44
+
45
+
(* {1 HMAC-SHA-384} *)
46
+
47
+
let sha384 ~key data =
48
+
match validate_key key with
49
+
| Error e -> Error e
50
+
| Ok () -> (
51
+
try
52
+
let key = Bytes.unsafe_to_string key in
53
+
let digest =
54
+
Digestif.SHA384.hmac_string ~key (Bytes.unsafe_to_string data)
55
+
in
56
+
Ok (Bytes.of_string (Digestif.SHA384.to_raw_string digest))
57
+
with exn -> Error (Internal_error (Printexc.to_string exn)))
58
+
59
+
let sha384_verify ~key ~mac data =
60
+
match sha384 ~key data with
61
+
| Error e -> Error e
62
+
| Ok computed -> Ok (ct_equal mac computed)
63
+
64
+
(* {1 HMAC-SHA-512} *)
65
+
66
+
let sha512 ~key data =
67
+
match validate_key key with
68
+
| Error e -> Error e
69
+
| Ok () -> (
70
+
try
71
+
let key = Bytes.unsafe_to_string key in
72
+
let digest =
73
+
Digestif.SHA512.hmac_string ~key (Bytes.unsafe_to_string data)
74
+
in
75
+
Ok (Bytes.of_string (Digestif.SHA512.to_raw_string digest))
76
+
with exn -> Error (Internal_error (Printexc.to_string exn)))
77
+
78
+
let sha512_verify ~key ~mac data =
79
+
match sha512 ~key data with
80
+
| Error e -> Error e
81
+
| Ok computed -> Ok (ct_equal mac computed)
+58
lib/hmac.mli
+58
lib/hmac.mli
···
1
+
(** HMAC (RFC 2104, FIPS 198-1).
2
+
3
+
Hash-based Message Authentication Code using SHA-256 and SHA-512. Provides
4
+
authentication tags for SDLS frames.
5
+
6
+
@see <https://datatracker.ietf.org/doc/html/rfc2104> RFC 2104 HMAC
7
+
@see <https://csrc.nist.gov/publications/detail/fips/198/1/final> FIPS 198-1
8
+
*)
9
+
10
+
(** {1 Errors} *)
11
+
12
+
type error =
13
+
| Invalid_key_length (** Key too short (minimum 1 byte) *)
14
+
| Internal_error of string
15
+
16
+
val pp_error : error Fmt.t
17
+
18
+
(** {1 HMAC-SHA-256} *)
19
+
20
+
val sha256_mac_len : int
21
+
(** HMAC-SHA-256 output length in bytes (32). *)
22
+
23
+
val sha256 : key:bytes -> bytes -> (bytes, error) result
24
+
(** [sha256 ~key data] computes HMAC-SHA-256 over [data].
25
+
@param key secret key (any length, but >= 32 bytes recommended)
26
+
@return 32-byte MAC *)
27
+
28
+
val sha256_verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
29
+
(** [sha256_verify ~key ~mac data] checks if [mac] is valid for [data]. Uses
30
+
constant-time comparison. *)
31
+
32
+
(** {1 HMAC-SHA-384} *)
33
+
34
+
val sha384_mac_len : int
35
+
(** HMAC-SHA-384 output length in bytes (48). *)
36
+
37
+
val sha384 : key:bytes -> bytes -> (bytes, error) result
38
+
(** [sha384 ~key data] computes HMAC-SHA-384 over [data].
39
+
@param key secret key (any length, but >= 48 bytes recommended)
40
+
@return 48-byte MAC *)
41
+
42
+
val sha384_verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
43
+
(** [sha384_verify ~key ~mac data] checks if [mac] is valid for [data]. Uses
44
+
constant-time comparison. *)
45
+
46
+
(** {1 HMAC-SHA-512} *)
47
+
48
+
val sha512_mac_len : int
49
+
(** HMAC-SHA-512 output length in bytes (64). *)
50
+
51
+
val sha512 : key:bytes -> bytes -> (bytes, error) result
52
+
(** [sha512 ~key data] computes HMAC-SHA-512 over [data].
53
+
@param key secret key (any length, but >= 64 bytes recommended)
54
+
@return 64-byte MAC *)
55
+
56
+
val sha512_verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
57
+
(** [sha512_verify ~key ~mac data] checks if [mac] is valid for [data]. Uses
58
+
constant-time comparison. *)
+178
lib/key.ml
+178
lib/key.ml
···
1
+
(** Key lifecycle state machine (CCSDS 355.1-B-1). *)
2
+
3
+
(* {1 Types} *)
4
+
5
+
type state = Empty | Pending | Active | Deprecated | Zeroized
6
+
7
+
let int_of_state = function
8
+
| Empty -> 0
9
+
| Pending -> 1
10
+
| Active -> 2
11
+
| Deprecated -> 3
12
+
| Zeroized -> 4
13
+
14
+
let state_of_int = function
15
+
| 0 -> Some Empty
16
+
| 1 -> Some Pending
17
+
| 2 -> Some Active
18
+
| 3 -> Some Deprecated
19
+
| 4 -> Some Zeroized
20
+
| _ -> None
21
+
22
+
let pp_state ppf = function
23
+
| Empty -> Fmt.pf ppf "EMPTY"
24
+
| Pending -> Fmt.pf ppf "PENDING"
25
+
| Active -> Fmt.pf ppf "ACTIVE"
26
+
| Deprecated -> Fmt.pf ppf "DEPRECATED"
27
+
| Zeroized -> Fmt.pf ppf "ZEROIZED"
28
+
29
+
type t = { kid : int; state : state; material : bytes option; algorithm : int }
30
+
31
+
let pp ppf t =
32
+
let material_len =
33
+
match t.material with Some m -> Bytes.length m | None -> 0
34
+
in
35
+
Fmt.pf ppf "@[<hov 2>Key { kid=0x%04X;@ state=%a;@ material[%d];@ algo=%d }@]"
36
+
t.kid pp_state t.state material_len t.algorithm
37
+
38
+
(* {1 Constructors} *)
39
+
40
+
let empty ~kid ~algorithm = { kid; state = Empty; material = None; algorithm }
41
+
42
+
let v ~kid ~algorithm ~material =
43
+
{ kid; state = Pending; material = Some (Bytes.copy material); algorithm }
44
+
45
+
(* {1 State Machine Errors} *)
46
+
47
+
type error =
48
+
| Invalid_state_transition of { from : state; to_ : state }
49
+
| No_key_material
50
+
| Key_already_active
51
+
| Key_not_found of int
52
+
53
+
let pp_error ppf = function
54
+
| Invalid_state_transition { from; to_ } ->
55
+
Fmt.pf ppf "invalid state transition: %a -> %a" pp_state from pp_state to_
56
+
| No_key_material -> Fmt.pf ppf "no key material present"
57
+
| Key_already_active -> Fmt.pf ppf "key is already active"
58
+
| Key_not_found kid -> Fmt.pf ppf "key not found: 0x%04X" kid
59
+
60
+
(* {1 State Transitions} *)
61
+
62
+
let update ~material t =
63
+
match t.state with
64
+
| Empty | Pending ->
65
+
Ok { t with state = Pending; material = Some (Bytes.copy material) }
66
+
| Active -> Error (Invalid_state_transition { from = Active; to_ = Pending })
67
+
| Deprecated ->
68
+
Error (Invalid_state_transition { from = Deprecated; to_ = Pending })
69
+
| Zeroized ->
70
+
Error (Invalid_state_transition { from = Zeroized; to_ = Pending })
71
+
72
+
let activate t =
73
+
match t.state with
74
+
| Pending -> (
75
+
match t.material with
76
+
| Some _ -> Ok { t with state = Active }
77
+
| None -> Error No_key_material)
78
+
| Active -> Error Key_already_active
79
+
| Empty -> Error (Invalid_state_transition { from = Empty; to_ = Active })
80
+
| Deprecated ->
81
+
Error (Invalid_state_transition { from = Deprecated; to_ = Active })
82
+
| Zeroized ->
83
+
Error (Invalid_state_transition { from = Zeroized; to_ = Active })
84
+
85
+
let deactivate t =
86
+
match t.state with
87
+
| Active -> Ok { t with state = Deprecated }
88
+
| Deprecated -> Ok t
89
+
| Pending ->
90
+
Error (Invalid_state_transition { from = Pending; to_ = Deprecated })
91
+
| Empty -> Error (Invalid_state_transition { from = Empty; to_ = Deprecated })
92
+
| Zeroized ->
93
+
Error (Invalid_state_transition { from = Zeroized; to_ = Deprecated })
94
+
95
+
let zeroize t =
96
+
(match t.material with
97
+
| Some m -> Bytes.fill m 0 (Bytes.length m) '\x00'
98
+
| None -> ());
99
+
{ t with state = Zeroized; material = None }
100
+
101
+
let expire t =
102
+
match t.state with
103
+
| Pending -> Ok (zeroize t)
104
+
| Empty -> Error (Invalid_state_transition { from = Empty; to_ = Zeroized })
105
+
| Active -> Error (Invalid_state_transition { from = Active; to_ = Zeroized })
106
+
| Deprecated ->
107
+
Error (Invalid_state_transition { from = Deprecated; to_ = Zeroized })
108
+
| Zeroized -> Ok t
109
+
110
+
let destroy t =
111
+
match t.state with
112
+
| Deprecated | Pending -> Ok (zeroize t)
113
+
| Active -> Error (Invalid_state_transition { from = Active; to_ = Zeroized })
114
+
| Empty -> Error (Invalid_state_transition { from = Empty; to_ = Zeroized })
115
+
| Zeroized -> Ok t
116
+
117
+
(* {1 Queries} *)
118
+
119
+
let is_usable t = t.state = Active && Option.is_some t.material
120
+
let get_material t = if is_usable t then t.material else None
121
+
let kid t = t.kid
122
+
let state t = t.state
123
+
let algorithm t = t.algorithm
124
+
let material_raw t = t.material
125
+
126
+
let from_raw ~kid ~state ~algorithm ~material =
127
+
{ kid; state; algorithm; material }
128
+
129
+
(* {1 Serialization} *)
130
+
131
+
let write w t =
132
+
let material = Option.value ~default:Bytes.empty t.material in
133
+
let material_len = Bytes.length material in
134
+
Binary.Writer.uint8 w (int_of_state t.state);
135
+
Binary.Writer.uint8 w t.algorithm;
136
+
Binary.Writer.uint16_be w material_len;
137
+
if material_len > 0 then Binary.Writer.bytes w material
138
+
139
+
let read ~kid r =
140
+
match Binary.Reader.ensure r 4 with
141
+
| Error _ -> None
142
+
| Ok () -> (
143
+
let state_int = Binary.Reader.uint8 r in
144
+
let algorithm = Binary.Reader.uint8 r in
145
+
let material_len = Binary.Reader.uint16_be r in
146
+
match Binary.Reader.ensure r material_len with
147
+
| Error _ -> None
148
+
| Ok () -> (
149
+
match state_of_int state_int with
150
+
| None -> None
151
+
| Some state ->
152
+
let material =
153
+
if material_len = 0 then None
154
+
else Some (Binary.Reader.bytes r material_len)
155
+
in
156
+
Some { kid; state; algorithm; material }))
157
+
158
+
(* {1 Keyring} *)
159
+
160
+
module Keyring = struct
161
+
type key = t
162
+
type t = key list
163
+
164
+
let empty = []
165
+
let add key ring = key :: List.filter (fun k -> k.kid <> key.kid) ring
166
+
let find kid ring = List.find_opt (fun k -> k.kid = kid) ring
167
+
let remove kid ring = List.filter (fun k -> k.kid <> kid) ring
168
+
let to_list ring = ring
169
+
let find_active ring = List.filter (fun k -> k.state = Active) ring
170
+
171
+
let inventory ?(first = 0) ?(last = 0xFFFF) ring =
172
+
ring
173
+
|> List.filter (fun k -> k.kid >= first && k.kid <= last)
174
+
|> List.sort (fun a b -> compare a.kid b.kid)
175
+
|> List.map (fun k -> (k.kid, k.state))
176
+
177
+
let pp ppf ring = Fmt.pf ppf "@[<v>%a@]" Fmt.(list ~sep:cut pp) ring
178
+
end
+80
lib/key.mli
+80
lib/key.mli
···
1
+
(** Key lifecycle state machine (CCSDS 355.1-B-1).
2
+
3
+
This module provides a pure state machine for key lifecycle management,
4
+
supporting OTAR (Over-The-Air Rekeying) operations.
5
+
6
+
{b Security:} Keys must never appear in plaintext in logs or errors. The
7
+
[pp] functions only show key IDs and states, never key material.
8
+
9
+
@see <https://public.ccsds.org/Pubs/355x1b1.pdf> CCSDS 355.1-B-1 Section 4
10
+
*)
11
+
12
+
(** {1 Key State} *)
13
+
14
+
type state = Empty | Pending | Active | Deprecated | Zeroized
15
+
16
+
val int_of_state : state -> int
17
+
val state_of_int : int -> state option
18
+
val pp_state : state Fmt.t
19
+
20
+
(** {1 Key Slot} *)
21
+
22
+
type t
23
+
24
+
val pp : t Fmt.t
25
+
26
+
(** {1 Constructors} *)
27
+
28
+
val empty : kid:int -> algorithm:int -> t
29
+
val v : kid:int -> algorithm:int -> material:bytes -> t
30
+
31
+
(** {1 State Machine Errors} *)
32
+
33
+
type error =
34
+
| Invalid_state_transition of { from : state; to_ : state }
35
+
| No_key_material
36
+
| Key_already_active
37
+
| Key_not_found of int
38
+
39
+
val pp_error : error Fmt.t
40
+
41
+
(** {1 State Transitions} *)
42
+
43
+
val update : material:bytes -> t -> (t, error) result
44
+
val activate : t -> (t, error) result
45
+
val deactivate : t -> (t, error) result
46
+
val expire : t -> (t, error) result
47
+
val destroy : t -> (t, error) result
48
+
49
+
(** {1 Queries} *)
50
+
51
+
val is_usable : t -> bool
52
+
val get_material : t -> bytes option
53
+
val kid : t -> int
54
+
val state : t -> state
55
+
val algorithm : t -> int
56
+
val material_raw : t -> bytes option
57
+
58
+
val from_raw :
59
+
kid:int -> state:state -> algorithm:int -> material:bytes option -> t
60
+
61
+
(** {1 Serialization} *)
62
+
63
+
val write : Binary.Writer.t -> t -> unit
64
+
val read : kid:int -> Binary.Reader.t -> t option
65
+
66
+
(** {1 Keyring} *)
67
+
68
+
module Keyring : sig
69
+
type key = t
70
+
type t
71
+
72
+
val empty : t
73
+
val add : key -> t -> t
74
+
val find : int -> t -> key option
75
+
val remove : int -> t -> t
76
+
val to_list : t -> key list
77
+
val find_active : t -> key list
78
+
val inventory : ?first:int -> ?last:int -> t -> (int * state) list
79
+
val pp : t Fmt.t
80
+
end
+18
lib/keyid.ml
+18
lib/keyid.ml
···
1
+
(** Key identifier for cryptographic keys. *)
2
+
3
+
type t = int
4
+
5
+
let max_value = 0xFFFF (* 16 bits *)
6
+
let of_int n = if n >= 0 && n <= max_value then Some n else None
7
+
8
+
let of_int_exn n =
9
+
match of_int n with
10
+
| Some t -> t
11
+
| None ->
12
+
invalid_arg
13
+
(Printf.sprintf "Keyid.of_int_exn: %d out of range [0, %d]" n max_value)
14
+
15
+
let to_int t = t
16
+
let pp fmt t = Format.fprintf fmt "%d" t
17
+
let equal = Int.equal
18
+
let compare = Int.compare
+14
lib/keyid.mli
+14
lib/keyid.mli
···
1
+
(** Key identifier for cryptographic keys.
2
+
3
+
16-bit identifier (0-65535) referencing keys in a keystore. Used by Security
4
+
Associations to reference encryption and authentication keys (ek_id, ak_id
5
+
fields). *)
6
+
7
+
type t = private int
8
+
9
+
val of_int : int -> t option
10
+
val of_int_exn : int -> t
11
+
val to_int : t -> int
12
+
val pp : t Fmt.t
13
+
val equal : t -> t -> bool
14
+
val compare : t -> t -> int
+196
lib/keystore.ml
+196
lib/keystore.ml
···
1
+
(** Key storage interface for SDLS (CCSDS 355.1-B-1). *)
2
+
3
+
(* {1 Cipher Suite for Key Validation} *)
4
+
5
+
type cipher_suite = AES_256 | HMAC_SHA_256 | HMAC_SHA_384 | HMAC_SHA_512
6
+
7
+
let pp_cipher_suite ppf = function
8
+
| AES_256 -> Fmt.pf ppf "AES-256"
9
+
| HMAC_SHA_256 -> Fmt.pf ppf "HMAC-SHA-256"
10
+
| HMAC_SHA_384 -> Fmt.pf ppf "HMAC-SHA-384"
11
+
| HMAC_SHA_512 -> Fmt.pf ppf "HMAC-SHA-512"
12
+
13
+
let required_key_len = function
14
+
| AES_256 -> 32
15
+
| HMAC_SHA_256 -> 32
16
+
| HMAC_SHA_384 -> 48
17
+
| HMAC_SHA_512 -> 64
18
+
19
+
let is_valid_key_len cipher_suite key_len =
20
+
let required = required_key_len cipher_suite in
21
+
match cipher_suite with
22
+
| AES_256 -> key_len = required
23
+
| HMAC_SHA_256 | HMAC_SHA_384 | HMAC_SHA_512 -> key_len >= required
24
+
25
+
(* {1 Key State} *)
26
+
27
+
type key_state = Pre_active | Active | Deactivated | Destroyed
28
+
29
+
let pp_key_state ppf = function
30
+
| Pre_active -> Fmt.pf ppf "pre_active"
31
+
| Active -> Fmt.pf ppf "active"
32
+
| Deactivated -> Fmt.pf ppf "deactivated"
33
+
| Destroyed -> Fmt.pf ppf "destroyed"
34
+
35
+
let int_of_key_state = function
36
+
| Pre_active -> 0
37
+
| Active -> 1
38
+
| Deactivated -> 2
39
+
| Destroyed -> 3
40
+
41
+
let key_state_of_int = function
42
+
| 0 -> Some Pre_active
43
+
| 1 -> Some Active
44
+
| 2 -> Some Deactivated
45
+
| 3 -> Some Destroyed
46
+
| _ -> None
47
+
48
+
(* {1 Key Entry} *)
49
+
50
+
type entry = { material : bytes; state : key_state }
51
+
52
+
let pp_entry ppf e =
53
+
Fmt.pf ppf "{ material=[%d bytes]; state=%a }" (Bytes.length e.material)
54
+
pp_key_state e.state
55
+
56
+
(* {1 Serialization} *)
57
+
58
+
let write_entry w e =
59
+
Binary.Writer.uint8 w (int_of_key_state e.state);
60
+
Binary.Writer.bytes w e.material
61
+
62
+
let read_entry r =
63
+
let ( let* ) = Option.bind in
64
+
let* () = Result.to_option (Binary.Reader.ensure r 1) in
65
+
let* state = key_state_of_int (Binary.Reader.uint8 r) in
66
+
let material = Binary.Reader.rest r in
67
+
Some { material; state }
68
+
69
+
(* {1 Backend Interface} *)
70
+
71
+
module type S = sig
72
+
type t
73
+
74
+
val get : t -> Keyid.t -> entry option
75
+
val set : t -> Keyid.t -> entry -> unit
76
+
val remove : t -> Keyid.t -> unit
77
+
val list : t -> Keyid.t list
78
+
val list_by_state : t -> key_state -> Keyid.t list
79
+
end
80
+
81
+
(* {1 First-class module wrapper} *)
82
+
83
+
type t = T : (module S with type t = 'a) * 'a -> t
84
+
85
+
(* {1 Functor} *)
86
+
87
+
module Make (B : S) = struct
88
+
let v backend = T ((module B), backend)
89
+
end
90
+
91
+
(* {1 In-Memory Backend} *)
92
+
93
+
module Keyid_map = Map.Make (struct
94
+
type t = Keyid.t
95
+
96
+
let compare = Keyid.compare
97
+
end)
98
+
99
+
module Mem : S with type t = entry Keyid_map.t ref = struct
100
+
type t = entry Keyid_map.t ref
101
+
102
+
let get store key_id = Keyid_map.find_opt key_id !store
103
+
let set store key_id entry = store := Keyid_map.add key_id entry !store
104
+
let remove store key_id = store := Keyid_map.remove key_id !store
105
+
let list store = Keyid_map.bindings !store |> List.map fst
106
+
107
+
let list_by_state store state =
108
+
Keyid_map.bindings !store
109
+
|> List.filter_map (fun (id, e) ->
110
+
if e.state = state then Some id else None)
111
+
end
112
+
113
+
let in_memory () = T ((module Mem), ref Keyid_map.empty)
114
+
115
+
(* {1 Operations} *)
116
+
117
+
let get (T ((module B), backend)) key_id = B.get backend key_id
118
+
let get_material t key_id = Option.map (fun e -> e.material) (get t key_id)
119
+
let set (T ((module B), backend)) key_id entry = B.set backend key_id entry
120
+
let add t key_id material = set t key_id { material; state = Pre_active }
121
+
122
+
(* {1 Key Length Validation Error} *)
123
+
124
+
type key_len_error = {
125
+
key_id : Keyid.t;
126
+
cipher_suite : cipher_suite;
127
+
expected : int;
128
+
actual : int;
129
+
}
130
+
131
+
let pp_key_len_error ppf e =
132
+
Fmt.pf ppf "key %a: %a requires %d bytes, got %d" Keyid.pp e.key_id
133
+
pp_cipher_suite e.cipher_suite e.expected e.actual
134
+
135
+
let add_for_cipher t key_id cipher material =
136
+
let key_len = Bytes.length material in
137
+
if is_valid_key_len cipher key_len then (
138
+
set t key_id { material; state = Pre_active };
139
+
Ok ())
140
+
else
141
+
Error
142
+
(`Invalid_key_len
143
+
{
144
+
key_id;
145
+
cipher_suite = cipher;
146
+
expected = required_key_len cipher;
147
+
actual = key_len;
148
+
})
149
+
150
+
let remove (T ((module B), backend)) key_id = B.remove backend key_id
151
+
let list (T ((module B), backend)) = B.list backend
152
+
153
+
let list_by_state (T ((module B), backend)) state =
154
+
B.list_by_state backend state
155
+
156
+
(* {1 Key Lifecycle Operations} *)
157
+
158
+
let activate t key_id =
159
+
match get t key_id with
160
+
| Some ({ state = Pre_active; _ } as e) ->
161
+
set t key_id { e with state = Active };
162
+
true
163
+
| _ -> false
164
+
165
+
let deactivate t key_id =
166
+
match get t key_id with
167
+
| Some ({ state = Active; _ } as e) ->
168
+
set t key_id { e with state = Deactivated };
169
+
true
170
+
| _ -> false
171
+
172
+
let destroy t key_id =
173
+
match get t key_id with
174
+
| Some e ->
175
+
Bytes.fill e.material 0 (Bytes.length e.material) '\x00';
176
+
set t key_id { material = Bytes.empty; state = Destroyed };
177
+
true
178
+
| None -> false
179
+
180
+
(* {1 SDLS Integration} *)
181
+
182
+
let get_active_key t key_id =
183
+
match get t key_id with
184
+
| Some { material; state = Active } -> Some material
185
+
| _ -> None
186
+
187
+
let get_encryption_key = get_active_key
188
+
let get_auth_key = get_active_key
189
+
190
+
let get_decryption_key t key_id =
191
+
match get t key_id with
192
+
| Some { material; state = Active } -> Some material
193
+
| Some { material; state = Deactivated } -> Some material
194
+
| _ -> None
195
+
196
+
let get_verify_key = get_decryption_key
+94
lib/keystore.mli
+94
lib/keystore.mli
···
1
+
(** Key storage interface for SDLS (CCSDS 355.1-B-1).
2
+
3
+
@see <https://public.ccsds.org/Pubs/355x1b1.pdf> CCSDS 355.1-B-1 Section 3.2
4
+
*)
5
+
6
+
(** {1 Cipher Suite for Key Validation} *)
7
+
8
+
type cipher_suite = AES_256 | HMAC_SHA_256 | HMAC_SHA_384 | HMAC_SHA_512
9
+
10
+
val pp_cipher_suite : cipher_suite Fmt.t
11
+
val required_key_len : cipher_suite -> int
12
+
val is_valid_key_len : cipher_suite -> int -> bool
13
+
14
+
(** {1 Key State} *)
15
+
16
+
type key_state = Pre_active | Active | Deactivated | Destroyed
17
+
18
+
val pp_key_state : key_state Fmt.t
19
+
val int_of_key_state : key_state -> int
20
+
val key_state_of_int : int -> key_state option
21
+
22
+
(** {1 Key Entry} *)
23
+
24
+
type entry = { material : bytes; state : key_state }
25
+
26
+
val pp_entry : entry Fmt.t
27
+
28
+
(** {1 Serialization} *)
29
+
30
+
val write_entry : Binary.Writer.t -> entry -> unit
31
+
val read_entry : Binary.Reader.t -> entry option
32
+
33
+
(** {1 Backend Interface} *)
34
+
35
+
module type S = sig
36
+
type t
37
+
38
+
val get : t -> Keyid.t -> entry option
39
+
val set : t -> Keyid.t -> entry -> unit
40
+
val remove : t -> Keyid.t -> unit
41
+
val list : t -> Keyid.t list
42
+
val list_by_state : t -> key_state -> Keyid.t list
43
+
end
44
+
45
+
(** {1 Keystore Handle} *)
46
+
47
+
type t
48
+
49
+
module Make (B : S) : sig
50
+
val v : B.t -> t
51
+
end
52
+
53
+
val in_memory : unit -> t
54
+
55
+
(** {1 Operations} *)
56
+
57
+
val get : t -> Keyid.t -> entry option
58
+
val get_material : t -> Keyid.t -> bytes option
59
+
val set : t -> Keyid.t -> entry -> unit
60
+
val add : t -> Keyid.t -> bytes -> unit
61
+
62
+
type key_len_error = {
63
+
key_id : Keyid.t;
64
+
cipher_suite : cipher_suite;
65
+
expected : int;
66
+
actual : int;
67
+
}
68
+
69
+
val pp_key_len_error : key_len_error Fmt.t
70
+
71
+
val add_for_cipher :
72
+
t ->
73
+
Keyid.t ->
74
+
cipher_suite ->
75
+
bytes ->
76
+
(unit, [ `Invalid_key_len of key_len_error ]) result
77
+
78
+
val remove : t -> Keyid.t -> unit
79
+
val list : t -> Keyid.t list
80
+
val list_by_state : t -> key_state -> Keyid.t list
81
+
82
+
(** {1 Key Lifecycle Operations} *)
83
+
84
+
val activate : t -> Keyid.t -> bool
85
+
val deactivate : t -> Keyid.t -> bool
86
+
val destroy : t -> Keyid.t -> bool
87
+
88
+
(** {1 SDLS Integration} *)
89
+
90
+
val get_active_key : t -> Keyid.t -> bytes option
91
+
val get_encryption_key : t -> Keyid.t -> bytes option
92
+
val get_auth_key : t -> Keyid.t -> bytes option
93
+
val get_decryption_key : t -> Keyid.t -> bytes option
94
+
val get_verify_key : t -> Keyid.t -> bytes option
+540
lib/mc.ml
+540
lib/mc.ml
···
1
+
(** SDLS Monitoring & Control (CCSDS 355.1-B-1).
2
+
3
+
This module implements the Security Monitoring & Control PDU types (SG=11):
4
+
- Log Status (PID=2): Query Security Log status
5
+
- Dump Log (PID=3): Retrieve all security events
6
+
- Erase Log (PID=4): Clear Security Log
7
+
- Self-Test (PID=5): Trigger crypto self-test
8
+
- Alarm Reset (PID=7): Reset FSR alarm flag
9
+
10
+
{b Security Log}
11
+
12
+
The Security Log stores security-relevant events for audit. Each event is
13
+
TLV-encoded: Tag (1 byte) + Length (2 bytes) + Data (variable).
14
+
15
+
@see <https://public.ccsds.org/Pubs/355x1b1.pdf>
16
+
CCSDS 355.1-B-1 Section 3.4.3 *)
17
+
18
+
(* {1 Binary helpers} *)
19
+
20
+
let u8 buf off = Char.code (Bytes.get buf off)
21
+
22
+
let u16_be buf off =
23
+
(Char.code (Bytes.get buf off) lsl 8) lor Char.code (Bytes.get buf (off + 1))
24
+
25
+
let u64_be buf off =
26
+
let hi =
27
+
Int64.of_int
28
+
((u8 buf off lsl 24)
29
+
lor (u8 buf (off + 1) lsl 16)
30
+
lor (u8 buf (off + 2) lsl 8)
31
+
lor u8 buf (off + 3))
32
+
in
33
+
let lo =
34
+
Int64.of_int
35
+
((u8 buf (off + 4) lsl 24)
36
+
lor (u8 buf (off + 5) lsl 16)
37
+
lor (u8 buf (off + 6) lsl 8)
38
+
lor u8 buf (off + 7))
39
+
in
40
+
Int64.logor (Int64.shift_left hi 32) (Int64.logand lo 0xFFFFFFFFL)
41
+
42
+
let set_u8 buf off v = Bytes.set buf off (Char.chr (v land 0xFF))
43
+
44
+
let set_u16_be buf off v =
45
+
set_u8 buf off (v lsr 8);
46
+
set_u8 buf (off + 1) v
47
+
48
+
let set_u64_be buf off v =
49
+
set_u8 buf off (Int64.to_int (Int64.shift_right_logical v 56) land 0xFF);
50
+
set_u8 buf (off + 1) (Int64.to_int (Int64.shift_right_logical v 48) land 0xFF);
51
+
set_u8 buf (off + 2) (Int64.to_int (Int64.shift_right_logical v 40) land 0xFF);
52
+
set_u8 buf (off + 3) (Int64.to_int (Int64.shift_right_logical v 32) land 0xFF);
53
+
set_u8 buf (off + 4) (Int64.to_int (Int64.shift_right_logical v 24) land 0xFF);
54
+
set_u8 buf (off + 5) (Int64.to_int (Int64.shift_right_logical v 16) land 0xFF);
55
+
set_u8 buf (off + 6) (Int64.to_int (Int64.shift_right_logical v 8) land 0xFF);
56
+
set_u8 buf (off + 7) (Int64.to_int v land 0xFF)
57
+
58
+
(* {1 Log Status PDU (PID=2)}
59
+
60
+
Per CCSDS 355.1-B-1 Section 5.6.1.2:
61
+
- Command: No data field (header only)
62
+
- Reply: num_events (2 bytes) + remaining_space (2 bytes) *)
63
+
64
+
type log_status_reply = {
65
+
num_events : int; (** Number of events in Security Log *)
66
+
remaining_space : int; (** Remaining space in bytes *)
67
+
}
68
+
69
+
let pp_log_status_reply ppf r =
70
+
Fmt.pf ppf "LOG_STATUS_REPLY { events=%d; space=%d }" r.num_events
71
+
r.remaining_space
72
+
73
+
let log_status_reply_size = 4
74
+
75
+
let encode_log_status_reply r =
76
+
let buf = Bytes.create log_status_reply_size in
77
+
set_u16_be buf 0 r.num_events;
78
+
set_u16_be buf 2 r.remaining_space;
79
+
buf
80
+
81
+
let decode_log_status_reply buf off =
82
+
if Bytes.length buf - off < log_status_reply_size then Error `Truncated
83
+
else
84
+
let num_events = u16_be buf off in
85
+
let remaining_space = u16_be buf (off + 2) in
86
+
Ok { num_events; remaining_space }
87
+
88
+
(* {1 Erase Log PDU (PID=4)}
89
+
90
+
Per CCSDS 355.1-B-1 Section 5.6.1.4:
91
+
- Command: No data field
92
+
- Reply: Same structure as Log Status Reply (status after erasure) *)
93
+
94
+
type erase_log_reply = {
95
+
num_events : int; (** Number of events after erasure (should be 0) *)
96
+
remaining_space : int; (** Remaining space after erasure *)
97
+
}
98
+
99
+
let pp_erase_log_reply ppf r =
100
+
Fmt.pf ppf "ERASE_LOG_REPLY { events=%d; space=%d }" r.num_events
101
+
r.remaining_space
102
+
103
+
let erase_log_reply_size = 4
104
+
105
+
let encode_erase_log_reply r =
106
+
let buf = Bytes.create erase_log_reply_size in
107
+
set_u16_be buf 0 r.num_events;
108
+
set_u16_be buf 2 r.remaining_space;
109
+
buf
110
+
111
+
let decode_erase_log_reply buf off =
112
+
if Bytes.length buf - off < erase_log_reply_size then Error `Truncated
113
+
else
114
+
let num_events = u16_be buf off in
115
+
let remaining_space = u16_be buf (off + 2) in
116
+
Ok { num_events; remaining_space }
117
+
118
+
(* {1 Self-Test PDU (PID=5)}
119
+
120
+
Per CCSDS 355.1-B-1 Section 5.6.1.5:
121
+
- Command: No data field
122
+
- Reply: 1 byte result (0xxxxxxx = OK, 1xxxxxxx = NOT OK)
123
+
124
+
The lower 7 bits can carry implementation-specific error codes. *)
125
+
126
+
type self_test_result =
127
+
| Self_test_ok (** Self-test passed (0xxxxxxx) *)
128
+
| Self_test_failed of int (** Self-test failed with error code (1xxxxxxx) *)
129
+
130
+
let pp_self_test_result ppf = function
131
+
| Self_test_ok -> Fmt.pf ppf "OK"
132
+
| Self_test_failed code -> Fmt.pf ppf "FAILED(0x%02X)" code
133
+
134
+
type self_test_reply = { result : self_test_result }
135
+
136
+
let pp_self_test_reply ppf r =
137
+
Fmt.pf ppf "SELF_TEST_REPLY { result=%a }" pp_self_test_result r.result
138
+
139
+
let self_test_reply_size = 1
140
+
141
+
let encode_self_test_reply r =
142
+
let buf = Bytes.create self_test_reply_size in
143
+
let v =
144
+
match r.result with
145
+
| Self_test_ok -> 0x00
146
+
| Self_test_failed code -> 0x80 lor (code land 0x7F)
147
+
in
148
+
set_u8 buf 0 v;
149
+
buf
150
+
151
+
let decode_self_test_reply buf off =
152
+
if Bytes.length buf - off < self_test_reply_size then Error `Truncated
153
+
else
154
+
let v = u8 buf off in
155
+
let result =
156
+
if v land 0x80 = 0 then Self_test_ok else Self_test_failed (v land 0x7F)
157
+
in
158
+
Ok { result }
159
+
160
+
(* {1 Security Event Types}
161
+
162
+
Security events are stored in the Security Log and transmitted in Dump Log
163
+
replies. Each event is TLV-encoded: Tag (1 byte) + Length (2 bytes) + Data
164
+
(variable).
165
+
166
+
Per CCSDS 355.1-B-1: "The content of each security message is implementation
167
+
specific and not specified by this Recommended Standard." *)
168
+
169
+
(** Authentication failure reason. *)
170
+
type auth_failure_reason =
171
+
| Bad_mac (** MAC verification failed *)
172
+
| Bad_sequence_number (** Anti-replay check failed *)
173
+
| Bad_sa (** Invalid or inactive Security Association *)
174
+
| Unknown_spi (** SPI not found *)
175
+
| Unknown_auth_reason of int (** Unrecognized reason code *)
176
+
177
+
let pp_auth_failure_reason ppf = function
178
+
| Bad_mac -> Fmt.pf ppf "BAD_MAC"
179
+
| Bad_sequence_number -> Fmt.pf ppf "BAD_SN"
180
+
| Bad_sa -> Fmt.pf ppf "BAD_SA"
181
+
| Unknown_spi -> Fmt.pf ppf "UNKNOWN_SPI"
182
+
| Unknown_auth_reason n -> Fmt.pf ppf "UNKNOWN(%d)" n
183
+
184
+
(** SA state transition. *)
185
+
type sa_transition =
186
+
| Sa_created (** New SA created *)
187
+
| Sa_started (** SA activated *)
188
+
| Sa_stopped (** SA deactivated *)
189
+
| Sa_rekeyed (** SA rekeyed with new key *)
190
+
| Sa_expired (** SA expired *)
191
+
| Sa_deleted (** SA deleted *)
192
+
| Unknown_sa_transition of int (** Unrecognized transition code *)
193
+
194
+
let pp_sa_transition ppf = function
195
+
| Sa_created -> Fmt.pf ppf "CREATED"
196
+
| Sa_started -> Fmt.pf ppf "STARTED"
197
+
| Sa_stopped -> Fmt.pf ppf "STOPPED"
198
+
| Sa_rekeyed -> Fmt.pf ppf "REKEYED"
199
+
| Sa_expired -> Fmt.pf ppf "EXPIRED"
200
+
| Sa_deleted -> Fmt.pf ppf "DELETED"
201
+
| Unknown_sa_transition n -> Fmt.pf ppf "UNKNOWN(%d)" n
202
+
203
+
(** Key state transition. *)
204
+
type key_transition =
205
+
| Key_received (** New key received via OTAR *)
206
+
| Key_activated (** Key activated *)
207
+
| Key_deactivated (** Key deactivated *)
208
+
| Key_destroyed (** Key securely destroyed *)
209
+
| Unknown_key_transition of int (** Unrecognized transition code *)
210
+
211
+
let pp_key_transition ppf = function
212
+
| Key_received -> Fmt.pf ppf "RECEIVED"
213
+
| Key_activated -> Fmt.pf ppf "ACTIVATED"
214
+
| Key_deactivated -> Fmt.pf ppf "DEACTIVATED"
215
+
| Key_destroyed -> Fmt.pf ppf "DESTROYED"
216
+
| Unknown_key_transition n -> Fmt.pf ppf "UNKNOWN(%d)" n
217
+
218
+
(** Frame direction for logging. *)
219
+
type frame_direction =
220
+
| Uplink
221
+
| Downlink
222
+
| Unknown_direction of int (** Unrecognized direction code *)
223
+
224
+
let pp_frame_direction ppf = function
225
+
| Uplink -> Fmt.pf ppf "UPLINK"
226
+
| Downlink -> Fmt.pf ppf "DOWNLINK"
227
+
| Unknown_direction n -> Fmt.pf ppf "UNKNOWN(%d)" n
228
+
229
+
(** Security event payload. *)
230
+
type event_data =
231
+
| Auth_failure of {
232
+
spi : int;
233
+
reason : auth_failure_reason;
234
+
vcid : int option;
235
+
} (** Frame authentication/decryption failure *)
236
+
| Frame_protected of {
237
+
spi : int;
238
+
direction : frame_direction;
239
+
vcid : int option;
240
+
} (** Frame successfully protected (encrypted/authenticated) *)
241
+
| Frame_unprotected of {
242
+
spi : int;
243
+
direction : frame_direction;
244
+
vcid : int option;
245
+
} (** Frame successfully unprotected (decrypted/verified) *)
246
+
| Iv_warning of { spi : int; remaining : int64 }
247
+
(** IV approaching exhaustion - rekey recommended *)
248
+
| Sa_change of { spi : int; transition : sa_transition }
249
+
(** SA state change *)
250
+
| Key_change of { kid : int; transition : key_transition }
251
+
(** Key lifecycle event *)
252
+
| Alarm_reset (** FSR alarm flag reset *)
253
+
| Self_test of { success : bool } (** Crypto self-test result *)
254
+
| Log_erased (** Security log was erased *)
255
+
256
+
let pp_vcid_opt ppf = function Some v -> Fmt.pf ppf "; vcid=%d" v | None -> ()
257
+
258
+
let pp_event_data ppf = function
259
+
| Auth_failure { spi; reason; vcid } ->
260
+
Fmt.pf ppf "AUTH_FAILURE { spi=0x%04X; reason=%a%a }" spi
261
+
pp_auth_failure_reason reason pp_vcid_opt vcid
262
+
| Frame_protected { spi; direction; vcid } ->
263
+
Fmt.pf ppf "FRAME_PROTECTED { spi=0x%04X; dir=%a%a }" spi
264
+
pp_frame_direction direction pp_vcid_opt vcid
265
+
| Frame_unprotected { spi; direction; vcid } ->
266
+
Fmt.pf ppf "FRAME_UNPROTECTED { spi=0x%04X; dir=%a%a }" spi
267
+
pp_frame_direction direction pp_vcid_opt vcid
268
+
| Iv_warning { spi; remaining } ->
269
+
Fmt.pf ppf "IV_WARNING { spi=0x%04X; remaining=%Ld }" spi remaining
270
+
| Sa_change { spi; transition } ->
271
+
Fmt.pf ppf "SA_CHANGE { spi=0x%04X; %a }" spi pp_sa_transition transition
272
+
| Key_change { kid; transition } ->
273
+
Fmt.pf ppf "KEY_CHANGE { kid=0x%04X; %a }" kid pp_key_transition
274
+
transition
275
+
| Alarm_reset -> Fmt.pf ppf "ALARM_RESET"
276
+
| Self_test { success } ->
277
+
Fmt.pf ppf "SELF_TEST { %s }" (if success then "OK" else "FAILED")
278
+
| Log_erased -> Fmt.pf ppf "LOG_ERASED"
279
+
280
+
(* {2 Event Tags} *)
281
+
282
+
let tag_auth_failure = 0x01
283
+
let tag_sa_change = 0x02
284
+
let tag_key_change = 0x03
285
+
let tag_alarm_reset = 0x04
286
+
let tag_self_test = 0x05
287
+
let tag_log_erased = 0x06
288
+
let tag_frame_protected = 0x07
289
+
let tag_frame_unprotected = 0x08
290
+
let tag_iv_warning = 0x09
291
+
292
+
(* {2 Int encoding helpers for event subtypes} *)
293
+
294
+
let int_of_auth_reason = function
295
+
| Bad_mac -> 0
296
+
| Bad_sequence_number -> 1
297
+
| Bad_sa -> 2
298
+
| Unknown_spi -> 3
299
+
| Unknown_auth_reason n -> n
300
+
301
+
let auth_reason_of_int = function
302
+
| 0 -> Bad_mac
303
+
| 1 -> Bad_sequence_number
304
+
| 2 -> Bad_sa
305
+
| 3 -> Unknown_spi
306
+
| n -> Unknown_auth_reason n
307
+
308
+
let int_of_direction = function
309
+
| Uplink -> 0
310
+
| Downlink -> 1
311
+
| Unknown_direction n -> n
312
+
313
+
let direction_of_int = function
314
+
| 0 -> Uplink
315
+
| 1 -> Downlink
316
+
| n -> Unknown_direction n
317
+
318
+
let int_of_sa_trans = function
319
+
| Sa_created -> 0
320
+
| Sa_started -> 1
321
+
| Sa_stopped -> 2
322
+
| Sa_rekeyed -> 3
323
+
| Sa_expired -> 4
324
+
| Sa_deleted -> 5
325
+
| Unknown_sa_transition n -> n
326
+
327
+
let sa_trans_of_int = function
328
+
| 0 -> Sa_created
329
+
| 1 -> Sa_started
330
+
| 2 -> Sa_stopped
331
+
| 3 -> Sa_rekeyed
332
+
| 4 -> Sa_expired
333
+
| 5 -> Sa_deleted
334
+
| n -> Unknown_sa_transition n
335
+
336
+
let int_of_key_trans = function
337
+
| Key_received -> 0
338
+
| Key_activated -> 1
339
+
| Key_deactivated -> 2
340
+
| Key_destroyed -> 3
341
+
| Unknown_key_transition n -> n
342
+
343
+
let key_trans_of_int = function
344
+
| 0 -> Key_received
345
+
| 1 -> Key_activated
346
+
| 2 -> Key_deactivated
347
+
| 3 -> Key_destroyed
348
+
| n -> Unknown_key_transition n
349
+
350
+
(* {2 Event Data Encoding}
351
+
352
+
Each event is TLV-encoded into a byte buffer. The encoder returns a fresh
353
+
bytes buffer; the decoder reads from a buffer at a given offset and returns
354
+
the event plus the number of bytes consumed. *)
355
+
356
+
(** Encode a frame-direction event (shared logic for protected/unprotected). *)
357
+
let encode_frame_dir_event tag ~spi ~direction ~vcid =
358
+
let has_vcid = Option.is_some vcid in
359
+
let data_len = 2 + 1 + if has_vcid then 1 else 0 in
360
+
let buf = Bytes.create (3 + data_len) in
361
+
set_u8 buf 0 tag;
362
+
set_u16_be buf 1 data_len;
363
+
set_u16_be buf 3 spi;
364
+
let dir_byte =
365
+
int_of_direction direction land 0x7F lor if has_vcid then 0x80 else 0
366
+
in
367
+
set_u8 buf 5 dir_byte;
368
+
(match vcid with Some v -> set_u8 buf 6 v | None -> ());
369
+
buf
370
+
371
+
let encode_event_data = function
372
+
| Auth_failure { spi; reason; vcid } ->
373
+
let has_vcid = Option.is_some vcid in
374
+
let data_len = 2 + 1 + if has_vcid then 1 else 0 in
375
+
let buf = Bytes.create (3 + data_len) in
376
+
set_u8 buf 0 tag_auth_failure;
377
+
set_u16_be buf 1 data_len;
378
+
set_u16_be buf 3 spi;
379
+
let reason_byte =
380
+
int_of_auth_reason reason land 0x7F lor if has_vcid then 0x80 else 0
381
+
in
382
+
set_u8 buf 5 reason_byte;
383
+
(match vcid with Some v -> set_u8 buf 6 v | None -> ());
384
+
buf
385
+
| Frame_protected { spi; direction; vcid } ->
386
+
encode_frame_dir_event tag_frame_protected ~spi ~direction ~vcid
387
+
| Frame_unprotected { spi; direction; vcid } ->
388
+
encode_frame_dir_event tag_frame_unprotected ~spi ~direction ~vcid
389
+
| Iv_warning { spi; remaining } ->
390
+
let buf = Bytes.create 13 in
391
+
set_u8 buf 0 tag_iv_warning;
392
+
set_u16_be buf 1 10;
393
+
set_u16_be buf 3 spi;
394
+
set_u64_be buf 5 remaining;
395
+
buf
396
+
| Sa_change { spi; transition } ->
397
+
let buf = Bytes.create 6 in
398
+
set_u8 buf 0 tag_sa_change;
399
+
set_u16_be buf 1 3;
400
+
set_u16_be buf 3 spi;
401
+
set_u8 buf 5 (int_of_sa_trans transition);
402
+
buf
403
+
| Key_change { kid; transition } ->
404
+
let buf = Bytes.create 6 in
405
+
set_u8 buf 0 tag_key_change;
406
+
set_u16_be buf 1 3;
407
+
set_u16_be buf 3 kid;
408
+
set_u8 buf 5 (int_of_key_trans transition);
409
+
buf
410
+
| Alarm_reset ->
411
+
let buf = Bytes.create 3 in
412
+
set_u8 buf 0 tag_alarm_reset;
413
+
set_u16_be buf 1 0;
414
+
buf
415
+
| Self_test { success } ->
416
+
let buf = Bytes.create 4 in
417
+
set_u8 buf 0 tag_self_test;
418
+
set_u16_be buf 1 1;
419
+
set_u8 buf 3 (if success then 0 else 1);
420
+
buf
421
+
| Log_erased ->
422
+
let buf = Bytes.create 3 in
423
+
set_u8 buf 0 tag_log_erased;
424
+
set_u16_be buf 1 0;
425
+
buf
426
+
427
+
type event_error = [ `Truncated | `Invalid_tag of int | `Invalid_vcid of int ]
428
+
429
+
let pp_event_error ppf = function
430
+
| `Truncated -> Fmt.pf ppf "truncated"
431
+
| `Invalid_tag t -> Fmt.pf ppf "invalid tag: %d" t
432
+
| `Invalid_vcid v -> Fmt.pf ppf "invalid vcid: %d" v
433
+
434
+
(** Decode a single event from [buf] at offset [off]. Returns the event and the
435
+
number of bytes consumed. *)
436
+
let decode_event_data buf off =
437
+
let remaining = Bytes.length buf - off in
438
+
if remaining < 3 then Error `Truncated
439
+
else
440
+
let tag = u8 buf off in
441
+
let data_len = u16_be buf (off + 1) in
442
+
if remaining < 3 + data_len then Error `Truncated
443
+
else
444
+
let data_off = off + 3 in
445
+
let consumed = 3 + data_len in
446
+
let decode_frame_dir_event mk =
447
+
if data_len < 3 then Error `Truncated
448
+
else
449
+
let spi = u16_be buf data_off in
450
+
let dir_byte = u8 buf (data_off + 2) in
451
+
let has_vcid = dir_byte land 0x80 <> 0 in
452
+
let direction = direction_of_int (dir_byte land 0x7F) in
453
+
if has_vcid && data_len >= 4 then
454
+
let v = u8 buf (data_off + 3) in
455
+
if v > 63 then Error (`Invalid_vcid v)
456
+
else Ok (mk ~spi ~direction ~vcid:(Some v), consumed)
457
+
else Ok (mk ~spi ~direction ~vcid:None, consumed)
458
+
in
459
+
match tag with
460
+
| t when t = tag_auth_failure ->
461
+
if data_len < 3 then Error `Truncated
462
+
else
463
+
let spi = u16_be buf data_off in
464
+
let reason_byte = u8 buf (data_off + 2) in
465
+
let has_vcid = reason_byte land 0x80 <> 0 in
466
+
let reason = auth_reason_of_int (reason_byte land 0x7F) in
467
+
if has_vcid && data_len >= 4 then
468
+
let v = u8 buf (data_off + 3) in
469
+
if v > 63 then Error (`Invalid_vcid v)
470
+
else Ok (Auth_failure { spi; reason; vcid = Some v }, consumed)
471
+
else Ok (Auth_failure { spi; reason; vcid = None }, consumed)
472
+
| t when t = tag_frame_protected ->
473
+
decode_frame_dir_event (fun ~spi ~direction ~vcid ->
474
+
Frame_protected { spi; direction; vcid })
475
+
| t when t = tag_frame_unprotected ->
476
+
decode_frame_dir_event (fun ~spi ~direction ~vcid ->
477
+
Frame_unprotected { spi; direction; vcid })
478
+
| t when t = tag_iv_warning ->
479
+
if data_len < 10 then Error `Truncated
480
+
else
481
+
let spi = u16_be buf data_off in
482
+
let remaining = u64_be buf (data_off + 2) in
483
+
Ok (Iv_warning { spi; remaining }, consumed)
484
+
| t when t = tag_sa_change ->
485
+
if data_len < 3 then Error `Truncated
486
+
else
487
+
let spi = u16_be buf data_off in
488
+
let transition = sa_trans_of_int (u8 buf (data_off + 2)) in
489
+
Ok (Sa_change { spi; transition }, consumed)
490
+
| t when t = tag_key_change ->
491
+
if data_len < 3 then Error `Truncated
492
+
else
493
+
let kid = u16_be buf data_off in
494
+
let transition = key_trans_of_int (u8 buf (data_off + 2)) in
495
+
Ok (Key_change { kid; transition }, consumed)
496
+
| t when t = tag_alarm_reset -> Ok (Alarm_reset, consumed)
497
+
| t when t = tag_self_test ->
498
+
let success = if data_len >= 1 then u8 buf data_off = 0 else true in
499
+
Ok (Self_test { success }, consumed)
500
+
| t when t = tag_log_erased -> Ok (Log_erased, consumed)
501
+
| t -> Error (`Invalid_tag t)
502
+
503
+
(* {1 Dump Log PDU (PID=3)}
504
+
505
+
Per CCSDS 355.1-B-1 Section 5.6.1.3:
506
+
- Command: No data field
507
+
- Reply: Variable number of TLV-encoded security events *)
508
+
509
+
type dump_log_reply = { events : event_data list }
510
+
511
+
let pp_dump_log_reply ppf r =
512
+
Fmt.pf ppf "@[<v 2>DUMP_LOG_REPLY@,%a@]"
513
+
Fmt.(list ~sep:comma pp_event_data)
514
+
r.events
515
+
516
+
let encode_dump_log_reply r =
517
+
let bufs = List.map encode_event_data r.events in
518
+
let total = List.fold_left (fun acc b -> acc + Bytes.length b) 0 bufs in
519
+
let result = Bytes.create total in
520
+
let _ =
521
+
List.fold_left
522
+
(fun off b ->
523
+
let len = Bytes.length b in
524
+
Bytes.blit b 0 result off len;
525
+
off + len)
526
+
0 bufs
527
+
in
528
+
result
529
+
530
+
let decode_dump_log_reply buf off =
531
+
let len = Bytes.length buf - off in
532
+
let rec loop acc pos =
533
+
if pos - off >= len then Ok { events = List.rev acc }
534
+
else if pos - off + 3 > len then Ok { events = List.rev acc }
535
+
else
536
+
match decode_event_data buf pos with
537
+
| Error _ -> Ok { events = List.rev acc }
538
+
| Ok (data, consumed) -> loop (data :: acc) (pos + consumed)
539
+
in
540
+
loop [] off
+184
lib/mc.mli
+184
lib/mc.mli
···
1
+
(** SDLS Monitoring & Control (CCSDS 355.1-B-1).
2
+
3
+
This module implements the Security Monitoring & Control PDU types (SG=11):
4
+
- Log Status (PID=2): Query Security Log status
5
+
- Dump Log (PID=3): Retrieve all security events
6
+
- Erase Log (PID=4): Clear Security Log
7
+
- Self-Test (PID=5): Trigger crypto self-test
8
+
- Alarm Reset (PID=7): Reset FSR alarm flag
9
+
10
+
@see <https://public.ccsds.org/Pubs/355x1b1.pdf>
11
+
CCSDS 355.1-B-1 Section 3.4.3 *)
12
+
13
+
(** {1 Log Status PDU (PID=2)} *)
14
+
15
+
type log_status_reply = {
16
+
num_events : int; (** Number of events in Security Log *)
17
+
remaining_space : int; (** Remaining space in bytes *)
18
+
}
19
+
(** Log Status Reply - Security Log status. *)
20
+
21
+
val log_status_reply_size : int
22
+
(** Size of the log status reply data in bytes (4). *)
23
+
24
+
val encode_log_status_reply : log_status_reply -> bytes
25
+
(** [encode_log_status_reply reply] encodes the reply into a fresh buffer. *)
26
+
27
+
val decode_log_status_reply :
28
+
bytes -> int -> (log_status_reply, [ `Truncated ]) result
29
+
(** [decode_log_status_reply buf off] decodes a reply from [buf] at [off]. *)
30
+
31
+
val pp_log_status_reply : log_status_reply Fmt.t
32
+
33
+
(** {1 Erase Log PDU (PID=4)} *)
34
+
35
+
type erase_log_reply = {
36
+
num_events : int; (** Number of events after erasure (should be 0) *)
37
+
remaining_space : int; (** Remaining space after erasure *)
38
+
}
39
+
(** Erase Log Reply - log status after erasure. *)
40
+
41
+
val erase_log_reply_size : int
42
+
(** Size of the erase log reply data in bytes (4). *)
43
+
44
+
val encode_erase_log_reply : erase_log_reply -> bytes
45
+
(** [encode_erase_log_reply reply] encodes the reply into a fresh buffer. *)
46
+
47
+
val decode_erase_log_reply :
48
+
bytes -> int -> (erase_log_reply, [ `Truncated ]) result
49
+
(** [decode_erase_log_reply buf off] decodes a reply from [buf] at [off]. *)
50
+
51
+
val pp_erase_log_reply : erase_log_reply Fmt.t
52
+
53
+
(** {1 Self-Test PDU (PID=5)} *)
54
+
55
+
(** Self-test result. *)
56
+
type self_test_result =
57
+
| Self_test_ok (** Self-test passed (0xxxxxxx) *)
58
+
| Self_test_failed of int (** Self-test failed with error code (1xxxxxxx) *)
59
+
60
+
type self_test_reply = { result : self_test_result }
61
+
(** Self-Test Reply. *)
62
+
63
+
val self_test_reply_size : int
64
+
(** Size of the self-test reply data in bytes (1). *)
65
+
66
+
val encode_self_test_reply : self_test_reply -> bytes
67
+
(** [encode_self_test_reply reply] encodes the reply into a fresh buffer. *)
68
+
69
+
val decode_self_test_reply :
70
+
bytes -> int -> (self_test_reply, [ `Truncated ]) result
71
+
(** [decode_self_test_reply buf off] decodes a reply from [buf] at [off]. *)
72
+
73
+
val pp_self_test_result : self_test_result Fmt.t
74
+
val pp_self_test_reply : self_test_reply Fmt.t
75
+
76
+
(** {1 Alarm Reset PDU (PID=7)}
77
+
78
+
Command only - no data field, no reply. Resets the alarm flag in the Frame
79
+
Security Report (FSR). *)
80
+
81
+
(** {1 Security Event Types}
82
+
83
+
Security events are stored in the Security Log and transmitted in Dump Log
84
+
replies. Each event is TLV-encoded: Tag (1 byte) + Length (2 bytes) + Data
85
+
(variable).
86
+
87
+
SPI and VCID values are plain ints. SPI is 16-bit (0-65535). VCID is 6-bit
88
+
(0-63) for TC/TM frames. *)
89
+
90
+
(** Authentication failure reason. *)
91
+
type auth_failure_reason =
92
+
| Bad_mac (** MAC verification failed *)
93
+
| Bad_sequence_number (** Anti-replay check failed *)
94
+
| Bad_sa (** Invalid or inactive Security Association *)
95
+
| Unknown_spi (** SPI not found *)
96
+
| Unknown_auth_reason of int (** Unrecognized reason code *)
97
+
98
+
val pp_auth_failure_reason : auth_failure_reason Fmt.t
99
+
100
+
(** SA state transition. *)
101
+
type sa_transition =
102
+
| Sa_created (** New SA created *)
103
+
| Sa_started (** SA activated *)
104
+
| Sa_stopped (** SA deactivated *)
105
+
| Sa_rekeyed (** SA rekeyed with new key *)
106
+
| Sa_expired (** SA expired *)
107
+
| Sa_deleted (** SA deleted *)
108
+
| Unknown_sa_transition of int (** Unrecognized transition code *)
109
+
110
+
val pp_sa_transition : sa_transition Fmt.t
111
+
112
+
(** Key state transition. *)
113
+
type key_transition =
114
+
| Key_received (** New key received via OTAR *)
115
+
| Key_activated (** Key activated *)
116
+
| Key_deactivated (** Key deactivated *)
117
+
| Key_destroyed (** Key securely destroyed *)
118
+
| Unknown_key_transition of int (** Unrecognized transition code *)
119
+
120
+
val pp_key_transition : key_transition Fmt.t
121
+
122
+
(** Frame direction for logging. *)
123
+
type frame_direction =
124
+
| Uplink
125
+
| Downlink
126
+
| Unknown_direction of int (** Unrecognized direction code *)
127
+
128
+
val pp_frame_direction : frame_direction Fmt.t
129
+
130
+
(** Security event payload. *)
131
+
type event_data =
132
+
| Auth_failure of {
133
+
spi : int;
134
+
reason : auth_failure_reason;
135
+
vcid : int option;
136
+
} (** Frame authentication/decryption failure *)
137
+
| Frame_protected of {
138
+
spi : int;
139
+
direction : frame_direction;
140
+
vcid : int option;
141
+
} (** Frame successfully protected *)
142
+
| Frame_unprotected of {
143
+
spi : int;
144
+
direction : frame_direction;
145
+
vcid : int option;
146
+
} (** Frame successfully unprotected *)
147
+
| Iv_warning of { spi : int; remaining : int64 }
148
+
(** IV approaching exhaustion *)
149
+
| Sa_change of { spi : int; transition : sa_transition }
150
+
(** SA state change *)
151
+
| Key_change of { kid : int; transition : key_transition }
152
+
(** Key lifecycle event *)
153
+
| Alarm_reset (** FSR alarm flag reset *)
154
+
| Self_test of { success : bool } (** Crypto self-test result *)
155
+
| Log_erased (** Security log was erased *)
156
+
157
+
val pp_event_data : event_data Fmt.t
158
+
159
+
val encode_event_data : event_data -> bytes
160
+
(** [encode_event_data e] encodes a single event as TLV (tag + length + data).
161
+
*)
162
+
163
+
type event_error = [ `Truncated | `Invalid_tag of int | `Invalid_vcid of int ]
164
+
165
+
val pp_event_error : event_error Fmt.t
166
+
167
+
val decode_event_data : bytes -> int -> (event_data * int, event_error) result
168
+
(** [decode_event_data buf off] decodes a single TLV event from [buf] at offset
169
+
[off]. Returns the event and the total number of bytes consumed. *)
170
+
171
+
(** {1 Dump Log PDU (PID=3)} *)
172
+
173
+
type dump_log_reply = { events : event_data list }
174
+
(** Dump Log Reply - all security event data. *)
175
+
176
+
val encode_dump_log_reply : dump_log_reply -> bytes
177
+
(** [encode_dump_log_reply reply] encodes the reply (concatenated TLV events).
178
+
*)
179
+
180
+
val decode_dump_log_reply : bytes -> int -> (dump_log_reply, event_error) result
181
+
(** [decode_dump_log_reply buf off] decodes a dump log reply. Stops at
182
+
truncation or end of buffer. *)
183
+
184
+
val pp_dump_log_reply : dump_log_reply Fmt.t
+825
lib/otar.ml
+825
lib/otar.ml
···
1
+
(** OTAR - Over-The-Air Rekeying (CCSDS 355.1-B-1). *)
2
+
3
+
(* {1 Types} *)
4
+
5
+
type plaintext_key = { kid : int; material : bytes }
6
+
7
+
let pp_plaintext_key ppf k =
8
+
Fmt.pf ppf "{ kid=0x%04X; material[%d] }" k.kid (Bytes.length k.material)
9
+
10
+
type encrypted_key_block = { ekid : int; ek : bytes }
11
+
12
+
type cmd = {
13
+
mkid : int;
14
+
iv : bytes;
15
+
keys : encrypted_key_block list;
16
+
mac : bytes;
17
+
}
18
+
19
+
type reply = { success : bool }
20
+
type activation_cmd = { kids : int list }
21
+
type activation_reply = { success : bool; failed_kids : int list }
22
+
type deactivation_cmd = { kids : int list }
23
+
type deactivation_reply = { success : bool; failed_kids : int list }
24
+
type verify_challenge = { kid : int; challenge : bytes }
25
+
type verify_response = { kid : int; encrypted_challenge : bytes; mac : bytes }
26
+
type verify_cmd = { challenges : verify_challenge list }
27
+
type verify_reply = { responses : verify_response list }
28
+
type destruction_cmd = { kids : int list }
29
+
type destruction_reply = { success : bool; failed_kids : int list }
30
+
type inventory_cmd = { kid_first : int; kid_last : int }
31
+
32
+
type key_state =
33
+
| Key_empty
34
+
| Key_pending
35
+
| Key_active
36
+
| Key_deprecated
37
+
| Key_destroyed
38
+
39
+
type inventory_entry = { kid : int; state : key_state }
40
+
type inventory_reply = { entries : inventory_entry list }
41
+
42
+
(* {1 Errors} *)
43
+
44
+
type error =
45
+
| Crypto_error of Sdls_crypto.error
46
+
| Auth_failure
47
+
| Invalid_iv_length
48
+
| Empty_key_list
49
+
| Key_length_mismatch
50
+
| Key_error of Key.error
51
+
| Master_key_not_found of int
52
+
| Master_key_not_active of int
53
+
| Key_not_found of int
54
+
| Key_not_pending of int
55
+
56
+
let pp_error ppf = function
57
+
| Crypto_error e -> Fmt.pf ppf "Crypto error: %a" Sdls_crypto.pp_error e
58
+
| Auth_failure -> Fmt.string ppf "Authentication failed"
59
+
| Invalid_iv_length -> Fmt.string ppf "IV must be 12 bytes"
60
+
| Empty_key_list -> Fmt.string ppf "Cannot encrypt empty key list"
61
+
| Key_length_mismatch -> Fmt.string ppf "All keys must have same length"
62
+
| Key_error e -> Fmt.pf ppf "key error: %a" Key.pp_error e
63
+
| Master_key_not_found mkid -> Fmt.pf ppf "master key not found: 0x%04X" mkid
64
+
| Master_key_not_active mkid ->
65
+
Fmt.pf ppf "master key not active: 0x%04X" mkid
66
+
| Key_not_found kid -> Fmt.pf ppf "key not found: 0x%04X" kid
67
+
| Key_not_pending kid -> Fmt.pf ppf "key not pending: 0x%04X" kid
68
+
69
+
(* {1 Helpers} *)
70
+
71
+
let trunc = function
72
+
| Error (`Truncated _) -> Error `Truncated
73
+
| Ok _ as ok -> ok
74
+
75
+
(* {1 PDU Pretty-printers} *)
76
+
77
+
let pp_encrypted_key_block ppf ekb =
78
+
Fmt.pf ppf "@[<hov 2>{ kid=0x%04X;@ ek[%d] }@]" ekb.ekid (Bytes.length ekb.ek)
79
+
80
+
let pp_cmd ppf cmd =
81
+
Fmt.pf ppf "@[<v 2>OTAR_CMD@,mkid=0x%04X@,iv=%a@,keys=@[<v>%a@]@,mac=%a@]"
82
+
cmd.mkid Hex.pp cmd.iv
83
+
Fmt.(list ~sep:comma pp_encrypted_key_block)
84
+
cmd.keys Hex.pp cmd.mac
85
+
86
+
let pp_reply ppf (r : reply) = Fmt.pf ppf "OTAR_REPLY { success=%b }" r.success
87
+
88
+
let pp_kid_list ppf kids =
89
+
Fmt.(list ~sep:comma (fun ppf k -> pf ppf "0x%04X" k)) ppf kids
90
+
91
+
let pp_activation_cmd ppf (cmd : activation_cmd) =
92
+
Fmt.pf ppf "@[<hov 2>KEY_ACTIVATION_CMD { kids=%a }@]" pp_kid_list cmd.kids
93
+
94
+
let pp_activation_reply ppf (r : activation_reply) =
95
+
Fmt.pf ppf "KEY_ACTIVATION_REPLY { success=%b; failed=%a }" r.success
96
+
pp_kid_list r.failed_kids
97
+
98
+
let pp_deactivation_cmd ppf (cmd : deactivation_cmd) =
99
+
Fmt.pf ppf "@[<hov 2>KEY_DEACTIVATION_CMD { kids=%a }@]" pp_kid_list cmd.kids
100
+
101
+
let pp_deactivation_reply ppf (r : deactivation_reply) =
102
+
Fmt.pf ppf "KEY_DEACTIVATION_REPLY { success=%b; failed=%a }" r.success
103
+
pp_kid_list r.failed_kids
104
+
105
+
let pp_verify_challenge ppf (c : verify_challenge) =
106
+
Fmt.pf ppf "@[<hov 2>{ kid=0x%04X;@ challenge=%a }@]" c.kid Hex.pp c.challenge
107
+
108
+
let pp_verify_response ppf (r : verify_response) =
109
+
Fmt.pf ppf "@[<hov 2>{ kid=0x%04X;@ enc=%a;@ mac=%a }@]" r.kid Hex.pp
110
+
r.encrypted_challenge Hex.pp r.mac
111
+
112
+
let pp_verify_cmd ppf cmd =
113
+
Fmt.pf ppf "@[<v 2>KEY_VERIFY_CMD@,%a@]"
114
+
Fmt.(list ~sep:comma pp_verify_challenge)
115
+
cmd.challenges
116
+
117
+
let pp_verify_reply ppf reply =
118
+
Fmt.pf ppf "@[<v 2>KEY_VERIFY_REPLY@,%a@]"
119
+
Fmt.(list ~sep:comma pp_verify_response)
120
+
reply.responses
121
+
122
+
let pp_destruction_cmd ppf (cmd : destruction_cmd) =
123
+
Fmt.pf ppf "@[<hov 2>KEY_DESTRUCTION_CMD { kids=%a }@]" pp_kid_list cmd.kids
124
+
125
+
let pp_destruction_reply ppf (r : destruction_reply) =
126
+
Fmt.pf ppf "KEY_DESTRUCTION_REPLY { success=%b; failed=%a }" r.success
127
+
pp_kid_list r.failed_kids
128
+
129
+
let pp_inventory_cmd ppf cmd =
130
+
Fmt.pf ppf "@[<hov 2>KEY_INV_CMD { first=0x%04X;@ last=0x%04X }@]"
131
+
cmd.kid_first cmd.kid_last
132
+
133
+
let int_of_key_state = function
134
+
| Key_empty -> 0
135
+
| Key_pending -> 1
136
+
| Key_active -> 2
137
+
| Key_deprecated -> 3
138
+
| Key_destroyed -> 4
139
+
140
+
let key_state_of_int = function
141
+
| 0 -> Some Key_empty
142
+
| 1 -> Some Key_pending
143
+
| 2 -> Some Key_active
144
+
| 3 -> Some Key_deprecated
145
+
| 4 -> Some Key_destroyed
146
+
| _ -> None
147
+
148
+
let pp_key_state ppf = function
149
+
| Key_empty -> Fmt.pf ppf "EMPTY"
150
+
| Key_pending -> Fmt.pf ppf "PENDING"
151
+
| Key_active -> Fmt.pf ppf "ACTIVE"
152
+
| Key_deprecated -> Fmt.pf ppf "DEPRECATED"
153
+
| Key_destroyed -> Fmt.pf ppf "DESTROYED"
154
+
155
+
let pp_inventory_entry ppf e =
156
+
Fmt.pf ppf "@[<hov 2>{ kid=0x%04X;@ state=%a }@]" e.kid pp_key_state e.state
157
+
158
+
let pp_inventory_reply ppf reply =
159
+
Fmt.pf ppf "@[<v 2>KEY_INV_REPLY@,%a@]"
160
+
Fmt.(list ~sep:comma pp_inventory_entry)
161
+
reply.entries
162
+
163
+
(* {1 PDU Serialization} *)
164
+
165
+
let write_cmd ~key_len:_ w cmd =
166
+
Binary.Writer.uint16_be w cmd.mkid;
167
+
Binary.Writer.bytes w cmd.iv;
168
+
List.iter
169
+
(fun ekb ->
170
+
Binary.Writer.uint16_be w ekb.ekid;
171
+
Binary.Writer.bytes w ekb.ek)
172
+
cmd.keys;
173
+
Binary.Writer.bytes w cmd.mac
174
+
175
+
let read_cmd ~key_len ~mac_len ~body_len r =
176
+
let min_len = 2 + mac_len in
177
+
if body_len < min_len then Error `Truncated
178
+
else
179
+
let mkid = Binary.Reader.uint16_be r in
180
+
let iv_len = 12 in
181
+
if body_len < 2 + iv_len + mac_len then Error `Truncated
182
+
else
183
+
let iv = Binary.Reader.bytes r iv_len in
184
+
let keys_len = body_len - 2 - iv_len - mac_len in
185
+
let key_block_size = 2 + key_len in
186
+
if keys_len < 0 || keys_len mod key_block_size <> 0 then Error `Invalid
187
+
else
188
+
let num_keys = keys_len / key_block_size in
189
+
let keys =
190
+
List.init num_keys (fun _ ->
191
+
let ekid = Binary.Reader.uint16_be r in
192
+
let ek = Binary.Reader.bytes r key_len in
193
+
{ ekid; ek })
194
+
in
195
+
let mac = Binary.Reader.bytes r mac_len in
196
+
Ok { mkid; iv; keys; mac }
197
+
198
+
let write_reply w (r : reply) =
199
+
Binary.Writer.uint8 w (if r.success then 1 else 0)
200
+
201
+
let read_reply r =
202
+
let ( let* ) = Result.bind in
203
+
let* b = trunc (Binary.Reader.try_uint8 r) in
204
+
Ok { success = b land 1 = 1 }
205
+
206
+
let write_activation_cmd w (cmd : activation_cmd) =
207
+
Binary.Writer.uint8 w (List.length cmd.kids);
208
+
List.iter (fun kid -> Binary.Writer.uint16_be w kid) cmd.kids
209
+
210
+
let read_activation_cmd r =
211
+
let ( let* ) = Result.bind in
212
+
let* num = trunc (Binary.Reader.try_uint8 r) in
213
+
let rec read_kids acc n =
214
+
if n = 0 then Ok (List.rev acc)
215
+
else
216
+
let* kid = trunc (Binary.Reader.try_uint16_be r) in
217
+
read_kids (kid :: acc) (n - 1)
218
+
in
219
+
let* kids = read_kids [] num in
220
+
Ok ({ kids } : activation_cmd)
221
+
222
+
let write_activation_reply w (r : activation_reply) =
223
+
Binary.Writer.uint8 w (if r.success then 1 else 0);
224
+
Binary.Writer.uint8 w (List.length r.failed_kids);
225
+
List.iter (fun kid -> Binary.Writer.uint16_be w kid) r.failed_kids
226
+
227
+
let read_activation_reply r =
228
+
let ( let* ) = Result.bind in
229
+
let* flags = trunc (Binary.Reader.try_uint8 r) in
230
+
let* num = trunc (Binary.Reader.try_uint8 r) in
231
+
let rec read_kids acc n =
232
+
if n = 0 then Ok (List.rev acc)
233
+
else
234
+
let* kid = trunc (Binary.Reader.try_uint16_be r) in
235
+
read_kids (kid :: acc) (n - 1)
236
+
in
237
+
let* failed_kids = read_kids [] num in
238
+
Ok ({ success = flags land 1 = 1; failed_kids } : activation_reply)
239
+
240
+
let write_deactivation_cmd w (cmd : deactivation_cmd) =
241
+
Binary.Writer.uint8 w (List.length cmd.kids);
242
+
List.iter (fun kid -> Binary.Writer.uint16_be w kid) cmd.kids
243
+
244
+
let read_deactivation_cmd r =
245
+
let ( let* ) = Result.bind in
246
+
let* num = trunc (Binary.Reader.try_uint8 r) in
247
+
let rec read_kids acc n =
248
+
if n = 0 then Ok (List.rev acc)
249
+
else
250
+
let* kid = trunc (Binary.Reader.try_uint16_be r) in
251
+
read_kids (kid :: acc) (n - 1)
252
+
in
253
+
let* kids = read_kids [] num in
254
+
Ok ({ kids } : deactivation_cmd)
255
+
256
+
let write_deactivation_reply w (r : deactivation_reply) =
257
+
Binary.Writer.uint8 w (if r.success then 1 else 0);
258
+
Binary.Writer.uint8 w (List.length r.failed_kids);
259
+
List.iter (fun kid -> Binary.Writer.uint16_be w kid) r.failed_kids
260
+
261
+
let read_deactivation_reply r =
262
+
let ( let* ) = Result.bind in
263
+
let* flags = trunc (Binary.Reader.try_uint8 r) in
264
+
let* num = trunc (Binary.Reader.try_uint8 r) in
265
+
let rec read_kids acc n =
266
+
if n = 0 then Ok (List.rev acc)
267
+
else
268
+
let* kid = trunc (Binary.Reader.try_uint16_be r) in
269
+
read_kids (kid :: acc) (n - 1)
270
+
in
271
+
let* failed_kids = read_kids [] num in
272
+
Ok ({ success = flags land 1 = 1; failed_kids } : deactivation_reply)
273
+
274
+
let challenge_len = 16
275
+
276
+
let write_verify_cmd w (cmd : verify_cmd) =
277
+
Binary.Writer.uint8 w (List.length cmd.challenges);
278
+
List.iter
279
+
(fun (c : verify_challenge) ->
280
+
Binary.Writer.uint16_be w c.kid;
281
+
Binary.Writer.bytes w c.challenge)
282
+
cmd.challenges
283
+
284
+
let read_verify_cmd r =
285
+
let ( let* ) = Result.bind in
286
+
let* num = trunc (Binary.Reader.try_uint8 r) in
287
+
let rec read_challenges acc n =
288
+
if n = 0 then Ok (List.rev acc)
289
+
else
290
+
let* kid = trunc (Binary.Reader.try_uint16_be r) in
291
+
let* challenge = trunc (Binary.Reader.try_bytes r challenge_len) in
292
+
read_challenges ({ kid; challenge } :: acc) (n - 1)
293
+
in
294
+
let* challenges = read_challenges [] num in
295
+
Ok { challenges }
296
+
297
+
let write_verify_reply w (reply : verify_reply) =
298
+
Binary.Writer.uint8 w (List.length reply.responses);
299
+
List.iter
300
+
(fun (r : verify_response) ->
301
+
Binary.Writer.uint16_be w r.kid;
302
+
Binary.Writer.bytes w r.encrypted_challenge;
303
+
Binary.Writer.bytes w r.mac)
304
+
reply.responses
305
+
306
+
let read_verify_reply r =
307
+
let ( let* ) = Result.bind in
308
+
let* num = trunc (Binary.Reader.try_uint8 r) in
309
+
let enc_len = 16 in
310
+
let mac_len = 16 in
311
+
let rec read_responses acc n =
312
+
if n = 0 then Ok (List.rev acc)
313
+
else
314
+
let* kid = trunc (Binary.Reader.try_uint16_be r) in
315
+
let* encrypted_challenge = trunc (Binary.Reader.try_bytes r enc_len) in
316
+
let* mac = trunc (Binary.Reader.try_bytes r mac_len) in
317
+
read_responses ({ kid; encrypted_challenge; mac } :: acc) (n - 1)
318
+
in
319
+
let* responses = read_responses [] num in
320
+
Ok { responses }
321
+
322
+
let write_destruction_cmd w (cmd : destruction_cmd) =
323
+
Binary.Writer.uint8 w (List.length cmd.kids);
324
+
List.iter (fun kid -> Binary.Writer.uint16_be w kid) cmd.kids
325
+
326
+
let read_destruction_cmd r =
327
+
let ( let* ) = Result.bind in
328
+
let* num = trunc (Binary.Reader.try_uint8 r) in
329
+
let rec read_kids acc n =
330
+
if n = 0 then Ok (List.rev acc)
331
+
else
332
+
let* kid = trunc (Binary.Reader.try_uint16_be r) in
333
+
read_kids (kid :: acc) (n - 1)
334
+
in
335
+
let* kids = read_kids [] num in
336
+
Ok ({ kids } : destruction_cmd)
337
+
338
+
let write_destruction_reply w (r : destruction_reply) =
339
+
Binary.Writer.uint8 w (if r.success then 1 else 0);
340
+
Binary.Writer.uint8 w (List.length r.failed_kids);
341
+
List.iter (fun kid -> Binary.Writer.uint16_be w kid) r.failed_kids
342
+
343
+
let read_destruction_reply r =
344
+
let ( let* ) = Result.bind in
345
+
let* flags = trunc (Binary.Reader.try_uint8 r) in
346
+
let* num = trunc (Binary.Reader.try_uint8 r) in
347
+
let rec read_kids acc n =
348
+
if n = 0 then Ok (List.rev acc)
349
+
else
350
+
let* kid = trunc (Binary.Reader.try_uint16_be r) in
351
+
read_kids (kid :: acc) (n - 1)
352
+
in
353
+
let* failed_kids = read_kids [] num in
354
+
Ok ({ success = flags land 1 = 1; failed_kids } : destruction_reply)
355
+
356
+
let write_inventory_cmd w cmd =
357
+
Binary.Writer.uint16_be w cmd.kid_first;
358
+
Binary.Writer.uint16_be w cmd.kid_last
359
+
360
+
let read_inventory_cmd r =
361
+
let ( let* ) = Result.bind in
362
+
let* kid_first = trunc (Binary.Reader.try_uint16_be r) in
363
+
let* kid_last = trunc (Binary.Reader.try_uint16_be r) in
364
+
Ok { kid_first; kid_last }
365
+
366
+
let write_inventory_reply w reply =
367
+
Binary.Writer.uint16_be w (List.length reply.entries);
368
+
List.iter
369
+
(fun e ->
370
+
Binary.Writer.uint16_be w e.kid;
371
+
Binary.Writer.uint8 w (int_of_key_state e.state))
372
+
reply.entries
373
+
374
+
let read_inventory_reply r =
375
+
let ( let* ) = Result.bind in
376
+
let* num = trunc (Binary.Reader.try_uint16_be r) in
377
+
let rec read_entries acc n =
378
+
if n = 0 then Ok (List.rev acc)
379
+
else
380
+
let* kid = trunc (Binary.Reader.try_uint16_be r) in
381
+
let* state_val = trunc (Binary.Reader.try_uint8 r) in
382
+
let state =
383
+
match key_state_of_int state_val with Some s -> s | None -> Key_empty
384
+
in
385
+
read_entries ({ kid; state } :: acc) (n - 1)
386
+
in
387
+
let* entries = read_entries [] num in
388
+
Ok { entries }
389
+
390
+
(* {1 Key block encoding} *)
391
+
392
+
let encode_key_blocks (keys : plaintext_key list) key_len =
393
+
let n = List.length keys in
394
+
let block_size = 2 + key_len in
395
+
let w = Binary.Writer.create (n * block_size) in
396
+
List.iter
397
+
(fun (k : plaintext_key) ->
398
+
Binary.Writer.uint16_be w k.kid;
399
+
Binary.Writer.bytes w k.material)
400
+
keys;
401
+
Binary.Writer.contents w
402
+
403
+
let decode_key_blocks buf key_len =
404
+
let len = Bytes.length buf in
405
+
let block_size = 2 + key_len in
406
+
if len mod block_size <> 0 then None
407
+
else
408
+
let n = len / block_size in
409
+
let r = Binary.Reader.of_bytes buf in
410
+
let keys =
411
+
List.init n (fun _i ->
412
+
let kid = Binary.Reader.uint16_be r in
413
+
let material = Binary.Reader.bytes r key_len in
414
+
{ kid; material })
415
+
in
416
+
Some keys
417
+
418
+
let make_aad mkid =
419
+
let w = Binary.Writer.create 2 in
420
+
Binary.Writer.uint16_be w mkid;
421
+
Binary.Writer.contents w
422
+
423
+
(* {1 Low-level Operations} *)
424
+
425
+
let encrypt_key_blocks ~master_key ~iv ~aad keys =
426
+
match keys with
427
+
| [] -> Error Empty_key_list
428
+
| first :: rest -> (
429
+
let key_len = Bytes.length first.material in
430
+
let all_same =
431
+
List.for_all (fun k -> Bytes.length k.material = key_len) rest
432
+
in
433
+
if not all_same then Error Key_length_mismatch
434
+
else if Bytes.length iv <> 12 then Error Invalid_iv_length
435
+
else
436
+
let plaintext = encode_key_blocks keys key_len in
437
+
match
438
+
Sdls_crypto.encrypt_aes_gcm ~key:master_key ~nonce:iv ~aad plaintext
439
+
with
440
+
| Error e -> Error (Crypto_error e)
441
+
| Ok ciphertext_with_tag ->
442
+
let ct_len =
443
+
Bytes.length ciphertext_with_tag - Sdls_crypto.tag_len
444
+
in
445
+
let ciphertext = Bytes.sub ciphertext_with_tag 0 ct_len in
446
+
let mac =
447
+
Bytes.sub ciphertext_with_tag ct_len Sdls_crypto.tag_len
448
+
in
449
+
Ok (ciphertext, mac))
450
+
451
+
let decrypt_key_blocks ~master_key ~iv ~aad ~ciphertext ~mac ~key_len =
452
+
if Bytes.length iv <> 12 then Error Invalid_iv_length
453
+
else
454
+
let ct_len = Bytes.length ciphertext in
455
+
let ciphertext_with_tag = Bytes.create (ct_len + Bytes.length mac) in
456
+
Bytes.blit ciphertext 0 ciphertext_with_tag 0 ct_len;
457
+
Bytes.blit mac 0 ciphertext_with_tag ct_len (Bytes.length mac);
458
+
match
459
+
Sdls_crypto.decrypt_aes_gcm ~key:master_key ~nonce:iv ~aad
460
+
ciphertext_with_tag
461
+
with
462
+
| Error Sdls_crypto.Auth_failure -> Error Auth_failure
463
+
| Error e -> Error (Crypto_error e)
464
+
| Ok plaintext -> (
465
+
match decode_key_blocks plaintext key_len with
466
+
| None -> Error Key_length_mismatch
467
+
| Some keys -> Ok keys)
468
+
469
+
(* {1 High-level Operations} *)
470
+
471
+
let encrypt_with_mkid ~master_key ~mkid ~iv keys =
472
+
let aad = make_aad mkid in
473
+
match encrypt_key_blocks ~master_key ~iv ~aad keys with
474
+
| Error e -> Error e
475
+
| Ok (ciphertext, mac) ->
476
+
let first = List.hd keys in
477
+
let key_len = Bytes.length first.material in
478
+
let block_size = 2 + key_len in
479
+
let n = Bytes.length ciphertext / block_size in
480
+
let r = Binary.Reader.of_bytes ciphertext in
481
+
let encrypted_keys =
482
+
List.init n (fun _i ->
483
+
let ekid = Binary.Reader.uint16_be r in
484
+
let ek = Binary.Reader.bytes r key_len in
485
+
{ ekid; ek })
486
+
in
487
+
Ok { mkid; iv; keys = encrypted_keys; mac }
488
+
489
+
let encrypt ~master_key ~iv keys =
490
+
encrypt_with_mkid ~master_key ~mkid:0 ~iv keys
491
+
492
+
let decrypt ~master_key cmd =
493
+
match cmd.keys with
494
+
| [] -> Error Empty_key_list
495
+
| first :: _ ->
496
+
let key_len = Bytes.length first.ek in
497
+
let aad = make_aad cmd.mkid in
498
+
let block_size = 2 + key_len in
499
+
let n = List.length cmd.keys in
500
+
let w = Binary.Writer.create (n * block_size) in
501
+
List.iter
502
+
(fun ekb ->
503
+
Binary.Writer.uint16_be w ekb.ekid;
504
+
Binary.Writer.bytes w ekb.ek)
505
+
cmd.keys;
506
+
let ciphertext = Binary.Writer.contents w in
507
+
decrypt_key_blocks ~master_key ~iv:cmd.iv ~aad ~ciphertext ~mac:cmd.mac
508
+
~key_len
509
+
510
+
(* {1 Backend Interface} *)
511
+
512
+
module type S = sig
513
+
type t
514
+
515
+
val get_master_key : t -> int -> Key.t option
516
+
val set_master_key : t -> int -> Key.t -> unit
517
+
val remove_master_key : t -> int -> unit
518
+
val list_master_keys : t -> int list
519
+
val get_session_key : t -> int -> Key.t option
520
+
val set_session_key : t -> int -> Key.t -> unit
521
+
val remove_session_key : t -> int -> unit
522
+
val list_session_keys : t -> int list
523
+
end
524
+
525
+
type t = { backend : backend; mutable verify_iv_counter : int64 }
526
+
and backend = B : (module S with type t = 'a) * 'a -> backend
527
+
528
+
module Make (B : S) = struct
529
+
let v ?(verify_iv_counter = 1L) backend =
530
+
{ backend = B ((module B), backend); verify_iv_counter }
531
+
end
532
+
533
+
module Mem : S with type t = (int, Key.t) Hashtbl.t * (int, Key.t) Hashtbl.t =
534
+
struct
535
+
type t = (int, Key.t) Hashtbl.t * (int, Key.t) Hashtbl.t
536
+
537
+
let get_master_key (mks, _) mkid = Hashtbl.find_opt mks mkid
538
+
let set_master_key (mks, _) mkid key = Hashtbl.replace mks mkid key
539
+
let remove_master_key (mks, _) mkid = Hashtbl.remove mks mkid
540
+
let list_master_keys (mks, _) = Hashtbl.to_seq_keys mks |> List.of_seq
541
+
let get_session_key (_, sks) kid = Hashtbl.find_opt sks kid
542
+
let set_session_key (_, sks) kid key = Hashtbl.replace sks kid key
543
+
let remove_session_key (_, sks) kid = Hashtbl.remove sks kid
544
+
let list_session_keys (_, sks) = Hashtbl.to_seq_keys sks |> List.of_seq
545
+
end
546
+
547
+
let in_memory ?(verify_iv_counter = 1L) () =
548
+
{
549
+
backend = B ((module Mem), (Hashtbl.create 16, Hashtbl.create 64));
550
+
verify_iv_counter;
551
+
}
552
+
553
+
(* {1 Master Key Operations} *)
554
+
555
+
let get_master_key { backend = B ((module B), backend); _ } mkid =
556
+
B.get_master_key backend mkid
557
+
558
+
let set_master_key { backend = B ((module B), backend); _ } mkid key =
559
+
B.set_master_key backend mkid key
560
+
561
+
let add_master_key t ~mkid material =
562
+
let key = Key.v ~kid:mkid ~algorithm:1 ~material:(Bytes.copy material) in
563
+
set_master_key t mkid key
564
+
565
+
let activate_master_key t mkid =
566
+
match get_master_key t mkid with
567
+
| None -> false
568
+
| Some key -> (
569
+
match Key.activate key with
570
+
| Error _ -> false
571
+
| Ok key' ->
572
+
set_master_key t mkid key';
573
+
true)
574
+
575
+
let deactivate_master_key t mkid =
576
+
match get_master_key t mkid with
577
+
| None -> false
578
+
| Some key -> (
579
+
match Key.deactivate key with
580
+
| Error _ -> false
581
+
| Ok key' ->
582
+
set_master_key t mkid key';
583
+
true)
584
+
585
+
let destroy_master_key t mkid =
586
+
match get_master_key t mkid with
587
+
| None -> false
588
+
| Some key -> (
589
+
match Key.destroy key with
590
+
| Error _ -> false
591
+
| Ok key' ->
592
+
set_master_key t mkid key';
593
+
true)
594
+
595
+
let get_master_key_material t mkid =
596
+
match get_master_key t mkid with
597
+
| None -> None
598
+
| Some key -> Key.get_material key
599
+
600
+
let remove_master_key { backend = B ((module B), backend); _ } mkid =
601
+
B.remove_master_key backend mkid
602
+
603
+
let list_master_keys { backend = B ((module B), backend); _ } =
604
+
B.list_master_keys backend
605
+
606
+
let list_active_master_keys t =
607
+
list_master_keys t
608
+
|> List.filter (fun mkid ->
609
+
match get_master_key t mkid with
610
+
| Some key when Key.state key = Key.Active -> true
611
+
| _ -> false)
612
+
613
+
(* {1 Session Key Operations} *)
614
+
615
+
let get_session_key { backend = B ((module B), backend); _ } kid =
616
+
B.get_session_key backend kid
617
+
618
+
let set_session_key { backend = B ((module B), backend); _ } kid key =
619
+
B.set_session_key backend kid key
620
+
621
+
let list_session_keys { backend = B ((module B), backend); _ } =
622
+
B.list_session_keys backend
623
+
624
+
let get_key t kid = get_session_key t kid
625
+
626
+
let get_material t kid =
627
+
match get_session_key t kid with
628
+
| None -> None
629
+
| Some key -> Key.get_material key
630
+
631
+
let active_keys t =
632
+
list_session_keys t
633
+
|> List.filter_map (fun kid ->
634
+
match get_session_key t kid with
635
+
| Some key when Key.state key = Key.Active -> Some kid
636
+
| _ -> None)
637
+
638
+
let pending_keys t =
639
+
list_session_keys t
640
+
|> List.filter_map (fun kid ->
641
+
match get_session_key t kid with
642
+
| Some key when Key.state key = Key.Pending -> Some kid
643
+
| _ -> None)
644
+
645
+
(* {1 PDU Handlers} *)
646
+
647
+
let receive t cmd =
648
+
match get_master_key t cmd.mkid with
649
+
| None -> Error (Master_key_not_found cmd.mkid)
650
+
| Some mk -> (
651
+
match Key.get_material mk with
652
+
| None -> Error (Master_key_not_active cmd.mkid)
653
+
| Some master_key -> (
654
+
match decrypt ~master_key cmd with
655
+
| Error e -> Error e
656
+
| Ok keys ->
657
+
List.iter
658
+
(fun (pk : plaintext_key) ->
659
+
let key =
660
+
Key.v ~kid:pk.kid ~algorithm:1
661
+
~material:(Bytes.copy pk.material)
662
+
in
663
+
set_session_key t pk.kid key)
664
+
keys;
665
+
Ok { success = true }))
666
+
667
+
let activation t (cmd : activation_cmd) : activation_reply =
668
+
let rec process_kids failed = function
669
+
| [] -> List.rev failed
670
+
| kid :: rest -> (
671
+
match get_session_key t kid with
672
+
| None -> process_kids (kid :: failed) rest
673
+
| Some key -> (
674
+
match Key.activate key with
675
+
| Error _ -> process_kids (kid :: failed) rest
676
+
| Ok key' ->
677
+
set_session_key t kid key';
678
+
process_kids failed rest))
679
+
in
680
+
let failed_kids = process_kids [] cmd.kids in
681
+
{ success = List.length failed_kids = 0; failed_kids }
682
+
683
+
let deactivation t (cmd : deactivation_cmd) : deactivation_reply =
684
+
let rec process_kids failed = function
685
+
| [] -> List.rev failed
686
+
| kid :: rest -> (
687
+
match get_session_key t kid with
688
+
| None -> process_kids (kid :: failed) rest
689
+
| Some key -> (
690
+
match Key.deactivate key with
691
+
| Error _ -> process_kids (kid :: failed) rest
692
+
| Ok key' ->
693
+
set_session_key t kid key';
694
+
process_kids failed rest))
695
+
in
696
+
let failed_kids = process_kids [] cmd.kids in
697
+
{ success = List.length failed_kids = 0; failed_kids }
698
+
699
+
let destruction t (cmd : destruction_cmd) : destruction_reply =
700
+
let rec process_kids failed = function
701
+
| [] -> List.rev failed
702
+
| kid :: rest -> (
703
+
match get_session_key t kid with
704
+
| None -> process_kids (kid :: failed) rest
705
+
| Some key -> (
706
+
match Key.destroy key with
707
+
| Error _ -> process_kids (kid :: failed) rest
708
+
| Ok key' ->
709
+
set_session_key t kid key';
710
+
process_kids failed rest))
711
+
in
712
+
let failed_kids = process_kids [] cmd.kids in
713
+
{ success = List.length failed_kids = 0; failed_kids }
714
+
715
+
let inventory t (cmd : inventory_cmd) =
716
+
let entries =
717
+
list_session_keys t
718
+
|> List.filter (fun kid -> kid >= cmd.kid_first && kid <= cmd.kid_last)
719
+
|> List.sort Int.compare
720
+
|> List.filter_map (fun kid ->
721
+
match get_session_key t kid with
722
+
| None -> None
723
+
| Some key ->
724
+
let state =
725
+
match Key.state key with
726
+
| Key.Empty -> Key_empty
727
+
| Key.Pending -> Key_pending
728
+
| Key.Active -> Key_active
729
+
| Key.Deprecated -> Key_deprecated
730
+
| Key.Zeroized -> Key_destroyed
731
+
in
732
+
Some { kid; state })
733
+
in
734
+
{ entries }
735
+
736
+
let iv_of_counter counter =
737
+
let iv = Bytes.make 12 '\x00' in
738
+
for i = 0 to 7 do
739
+
let shift = (7 - i) * 8 in
740
+
Bytes.set iv (4 + i)
741
+
(Char.chr (Int64.to_int (Int64.shift_right counter shift) land 0xFF))
742
+
done;
743
+
iv
744
+
745
+
let get_verify_iv_counter t = t.verify_iv_counter
746
+
let set_verify_iv_counter t counter = t.verify_iv_counter <- counter
747
+
748
+
let verification t (cmd : verify_cmd) =
749
+
let process_challenge (ch : verify_challenge) =
750
+
match get_session_key t ch.kid with
751
+
| None -> Error (Key_not_found ch.kid)
752
+
| Some key -> (
753
+
match Key.state key with
754
+
| Key.Pending | Key.Active -> (
755
+
match Key.get_material key with
756
+
| None -> Error (Key_not_found ch.kid)
757
+
| Some material -> (
758
+
let iv = iv_of_counter t.verify_iv_counter in
759
+
t.verify_iv_counter <- Int64.add t.verify_iv_counter 1L;
760
+
let aad = Bytes.empty in
761
+
match
762
+
Sdls_crypto.encrypt_aes_gcm ~key:material ~nonce:iv ~aad
763
+
ch.challenge
764
+
with
765
+
| Error e -> Error (Crypto_error e)
766
+
| Ok ciphertext_tag ->
767
+
let ct_len =
768
+
Bytes.length ciphertext_tag - Sdls_crypto.tag_len
769
+
in
770
+
let encrypted_challenge =
771
+
Bytes.sub ciphertext_tag 0 ct_len
772
+
in
773
+
let mac =
774
+
Bytes.sub ciphertext_tag ct_len Sdls_crypto.tag_len
775
+
in
776
+
Ok { kid = ch.kid; encrypted_challenge; mac }))
777
+
| _ -> Error (Key_not_pending ch.kid))
778
+
in
779
+
let rec process_all acc = function
780
+
| [] -> Ok (List.rev acc)
781
+
| ch :: rest -> (
782
+
match process_challenge ch with
783
+
| Error e -> Error e
784
+
| Ok resp -> process_all (resp :: acc) rest)
785
+
in
786
+
match process_all [] cmd.challenges with
787
+
| Error e -> Error e
788
+
| Ok responses -> Ok { responses }
789
+
790
+
(* {1 SA Integration} *)
791
+
792
+
let rekey_sa t ~ek_id ~ak_id sa =
793
+
let ek_id_int = Keyid.to_int ek_id in
794
+
let ak_id_int = Keyid.to_int ak_id in
795
+
match get_session_key t ek_id_int with
796
+
| None -> Error (Key_not_found ek_id_int)
797
+
| Some key -> (
798
+
if not (Key.is_usable key) then
799
+
Error
800
+
(Key_error
801
+
(Key.Invalid_state_transition
802
+
{ from = Key.state key; to_ = Key.Active }))
803
+
else
804
+
match get_session_key t ak_id_int with
805
+
| None -> Error (Key_not_found ak_id_int)
806
+
| Some akey ->
807
+
if not (Key.is_usable akey) then
808
+
Error
809
+
(Key_error
810
+
(Key.Invalid_state_transition
811
+
{ from = Key.state akey; to_ = Key.Active }))
812
+
else Ok (Sa.rekey ~ek_id ~ak_id sa))
813
+
814
+
(* {1 Keystore Bridge} *)
815
+
816
+
let to_keystore_id kid = Fmt.str "key_%04X" kid
817
+
818
+
let populate_keystore t store =
819
+
active_keys t
820
+
|> List.iter (fun kid ->
821
+
match get_material t kid with
822
+
| None -> ()
823
+
| Some material ->
824
+
let key_id = Keyid.of_int_exn kid in
825
+
Keystore.add store key_id material)
+230
lib/otar.mli
+230
lib/otar.mli
···
1
+
(** OTAR - Over-The-Air Rekeying (CCSDS 355.1-B-1). *)
2
+
3
+
(** {1 Types} *)
4
+
5
+
type plaintext_key = { kid : int; material : bytes }
6
+
7
+
val pp_plaintext_key : plaintext_key Fmt.t
8
+
9
+
type encrypted_key_block = { ekid : int; ek : bytes }
10
+
11
+
type cmd = {
12
+
mkid : int;
13
+
iv : bytes;
14
+
keys : encrypted_key_block list;
15
+
mac : bytes;
16
+
}
17
+
18
+
type reply = { success : bool }
19
+
type activation_cmd = { kids : int list }
20
+
type activation_reply = { success : bool; failed_kids : int list }
21
+
type deactivation_cmd = { kids : int list }
22
+
type deactivation_reply = { success : bool; failed_kids : int list }
23
+
type verify_challenge = { kid : int; challenge : bytes }
24
+
type verify_response = { kid : int; encrypted_challenge : bytes; mac : bytes }
25
+
type verify_cmd = { challenges : verify_challenge list }
26
+
type verify_reply = { responses : verify_response list }
27
+
type destruction_cmd = { kids : int list }
28
+
type destruction_reply = { success : bool; failed_kids : int list }
29
+
type inventory_cmd = { kid_first : int; kid_last : int }
30
+
31
+
type key_state =
32
+
| Key_empty
33
+
| Key_pending
34
+
| Key_active
35
+
| Key_deprecated
36
+
| Key_destroyed
37
+
38
+
val int_of_key_state : key_state -> int
39
+
val key_state_of_int : int -> key_state option
40
+
val pp_key_state : key_state Fmt.t
41
+
42
+
type inventory_entry = { kid : int; state : key_state }
43
+
type inventory_reply = { entries : inventory_entry list }
44
+
45
+
val pp_cmd : cmd Fmt.t
46
+
val pp_reply : reply Fmt.t
47
+
val pp_activation_cmd : activation_cmd Fmt.t
48
+
val pp_activation_reply : activation_reply Fmt.t
49
+
val pp_deactivation_cmd : deactivation_cmd Fmt.t
50
+
val pp_deactivation_reply : deactivation_reply Fmt.t
51
+
val pp_verify_cmd : verify_cmd Fmt.t
52
+
val pp_verify_reply : verify_reply Fmt.t
53
+
val pp_destruction_cmd : destruction_cmd Fmt.t
54
+
val pp_destruction_reply : destruction_reply Fmt.t
55
+
val pp_inventory_cmd : inventory_cmd Fmt.t
56
+
val pp_inventory_reply : inventory_reply Fmt.t
57
+
58
+
(** {1 PDU Serialization} *)
59
+
60
+
val write_cmd : key_len:int -> Binary.Writer.t -> cmd -> unit
61
+
62
+
val read_cmd :
63
+
key_len:int ->
64
+
mac_len:int ->
65
+
body_len:int ->
66
+
Binary.Reader.t ->
67
+
(cmd, [ `Truncated | `Invalid ]) result
68
+
69
+
val write_reply : Binary.Writer.t -> reply -> unit
70
+
val read_reply : Binary.Reader.t -> (reply, [ `Truncated ]) result
71
+
val write_activation_cmd : Binary.Writer.t -> activation_cmd -> unit
72
+
73
+
val read_activation_cmd :
74
+
Binary.Reader.t -> (activation_cmd, [ `Truncated ]) result
75
+
76
+
val write_activation_reply : Binary.Writer.t -> activation_reply -> unit
77
+
78
+
val read_activation_reply :
79
+
Binary.Reader.t -> (activation_reply, [ `Truncated ]) result
80
+
81
+
val write_deactivation_cmd : Binary.Writer.t -> deactivation_cmd -> unit
82
+
83
+
val read_deactivation_cmd :
84
+
Binary.Reader.t -> (deactivation_cmd, [ `Truncated ]) result
85
+
86
+
val write_deactivation_reply : Binary.Writer.t -> deactivation_reply -> unit
87
+
88
+
val read_deactivation_reply :
89
+
Binary.Reader.t -> (deactivation_reply, [ `Truncated ]) result
90
+
91
+
val write_verify_cmd : Binary.Writer.t -> verify_cmd -> unit
92
+
val read_verify_cmd : Binary.Reader.t -> (verify_cmd, [ `Truncated ]) result
93
+
val write_verify_reply : Binary.Writer.t -> verify_reply -> unit
94
+
val read_verify_reply : Binary.Reader.t -> (verify_reply, [ `Truncated ]) result
95
+
val write_destruction_cmd : Binary.Writer.t -> destruction_cmd -> unit
96
+
97
+
val read_destruction_cmd :
98
+
Binary.Reader.t -> (destruction_cmd, [ `Truncated ]) result
99
+
100
+
val write_destruction_reply : Binary.Writer.t -> destruction_reply -> unit
101
+
102
+
val read_destruction_reply :
103
+
Binary.Reader.t -> (destruction_reply, [ `Truncated ]) result
104
+
105
+
val write_inventory_cmd : Binary.Writer.t -> inventory_cmd -> unit
106
+
107
+
val read_inventory_cmd :
108
+
Binary.Reader.t -> (inventory_cmd, [ `Truncated ]) result
109
+
110
+
val write_inventory_reply : Binary.Writer.t -> inventory_reply -> unit
111
+
112
+
val read_inventory_reply :
113
+
Binary.Reader.t -> (inventory_reply, [ `Truncated ]) result
114
+
115
+
(** {1 Errors} *)
116
+
117
+
type error =
118
+
| Crypto_error of Sdls_crypto.error
119
+
| Auth_failure
120
+
| Invalid_iv_length
121
+
| Empty_key_list
122
+
| Key_length_mismatch
123
+
| Key_error of Key.error
124
+
| Master_key_not_found of int
125
+
| Master_key_not_active of int
126
+
| Key_not_found of int
127
+
| Key_not_pending of int
128
+
129
+
val pp_error : error Fmt.t
130
+
131
+
(** {1 Encryption} *)
132
+
133
+
val encrypt :
134
+
master_key:bytes -> iv:bytes -> plaintext_key list -> (cmd, error) result
135
+
136
+
val encrypt_with_mkid :
137
+
master_key:bytes ->
138
+
mkid:int ->
139
+
iv:bytes ->
140
+
plaintext_key list ->
141
+
(cmd, error) result
142
+
143
+
(** {1 Decryption} *)
144
+
145
+
val decrypt : master_key:bytes -> cmd -> (plaintext_key list, error) result
146
+
147
+
(** {1 Low-level Operations} *)
148
+
149
+
val encrypt_key_blocks :
150
+
master_key:bytes ->
151
+
iv:bytes ->
152
+
aad:bytes ->
153
+
plaintext_key list ->
154
+
(bytes * bytes, error) result
155
+
156
+
val decrypt_key_blocks :
157
+
master_key:bytes ->
158
+
iv:bytes ->
159
+
aad:bytes ->
160
+
ciphertext:bytes ->
161
+
mac:bytes ->
162
+
key_len:int ->
163
+
(plaintext_key list, error) result
164
+
165
+
(** {1 Backend Interface} *)
166
+
167
+
module type S = sig
168
+
type t
169
+
170
+
val get_master_key : t -> int -> Key.t option
171
+
val set_master_key : t -> int -> Key.t -> unit
172
+
val remove_master_key : t -> int -> unit
173
+
val list_master_keys : t -> int list
174
+
val get_session_key : t -> int -> Key.t option
175
+
val set_session_key : t -> int -> Key.t -> unit
176
+
val remove_session_key : t -> int -> unit
177
+
val list_session_keys : t -> int list
178
+
end
179
+
180
+
type t
181
+
182
+
module Make (B : S) : sig
183
+
val v : ?verify_iv_counter:int64 -> B.t -> t
184
+
end
185
+
186
+
val in_memory : ?verify_iv_counter:int64 -> unit -> t
187
+
188
+
(** {1 Master Key Operations} *)
189
+
190
+
val add_master_key : t -> mkid:int -> bytes -> unit
191
+
val activate_master_key : t -> int -> bool
192
+
val deactivate_master_key : t -> int -> bool
193
+
val destroy_master_key : t -> int -> bool
194
+
val get_master_key : t -> int -> Key.t option
195
+
val get_master_key_material : t -> int -> bytes option
196
+
val remove_master_key : t -> int -> unit
197
+
val list_master_keys : t -> int list
198
+
val list_active_master_keys : t -> int list
199
+
200
+
(** {1 Key Queries} *)
201
+
202
+
val get_key : t -> int -> Key.t option
203
+
val get_material : t -> int -> bytes option
204
+
val active_keys : t -> int list
205
+
val pending_keys : t -> int list
206
+
207
+
(** {1 PDU Handlers} *)
208
+
209
+
val receive : t -> cmd -> (reply, error) result
210
+
val activation : t -> activation_cmd -> activation_reply
211
+
val deactivation : t -> deactivation_cmd -> deactivation_reply
212
+
val destruction : t -> destruction_cmd -> destruction_reply
213
+
val inventory : t -> inventory_cmd -> inventory_reply
214
+
val verification : t -> verify_cmd -> (verify_reply, error) result
215
+
216
+
(** {1 Verification IV Counter} *)
217
+
218
+
val get_verify_iv_counter : t -> int64
219
+
val set_verify_iv_counter : t -> int64 -> unit
220
+
val iv_of_counter : int64 -> bytes
221
+
222
+
(** {1 SA Integration} *)
223
+
224
+
val rekey_sa :
225
+
t -> ek_id:Keyid.t -> ak_id:Keyid.t -> Sa.entry -> (Sa.entry, error) result
226
+
227
+
(** {1 Keystore Bridge} *)
228
+
229
+
val to_keystore_id : int -> string
230
+
val populate_keystore : t -> Keystore.t -> unit
+1092
lib/sa.ml
+1092
lib/sa.ml
···
1
+
(** Security Association (SA) types and management (CCSDS 355.0-B-2, 355.1-B-1).
2
+
3
+
SPI, SCID, and VCID are represented as bare [int] values. *)
4
+
5
+
(* {1 Types} *)
6
+
7
+
type ecs =
8
+
| Cipher_none
9
+
| AES_256_GCM
10
+
| AES_256_CBC
11
+
| AES_256_CBC_MAC
12
+
| AES_256_CCM
13
+
| AES_256_GCM_SIV
14
+
| AES_256_CTR
15
+
| ECS_agency_defined of int
16
+
17
+
type acs =
18
+
| Mac_none
19
+
| AES_256_CMAC
20
+
| HMAC_SHA_256
21
+
| HMAC_SHA_384
22
+
| HMAC_SHA_512
23
+
| AES_256_GMAC
24
+
| ACS_agency_defined of int
25
+
26
+
type state = Disabled | Unkeyed | Keyed | Operational
27
+
type abm = All | Mask of bytes
28
+
29
+
type config = {
30
+
spi : int;
31
+
gvcid : int * int;
32
+
encryption : bool;
33
+
authentication : bool;
34
+
ecs : ecs option;
35
+
acs : acs option;
36
+
iv_len : int;
37
+
mac_len : int;
38
+
sn_len : int;
39
+
arsnw : int;
40
+
abm : abm;
41
+
}
42
+
43
+
type dyn = {
44
+
lifecycle : state;
45
+
ek_id : Keyid.t;
46
+
ak_id : Keyid.t;
47
+
iv : bytes;
48
+
arsn : bytes;
49
+
replay_window : Bitv.t;
50
+
}
51
+
52
+
type entry = { config : config; dyn : dyn }
53
+
type security_header = { spi : int; iv : bytes; sn : bytes }
54
+
type security_trailer = { mac : bytes }
55
+
56
+
(* {1 Constants} *)
57
+
58
+
let max_sn_len = 8
59
+
let max_arsnw = 65536
60
+
61
+
(* {1 Pretty-printing} *)
62
+
63
+
let pp_state ppf = function
64
+
| Disabled -> Fmt.pf ppf "disabled"
65
+
| Unkeyed -> Fmt.pf ppf "unkeyed"
66
+
| Keyed -> Fmt.pf ppf "keyed"
67
+
| Operational -> Fmt.pf ppf "operational"
68
+
69
+
let int_of_state = function
70
+
| Disabled -> 0
71
+
| Unkeyed -> 1
72
+
| Keyed -> 2
73
+
| Operational -> 3
74
+
75
+
let state_of_int = function
76
+
| 0 -> Some Disabled
77
+
| 1 -> Some Unkeyed
78
+
| 2 -> Some Keyed
79
+
| 3 -> Some Operational
80
+
| _ -> None
81
+
82
+
let int_of_ecs = function
83
+
| Cipher_none -> 0
84
+
| AES_256_GCM -> 1
85
+
| AES_256_CBC -> 2
86
+
| AES_256_CBC_MAC -> 3
87
+
| AES_256_CCM -> 4
88
+
| AES_256_GCM_SIV -> 5
89
+
| AES_256_CTR -> 6
90
+
| ECS_agency_defined n -> n
91
+
92
+
let ecs_of_int = function
93
+
| 0 -> Some Cipher_none
94
+
| 1 -> Some AES_256_GCM
95
+
| 2 -> Some AES_256_CBC
96
+
| 3 -> Some AES_256_CBC_MAC
97
+
| 4 -> Some AES_256_CCM
98
+
| 5 -> Some AES_256_GCM_SIV
99
+
| 6 -> Some AES_256_CTR
100
+
| n when n >= 128 -> Some (ECS_agency_defined n)
101
+
| _ -> None
102
+
103
+
let pp_ecs ppf = function
104
+
| Cipher_none -> Fmt.pf ppf "CIPHER_NONE"
105
+
| AES_256_GCM -> Fmt.pf ppf "AES-256-GCM"
106
+
| AES_256_CBC -> Fmt.pf ppf "AES-256-CBC"
107
+
| AES_256_CBC_MAC -> Fmt.pf ppf "AES-256-CBC-MAC"
108
+
| AES_256_CCM -> Fmt.pf ppf "AES-256-CCM"
109
+
| AES_256_GCM_SIV -> Fmt.pf ppf "AES-256-GCM-SIV"
110
+
| AES_256_CTR -> Fmt.pf ppf "AES-256-CTR"
111
+
| ECS_agency_defined n -> Fmt.pf ppf "ECS-AGENCY(%d)" n
112
+
113
+
let int_of_acs = function
114
+
| Mac_none -> 0
115
+
| AES_256_CMAC -> 1
116
+
| HMAC_SHA_256 -> 2
117
+
| HMAC_SHA_384 -> 3
118
+
| HMAC_SHA_512 -> 4
119
+
| AES_256_GMAC -> 5
120
+
| ACS_agency_defined n -> n
121
+
122
+
let acs_of_int = function
123
+
| 0 -> Some Mac_none
124
+
| 1 -> Some AES_256_CMAC
125
+
| 2 -> Some HMAC_SHA_256
126
+
| 3 -> Some HMAC_SHA_384
127
+
| 4 -> Some HMAC_SHA_512
128
+
| 5 -> Some AES_256_GMAC
129
+
| n when n >= 128 -> Some (ACS_agency_defined n)
130
+
| _ -> None
131
+
132
+
let pp_acs ppf = function
133
+
| Mac_none -> Fmt.pf ppf "MAC_NONE"
134
+
| AES_256_CMAC -> Fmt.pf ppf "AES-256-CMAC"
135
+
| HMAC_SHA_256 -> Fmt.pf ppf "HMAC-SHA-256"
136
+
| HMAC_SHA_384 -> Fmt.pf ppf "HMAC-SHA-384"
137
+
| HMAC_SHA_512 -> Fmt.pf ppf "HMAC-SHA-512"
138
+
| AES_256_GMAC -> Fmt.pf ppf "AES-256-GMAC"
139
+
| ACS_agency_defined n -> Fmt.pf ppf "ACS-AGENCY(%d)" n
140
+
141
+
let pp_config ppf (c : config) =
142
+
Fmt.pf ppf
143
+
"@[<v 2>SA Config:@,\
144
+
spi=%d gvcid=(%d,%d)@,\
145
+
enc=%b auth=%b@,\
146
+
ecs=%a acs=%a@,\
147
+
iv_len=%d mac_len=%d sn_len=%d arsnw=%d@]"
148
+
c.spi (fst c.gvcid) (snd c.gvcid) c.encryption c.authentication
149
+
Fmt.(option ~none:(any "none") pp_ecs)
150
+
c.ecs
151
+
Fmt.(option ~none:(any "none") pp_acs)
152
+
c.acs c.iv_len c.mac_len c.sn_len c.arsnw
153
+
154
+
let pp_dyn ppf d =
155
+
Fmt.pf ppf "@[<v 2>SA Dyn:@,lifecycle=%a@,ek_id=%a ak_id=%a@,iv=%a arsn=%a@]"
156
+
pp_state d.lifecycle Keyid.pp d.ek_id Keyid.pp d.ak_id Hex.pp d.iv Hex.pp
157
+
d.arsn
158
+
159
+
let pp_entry ppf sa =
160
+
Fmt.pf ppf "@[<v>%a@,%a@]" pp_config sa.config pp_dyn sa.dyn
161
+
162
+
(* {1 Config/Dyn Serialization} *)
163
+
164
+
let serialization_version = 0
165
+
166
+
let write_config w (c : config) =
167
+
let map =
168
+
Cbor.map
169
+
[
170
+
(Cbor.text "spi", Cbor.uint c.spi);
171
+
(Cbor.text "scid", Cbor.uint (fst c.gvcid));
172
+
(Cbor.text "vcid", Cbor.uint (snd c.gvcid));
173
+
(Cbor.text "enc", if c.encryption then Cbor.True else Cbor.False);
174
+
(Cbor.text "auth", if c.authentication then Cbor.True else Cbor.False);
175
+
( Cbor.text "ecs",
176
+
match c.ecs with
177
+
| None -> Cbor.Null
178
+
| Some e -> Cbor.uint (int_of_ecs e) );
179
+
( Cbor.text "acs",
180
+
match c.acs with
181
+
| None -> Cbor.Null
182
+
| Some a -> Cbor.uint (int_of_acs a) );
183
+
(Cbor.text "iv", Cbor.uint c.iv_len);
184
+
(Cbor.text "mac", Cbor.uint c.mac_len);
185
+
(Cbor.text "sn", Cbor.uint c.sn_len);
186
+
(Cbor.text "arsnw", Cbor.uint c.arsnw);
187
+
( Cbor.text "abm",
188
+
match c.abm with All -> Cbor.Null | Mask m -> Cbor.bytes m );
189
+
]
190
+
in
191
+
Binary.Writer.uint8 w serialization_version;
192
+
Cbor.write w map
193
+
194
+
let read_config r =
195
+
let ( let* ) = Option.bind in
196
+
let* () = Result.to_option (Binary.Reader.ensure r 1) in
197
+
let version = Binary.Reader.uint8 r in
198
+
if version <> serialization_version then None
199
+
else
200
+
match Cbor.read r with
201
+
| Error _ -> None
202
+
| Ok cbor ->
203
+
let* pairs = Cbor.to_map cbor in
204
+
let find key = List.assoc_opt (Cbor.text key) pairs in
205
+
let* spi = find "spi" |> Option.map Cbor.to_int |> Option.join in
206
+
let* scid = find "scid" |> Option.map Cbor.to_int |> Option.join in
207
+
let* vcid = find "vcid" |> Option.map Cbor.to_int |> Option.join in
208
+
let encryption =
209
+
find "enc"
210
+
|> Option.map (( = ) Cbor.True)
211
+
|> Option.value ~default:true
212
+
in
213
+
let authentication =
214
+
find "auth"
215
+
|> Option.map (( = ) Cbor.True)
216
+
|> Option.value ~default:true
217
+
in
218
+
let ecs =
219
+
match find "ecs" with
220
+
| Some Cbor.Null | None -> None
221
+
| Some v -> Cbor.to_int v |> Option.map ecs_of_int |> Option.join
222
+
in
223
+
let acs =
224
+
match find "acs" with
225
+
| Some Cbor.Null | None -> None
226
+
| Some v -> Cbor.to_int v |> Option.map acs_of_int |> Option.join
227
+
in
228
+
let iv_len =
229
+
find "iv" |> Option.map Cbor.to_int |> Option.join
230
+
|> Option.value ~default:12
231
+
in
232
+
let mac_len =
233
+
find "mac" |> Option.map Cbor.to_int |> Option.join
234
+
|> Option.value ~default:16
235
+
in
236
+
let sn_len =
237
+
find "sn" |> Option.map Cbor.to_int |> Option.join
238
+
|> Option.value ~default:0
239
+
in
240
+
let arsnw =
241
+
find "arsnw" |> Option.map Cbor.to_int |> Option.join
242
+
|> Option.value ~default:1024
243
+
in
244
+
let abm =
245
+
match find "abm" with
246
+
| Some Cbor.Null | None -> All
247
+
| Some v -> (
248
+
match Cbor.to_bytes v with Some m -> Mask m | None -> All)
249
+
in
250
+
Some
251
+
{
252
+
spi;
253
+
gvcid = (scid, vcid);
254
+
encryption;
255
+
authentication;
256
+
ecs;
257
+
acs;
258
+
iv_len;
259
+
mac_len;
260
+
sn_len;
261
+
arsnw;
262
+
abm;
263
+
}
264
+
265
+
let pack_bitv (bv : Bitv.t) : bytes =
266
+
let len = Bitv.length bv in
267
+
let byte_len = (len + 7) / 8 in
268
+
let buf = Bytes.make byte_len '\x00' in
269
+
for i = 0 to len - 1 do
270
+
if Bitv.get bv i then begin
271
+
let byte_idx = i / 8 in
272
+
let bit_idx = i mod 8 in
273
+
let b = Bytes.get_uint8 buf byte_idx in
274
+
Bytes.set_uint8 buf byte_idx (b lor (1 lsl bit_idx))
275
+
end
276
+
done;
277
+
buf
278
+
279
+
let unpack_bitv ~size (buf : bytes) : Bitv.t =
280
+
let bv = Bitv.create size false in
281
+
for i = 0 to size - 1 do
282
+
let byte_idx = i / 8 in
283
+
let bit_idx = i mod 8 in
284
+
if byte_idx < Bytes.length buf then begin
285
+
let b = Bytes.get_uint8 buf byte_idx in
286
+
if b land (1 lsl bit_idx) <> 0 then Bitv.set bv i true
287
+
end
288
+
done;
289
+
bv
290
+
291
+
let write_dyn w (d : dyn) =
292
+
let window_bytes = pack_bitv d.replay_window in
293
+
let map =
294
+
Cbor.map
295
+
[
296
+
(Cbor.text "lc", Cbor.uint (int_of_state d.lifecycle));
297
+
(Cbor.text "ek", Cbor.uint (Keyid.to_int d.ek_id));
298
+
(Cbor.text "ak", Cbor.uint (Keyid.to_int d.ak_id));
299
+
(Cbor.text "iv", Cbor.bytes d.iv);
300
+
(Cbor.text "arsn", Cbor.bytes d.arsn);
301
+
(Cbor.text "rws", Cbor.uint (Bitv.length d.replay_window));
302
+
(Cbor.text "rw", Cbor.bytes window_bytes);
303
+
]
304
+
in
305
+
Binary.Writer.uint8 w serialization_version;
306
+
Cbor.write w map
307
+
308
+
let read_dyn r =
309
+
let ( let* ) = Option.bind in
310
+
let* () = Result.to_option (Binary.Reader.ensure r 1) in
311
+
let version = Binary.Reader.uint8 r in
312
+
if version <> serialization_version then None
313
+
else
314
+
match Cbor.read r with
315
+
| Error _ -> None
316
+
| Ok cbor ->
317
+
let* pairs = Cbor.to_map cbor in
318
+
let find key = List.assoc_opt (Cbor.text key) pairs in
319
+
let* lc_v = find "lc" |> Option.map Cbor.to_int |> Option.join in
320
+
let* ek_v = find "ek" |> Option.map Cbor.to_int |> Option.join in
321
+
let* ak_v = find "ak" |> Option.map Cbor.to_int |> Option.join in
322
+
let* iv = find "iv" |> Option.map Cbor.to_bytes |> Option.join in
323
+
let* arsn = find "arsn" |> Option.map Cbor.to_bytes |> Option.join in
324
+
let* rws = find "rws" |> Option.map Cbor.to_int |> Option.join in
325
+
let* rw = find "rw" |> Option.map Cbor.to_bytes |> Option.join in
326
+
let* lifecycle = state_of_int lc_v in
327
+
let* ek_id = Keyid.of_int ek_v in
328
+
let* ak_id = Keyid.of_int ak_v in
329
+
Some
330
+
{
331
+
lifecycle;
332
+
ek_id;
333
+
ak_id;
334
+
iv;
335
+
arsn;
336
+
replay_window = unpack_bitv ~size:rws rw;
337
+
}
338
+
339
+
(* {1 Bytes arithmetic} *)
340
+
341
+
let incr_be b =
342
+
let r = Bytes.copy b in
343
+
let rec go i carry =
344
+
if i < 0 || carry = 0 then ()
345
+
else begin
346
+
let v = Char.code (Bytes.get r i) + carry in
347
+
Bytes.set r i (Char.chr (v land 0xFF));
348
+
go (i - 1) (v lsr 8)
349
+
end
350
+
in
351
+
go (Bytes.length r - 1) 1;
352
+
r
353
+
354
+
let incr_be_n b n =
355
+
let r = Bytes.copy b in
356
+
let rec go i carry =
357
+
if i < 0 || carry = 0 then ()
358
+
else begin
359
+
let v = Char.code (Bytes.get r i) + carry in
360
+
Bytes.set r i (Char.chr (v land 0xFF));
361
+
go (i - 1) (v lsr 8)
362
+
end
363
+
in
364
+
go (Bytes.length r - 1) n;
365
+
r
366
+
367
+
let increment_iv = incr_be
368
+
let increment_arsn = incr_be
369
+
let is_iv_max iv = Bytes.for_all (fun c -> c = '\xFF') iv
370
+
let increment_iv_safe iv = if is_iv_max iv then None else Some (incr_be iv)
371
+
372
+
let iv_remaining iv =
373
+
let len = Bytes.length iv in
374
+
let rec count_ff i =
375
+
if i >= len then len
376
+
else if Bytes.get iv i = '\xFF' then count_ff (i + 1)
377
+
else i
378
+
in
379
+
let ff_count = count_ff 0 in
380
+
if ff_count >= 8 then begin
381
+
let remaining = ref 0L in
382
+
for i = max 0 (len - 8) to len - 1 do
383
+
remaining :=
384
+
Int64.add
385
+
(Int64.shift_left !remaining 8)
386
+
(Int64.of_int (0xFF - Char.code (Bytes.get iv i)))
387
+
done;
388
+
!remaining
389
+
end
390
+
else Int64.max_int
391
+
392
+
let is_iv_near_max ?(threshold = 1000L) iv = iv_remaining iv < threshold
393
+
394
+
let cmp_be a b =
395
+
let len_a = Bytes.length a and len_b = Bytes.length b in
396
+
let max_len = max len_a len_b in
397
+
let get_byte buf len i =
398
+
let offset = max_len - len in
399
+
if i < offset then 0 else Char.code (Bytes.get buf (i - offset))
400
+
in
401
+
let rec go i =
402
+
if i >= max_len then 0
403
+
else
404
+
let ca = get_byte a len_a i and cb = get_byte b len_b i in
405
+
if ca <> cb then compare ca cb else go (i + 1)
406
+
in
407
+
go 0
408
+
409
+
let diff_be a b =
410
+
let len_a = Bytes.length a and len_b = Bytes.length b in
411
+
let max_len = max len_a len_b in
412
+
let get_byte buf len i =
413
+
let offset = max_len - len in
414
+
if i < offset then 0 else Char.code (Bytes.get buf (i - offset))
415
+
in
416
+
let rec go i acc =
417
+
if i >= max_len then acc
418
+
else go (i + 1) ((acc * 256) + get_byte a len_a i - get_byte b len_b i)
419
+
in
420
+
go 0 0
421
+
422
+
let diff_be_bounded a b ~limit =
423
+
let len_a = Bytes.length a and len_b = Bytes.length b in
424
+
let max_len = max len_a len_b in
425
+
let get_byte buf len i =
426
+
let offset = max_len - len in
427
+
if i < offset then 0 else Char.code (Bytes.get buf (i - offset))
428
+
in
429
+
let rec go i acc borrow =
430
+
if i >= max_len then if borrow = 0 && acc <= limit then Some acc else None
431
+
else
432
+
let va = get_byte a len_a i and vb = get_byte b len_b i in
433
+
let acc' = (acc lsl 8) + va - vb - borrow in
434
+
if acc' < 0 then None
435
+
else if acc' > limit then None
436
+
else go (i + 1) acc' 0
437
+
in
438
+
go 0 0 0
439
+
440
+
(* {1 Anti-replay} *)
441
+
442
+
let index_of_sn ~window_size sn =
443
+
if window_size <= 0 then 0
444
+
else
445
+
let len = Bytes.length sn in
446
+
let rec go acc i =
447
+
if i >= len then acc
448
+
else
449
+
go
450
+
(((acc mod window_size * 256) + Char.code (Bytes.get sn i))
451
+
mod window_size)
452
+
(i + 1)
453
+
in
454
+
go 0 0
455
+
456
+
let is_zero b = Bytes.for_all (fun c -> c = '\x00') b
457
+
458
+
let check_anti_replay ~config ~dyn sn =
459
+
if config.arsnw = 0 || config.sn_len = 0 then true
460
+
else
461
+
let c = cmp_be sn dyn.arsn in
462
+
if c > 0 then true
463
+
else if c = 0 then
464
+
if is_zero dyn.arsn then
465
+
let ws = Bitv.length dyn.replay_window in
466
+
not (Bitv.get dyn.replay_window (index_of_sn ~window_size:ws sn))
467
+
else false
468
+
else
469
+
match diff_be_bounded dyn.arsn sn ~limit:config.arsnw with
470
+
| None -> false
471
+
| Some _ ->
472
+
let ws = Bitv.length dyn.replay_window in
473
+
not (Bitv.get dyn.replay_window (index_of_sn ~window_size:ws sn))
474
+
475
+
let update_replay_window ~config:_ ~dyn sn =
476
+
let c = cmp_be sn dyn.arsn in
477
+
let window_size = Bitv.length dyn.replay_window in
478
+
let window = Bitv.copy dyn.replay_window in
479
+
if c > 0 then begin
480
+
let old_arsn = dyn.arsn in
481
+
let advance =
482
+
match diff_be_bounded sn dyn.arsn ~limit:window_size with
483
+
| Some d -> d
484
+
| None -> window_size
485
+
in
486
+
if advance >= window_size then Bitv.fill window 0 window_size false
487
+
else
488
+
for i = 0 to advance - 1 do
489
+
Bitv.set window
490
+
(index_of_sn ~window_size (incr_be_n old_arsn (i + 1)))
491
+
false
492
+
done;
493
+
Bitv.set window (index_of_sn ~window_size sn) true;
494
+
if not (is_zero old_arsn) then
495
+
Bitv.set window (index_of_sn ~window_size old_arsn) true;
496
+
{ dyn with arsn = sn; replay_window = window }
497
+
end
498
+
else if c = 0 then begin
499
+
if is_zero dyn.arsn then begin
500
+
let window = Bitv.copy dyn.replay_window in
501
+
Bitv.set window (index_of_sn ~window_size sn) true;
502
+
{ dyn with replay_window = window }
503
+
end
504
+
else dyn
505
+
end
506
+
else begin
507
+
Bitv.set window (index_of_sn ~window_size sn) true;
508
+
{ dyn with replay_window = window }
509
+
end
510
+
511
+
(* {1 SA Config Validation} *)
512
+
513
+
let is_aead_ecs = function
514
+
| Some AES_256_GCM | Some AES_256_CCM | Some AES_256_GCM_SIV -> true
515
+
| _ -> false
516
+
517
+
type config_error =
518
+
| Aead_requires_authentication of ecs
519
+
| Encryption_without_cipher
520
+
| Authentication_without_mac
521
+
| Auth_only_requires_acs
522
+
523
+
let pp_config_error ppf = function
524
+
| Aead_requires_authentication ecs ->
525
+
Fmt.pf ppf "%a is AEAD - authentication must be true" pp_ecs ecs
526
+
| Encryption_without_cipher ->
527
+
Fmt.pf ppf "encryption=true requires a valid encryption cipher (ecs)"
528
+
| Authentication_without_mac ->
529
+
Fmt.pf ppf "authentication=true requires a valid MAC algorithm (acs)"
530
+
| Auth_only_requires_acs ->
531
+
Fmt.pf ppf
532
+
"authentication-only mode (encryption=false) requires acs to be set"
533
+
534
+
let validate_config_params ~encryption ~authentication ~ecs ~acs =
535
+
if encryption && is_aead_ecs ecs && not authentication then
536
+
Error (Aead_requires_authentication (Option.get ecs))
537
+
else if encryption && (ecs = None || ecs = Some Cipher_none) then
538
+
Error Encryption_without_cipher
539
+
else if
540
+
authentication && (not encryption) && (acs = None || acs = Some Mac_none)
541
+
then Error Auth_only_requires_acs
542
+
else Ok ()
543
+
544
+
(* {1 SA Constructors} *)
545
+
546
+
let default_key_id = Keyid.of_int_exn 0
547
+
548
+
let config ?(encryption = true) ?(authentication = true)
549
+
?(ecs = Some AES_256_GCM) ?(acs = Some AES_256_CMAC) ?(iv_len = 12)
550
+
?(mac_len = 16) ?(sn_len = 4) ?(arsnw = 1024) ?(abm = All) ~spi ~scid ~vcid
551
+
() =
552
+
(match validate_config_params ~encryption ~authentication ~ecs ~acs with
553
+
| Ok () -> ()
554
+
| Error e -> invalid_arg (Format.asprintf "Sa.config: %a" pp_config_error e));
555
+
let sn_len = max 0 (min sn_len max_sn_len) in
556
+
let arsnw = max 0 (min arsnw max_arsnw) in
557
+
{
558
+
spi;
559
+
gvcid = (scid, vcid);
560
+
encryption;
561
+
authentication;
562
+
ecs;
563
+
acs;
564
+
iv_len;
565
+
mac_len;
566
+
sn_len;
567
+
arsnw;
568
+
abm;
569
+
}
570
+
571
+
let config_result ?(encryption = true) ?(authentication = true)
572
+
?(ecs = Some AES_256_GCM) ?(acs = Some AES_256_CMAC) ?(iv_len = 12)
573
+
?(mac_len = 16) ?(sn_len = 4) ?(arsnw = 1024) ?(abm = All) ~spi ~scid ~vcid
574
+
() =
575
+
match validate_config_params ~encryption ~authentication ~ecs ~acs with
576
+
| Error e -> Error e
577
+
| Ok () ->
578
+
let sn_len = max 0 (min sn_len max_sn_len) in
579
+
let arsnw = max 0 (min arsnw max_arsnw) in
580
+
Ok
581
+
{
582
+
spi;
583
+
gvcid = (scid, vcid);
584
+
encryption;
585
+
authentication;
586
+
ecs;
587
+
acs;
588
+
iv_len;
589
+
mac_len;
590
+
sn_len;
591
+
arsnw;
592
+
abm;
593
+
}
594
+
595
+
let dyn ?(lifecycle = Operational) ?(ek_id = default_key_id)
596
+
?(ak_id = default_key_id) ~config () =
597
+
let arsn_len = if config.sn_len > 0 then config.sn_len else 0 in
598
+
{
599
+
lifecycle;
600
+
ek_id;
601
+
ak_id;
602
+
iv = Bytes.make config.iv_len '\x00';
603
+
arsn = Bytes.make arsn_len '\x00';
604
+
replay_window = Bitv.create (max 1 config.arsnw) false;
605
+
}
606
+
607
+
let v ?(encryption = true) ?(authentication = true) ?(ecs = Some AES_256_GCM)
608
+
?(acs = None) ?(ek_id = default_key_id) ?(ak_id = default_key_id)
609
+
?(iv_len = 12) ?(mac_len = 16) ?(sn_len = 4) ?(arsnw = 1024) ~spi ~scid
610
+
~vcid () =
611
+
let cfg =
612
+
config ~encryption ~authentication ~ecs ~acs ~iv_len ~mac_len ~sn_len ~arsnw
613
+
~spi ~scid ~vcid ()
614
+
in
615
+
let dyn = dyn ~lifecycle:Operational ~ek_id ~ak_id ~config:cfg () in
616
+
{ config = cfg; dyn }
617
+
618
+
let gcm_only ~spi ~scid ~vcid =
619
+
v ~encryption:true ~authentication:true ~ecs:(Some AES_256_GCM) ~acs:None
620
+
~iv_len:12 ~mac_len:16 ~sn_len:4 ~spi ~scid ~vcid ()
621
+
622
+
let auth_only ~spi ~scid ~vcid =
623
+
v ~encryption:false ~authentication:true ~ecs:None ~acs:(Some AES_256_CMAC)
624
+
~iv_len:0 ~mac_len:16 ~sn_len:4 ~spi ~scid ~vcid ()
625
+
626
+
(* {1 SA Store} *)
627
+
628
+
module type BACKEND = sig
629
+
type t
630
+
631
+
val get_config : t -> int -> config option
632
+
val get_dyn : t -> int -> dyn option
633
+
val set_config : t -> int -> config -> unit
634
+
val set_dyn : t -> int -> dyn -> unit
635
+
val remove : t -> int -> unit
636
+
val list : t -> int list
637
+
end
638
+
639
+
type t = Store : (module BACKEND with type t = 'a) * 'a -> t
640
+
641
+
module Make (B : BACKEND) = struct
642
+
let v backend = Store ((module B), backend)
643
+
end
644
+
645
+
module Int_map = Map.Make (Int)
646
+
647
+
module Mem : BACKEND with type t = (config * dyn) Int_map.t ref = struct
648
+
type t = (config * dyn) Int_map.t ref
649
+
650
+
let get_config store spi = Option.map fst (Int_map.find_opt spi !store)
651
+
let get_dyn store spi = Option.map snd (Int_map.find_opt spi !store)
652
+
653
+
let set_config store spi cfg =
654
+
let d =
655
+
match Int_map.find_opt spi !store with
656
+
| Some (_, d) -> d
657
+
| None -> dyn ~config:cfg ()
658
+
in
659
+
store := Int_map.add spi (cfg, d) !store
660
+
661
+
let set_dyn store spi d =
662
+
match Int_map.find_opt spi !store with
663
+
| Some (c, _) -> store := Int_map.add spi (c, d) !store
664
+
| None -> ()
665
+
666
+
let remove store spi = store := Int_map.remove spi !store
667
+
let list store = Int_map.bindings !store |> List.map fst
668
+
end
669
+
670
+
let in_memory () = Store ((module Mem), ref Int_map.empty)
671
+
let get_config (Store ((module B), backend)) spi = B.get_config backend spi
672
+
let get_dyn (Store ((module B), backend)) spi = B.get_dyn backend spi
673
+
674
+
let set_config (Store ((module B), backend)) spi cfg =
675
+
B.set_config backend spi cfg
676
+
677
+
let set_dyn (Store ((module B), backend)) spi d = B.set_dyn backend spi d
678
+
let remove (Store ((module B), backend)) spi = B.remove backend spi
679
+
let list (Store ((module B), backend)) = B.list backend
680
+
681
+
let get store spi =
682
+
match (get_config store spi, get_dyn store spi) with
683
+
| Some config, Some dyn -> Some { config; dyn }
684
+
| _ -> None
685
+
686
+
let set store spi sa =
687
+
set_config store spi sa.config;
688
+
set_dyn store spi sa.dyn
689
+
690
+
(* {1 SA Management} *)
691
+
692
+
type mgmt_error =
693
+
| Invalid_state_transition of { from : state; to_ : state }
694
+
| No_key_assigned
695
+
| Invalid_arsn_length of { expected : int; actual : int }
696
+
| Invalid_arsnw of { value : int; max : int }
697
+
698
+
let pp_mgmt_error ppf = function
699
+
| Invalid_state_transition { from; to_ } ->
700
+
Fmt.pf ppf "invalid SA state transition: %a -> %a" pp_state from pp_state
701
+
to_
702
+
| No_key_assigned -> Fmt.pf ppf "no encryption/authentication key assigned"
703
+
| Invalid_arsn_length { expected; actual } ->
704
+
Fmt.pf ppf "invalid ARSN length: expected %d, got %d" expected actual
705
+
| Invalid_arsnw { value; max } ->
706
+
Fmt.pf ppf "invalid ARSNW: %d (max %d)" value max
707
+
708
+
type status = {
709
+
spi : int;
710
+
state : state;
711
+
iv : bytes;
712
+
arsn : bytes;
713
+
arsnw : int;
714
+
frames_until_iv_exhaustion : int option;
715
+
}
716
+
717
+
let pp_status ppf st =
718
+
Fmt.pf ppf
719
+
"@[<v>SA Status:@,\
720
+
\ SPI: %d@,\
721
+
\ State: %a@,\
722
+
\ IV: %s@,\
723
+
\ ARSN: %s@,\
724
+
\ ARSNW: %d@,\
725
+
\ Frames until IV exhaustion: %s@]"
726
+
st.spi pp_state st.state (Hex.encode st.iv) (Hex.encode st.arsn) st.arsnw
727
+
(match st.frames_until_iv_exhaustion with
728
+
| None -> ">2^32 (very large)"
729
+
| Some n -> string_of_int n)
730
+
731
+
let start (sa : entry) : (entry, mgmt_error) result =
732
+
match sa.dyn.lifecycle with
733
+
| Keyed -> Ok { sa with dyn = { sa.dyn with lifecycle = Operational } }
734
+
| Operational -> Ok sa
735
+
| other ->
736
+
Error (Invalid_state_transition { from = other; to_ = Operational })
737
+
738
+
let stop (sa : entry) : (entry, mgmt_error) result =
739
+
match sa.dyn.lifecycle with
740
+
| Operational -> Ok { sa with dyn = { sa.dyn with lifecycle = Keyed } }
741
+
| Keyed -> Ok sa
742
+
| other -> Error (Invalid_state_transition { from = other; to_ = Keyed })
743
+
744
+
let rekey ?(reset_iv = true) ?(reset_arsn = true) ~ek_id ~ak_id sa =
745
+
let iv = if reset_iv then Bytes.make sa.config.iv_len '\x00' else sa.dyn.iv in
746
+
let arsn, replay_window =
747
+
if reset_arsn then
748
+
( Bytes.make (Bytes.length sa.dyn.arsn) '\x00',
749
+
Bitv.create (max 1 sa.config.arsnw) false )
750
+
else (sa.dyn.arsn, sa.dyn.replay_window)
751
+
in
752
+
{ sa with dyn = { sa.dyn with ek_id; ak_id; iv; arsn; replay_window } }
753
+
754
+
let expire sa =
755
+
{
756
+
sa with
757
+
dyn =
758
+
{
759
+
lifecycle = Unkeyed;
760
+
ek_id = default_key_id;
761
+
ak_id = default_key_id;
762
+
iv = Bytes.make sa.config.iv_len '\x00';
763
+
arsn = Bytes.make (Bytes.length sa.dyn.arsn) '\x00';
764
+
replay_window = Bitv.create (max 1 sa.config.arsnw) false;
765
+
};
766
+
}
767
+
768
+
let status sa =
769
+
let frames_until_iv_exhaustion =
770
+
if sa.config.iv_len = 0 then None
771
+
else if sa.config.iv_len > 4 then None
772
+
else
773
+
let max_val = 1 lsl (sa.config.iv_len * 8) in
774
+
let current =
775
+
let rec go acc i =
776
+
if i >= sa.config.iv_len then acc
777
+
else go ((acc * 256) + Char.code (Bytes.get sa.dyn.iv i)) (i + 1)
778
+
in
779
+
go 0 0
780
+
in
781
+
Some (max_val - current - 1)
782
+
in
783
+
{
784
+
spi = sa.config.spi;
785
+
state = sa.dyn.lifecycle;
786
+
iv = Bytes.copy sa.dyn.iv;
787
+
arsn = Bytes.copy sa.dyn.arsn;
788
+
arsnw = sa.config.arsnw;
789
+
frames_until_iv_exhaustion;
790
+
}
791
+
792
+
let set_arsn ~arsn sa =
793
+
let expected_len = if sa.config.sn_len > 0 then sa.config.sn_len else 0 in
794
+
if Bytes.length arsn <> expected_len then
795
+
Error
796
+
(Invalid_arsn_length
797
+
{ expected = expected_len; actual = Bytes.length arsn })
798
+
else
799
+
Ok
800
+
{
801
+
sa with
802
+
dyn =
803
+
{
804
+
sa.dyn with
805
+
arsn = Bytes.copy arsn;
806
+
replay_window = Bitv.create (max 1 sa.config.arsnw) true;
807
+
};
808
+
}
809
+
810
+
let set_arsnw ~arsnw sa =
811
+
if arsnw < 0 || arsnw > max_arsnw then
812
+
Error (Invalid_arsnw { value = arsnw; max = max_arsnw })
813
+
else
814
+
Ok
815
+
{
816
+
config = { sa.config with arsnw };
817
+
dyn = { sa.dyn with replay_window = Bitv.create (max 1 arsnw) false };
818
+
}
819
+
820
+
let unkeyed ~spi ~scid ~vcid =
821
+
let cfg = config ~spi ~scid ~vcid () in
822
+
let dyn = dyn ~lifecycle:Unkeyed ~config:cfg () in
823
+
{ config = cfg; dyn }
824
+
825
+
let keyed ~spi ~scid ~vcid ~ek_id ~ak_id =
826
+
let cfg = config ~spi ~scid ~vcid () in
827
+
let dyn = dyn ~lifecycle:Keyed ~ek_id ~ak_id ~config:cfg () in
828
+
{ config = cfg; dyn }
829
+
830
+
(* {1 SA PDU Wire Formats} *)
831
+
832
+
let read_spi r =
833
+
let v = Binary.Reader.uint16_be r in
834
+
if v >= 0 && v <= 0xFFFF then Ok v else Error `Invalid
835
+
836
+
let read_scid r =
837
+
let v = Binary.Reader.uint16_be r in
838
+
if v >= 0 && v <= 0xFFFF then Ok v else Error `Invalid
839
+
840
+
let read_vcid r =
841
+
let v = Binary.Reader.uint8 r in
842
+
if v >= 0 && v <= 63 then Ok v else Error `Invalid
843
+
844
+
let read_keyid r =
845
+
match Keyid.of_int (Binary.Reader.uint16_be r) with
846
+
| None -> Error `Invalid
847
+
| Some v -> Ok v
848
+
849
+
type create_cmd = {
850
+
spi : int;
851
+
scid : int;
852
+
vcid : int;
853
+
ecs : ecs option;
854
+
acs : acs option;
855
+
iv_len : int;
856
+
mac_len : int;
857
+
sn_len : int;
858
+
arsnw : int;
859
+
abm : abm;
860
+
}
861
+
862
+
let pp_create_cmd ppf cmd =
863
+
Fmt.pf ppf
864
+
"@[<v 2>SA_CREATE_CMD@,\
865
+
spi=%d scid=%d vcid=%d@,\
866
+
ecs=%a acs=%a@,\
867
+
iv_len=%d mac_len=%d sn_len=%d arsnw=%d@]"
868
+
cmd.spi cmd.scid cmd.vcid
869
+
Fmt.(option ~none:(any "none") pp_ecs)
870
+
cmd.ecs
871
+
Fmt.(option ~none:(any "none") pp_acs)
872
+
cmd.acs cmd.iv_len cmd.mac_len cmd.sn_len cmd.arsnw
873
+
874
+
let write_create_cmd w cmd =
875
+
let has_ecs = Option.is_some cmd.ecs in
876
+
let has_acs = Option.is_some cmd.acs in
877
+
let abm_bytes = match cmd.abm with All -> Bytes.empty | Mask m -> m in
878
+
let abm_len = Bytes.length abm_bytes in
879
+
Binary.Writer.uint16_be w cmd.spi;
880
+
Binary.Writer.uint16_be w cmd.scid;
881
+
Binary.Writer.uint8 w cmd.vcid;
882
+
let flags =
883
+
(if has_ecs then 0x80 else 0)
884
+
lor (if has_acs then 0x40 else 0)
885
+
lor if abm_len > 0 then 0x20 else 0
886
+
in
887
+
Binary.Writer.uint8 w flags;
888
+
(match cmd.ecs with
889
+
| Some e -> Binary.Writer.uint8 w (int_of_ecs e)
890
+
| None -> ());
891
+
(match cmd.acs with
892
+
| Some a -> Binary.Writer.uint8 w (int_of_acs a)
893
+
| None -> ());
894
+
Binary.Writer.uint8 w cmd.iv_len;
895
+
Binary.Writer.uint8 w cmd.mac_len;
896
+
Binary.Writer.uint8 w cmd.sn_len;
897
+
Binary.Writer.uint16_be w cmd.arsnw;
898
+
if abm_len > 0 then Binary.Writer.bytes w abm_bytes
899
+
900
+
let read_create_cmd r =
901
+
let ( let* ) = Result.bind in
902
+
if Binary.Reader.remaining r < 10 then Error `Truncated
903
+
else
904
+
let* spi = read_spi r in
905
+
let* scid = read_scid r in
906
+
let* vcid = read_vcid r in
907
+
let flags = Binary.Reader.uint8 r in
908
+
let has_ecs = flags land 0x80 <> 0 in
909
+
let has_acs = flags land 0x40 <> 0 in
910
+
let has_abm = flags land 0x20 <> 0 in
911
+
let ecs =
912
+
if has_ecs then
913
+
if Binary.Reader.remaining r < 1 then None
914
+
else ecs_of_int (Binary.Reader.uint8 r)
915
+
else None
916
+
in
917
+
let acs =
918
+
if has_acs then
919
+
if Binary.Reader.remaining r < 1 then None
920
+
else acs_of_int (Binary.Reader.uint8 r)
921
+
else None
922
+
in
923
+
if Binary.Reader.remaining r < 5 then Error `Truncated
924
+
else
925
+
let iv_len = Binary.Reader.uint8 r in
926
+
let mac_len = Binary.Reader.uint8 r in
927
+
let sn_len = Binary.Reader.uint8 r in
928
+
let arsnw = Binary.Reader.uint16_be r in
929
+
let abm =
930
+
if has_abm && Binary.Reader.remaining r > 0 then
931
+
Mask (Binary.Reader.bytes r (Binary.Reader.remaining r))
932
+
else All
933
+
in
934
+
Ok { spi; scid; vcid; ecs; acs; iv_len; mac_len; sn_len; arsnw; abm }
935
+
936
+
type delete_cmd = { spi : int }
937
+
938
+
let pp_delete_cmd ppf cmd = Fmt.pf ppf "SA_DELETE_CMD { spi=%d }" cmd.spi
939
+
let write_delete_cmd w cmd = Binary.Writer.uint16_be w cmd.spi
940
+
941
+
let read_delete_cmd r =
942
+
if Binary.Reader.remaining r < 2 then Error `Truncated
943
+
else
944
+
let spi = Binary.Reader.uint16_be r in
945
+
if spi >= 0 && spi <= 0xFFFF then Ok { spi } else Error `Invalid
946
+
947
+
type set_arsn_cmd = { spi : int; arsn : bytes }
948
+
949
+
let pp_set_arsn_cmd ppf (cmd : set_arsn_cmd) =
950
+
Fmt.pf ppf "SA_SET_ARSN_CMD { spi=%d; arsn=%a }" cmd.spi Hex.pp cmd.arsn
951
+
952
+
let write_set_arsn_cmd w cmd =
953
+
Binary.Writer.uint16_be w cmd.spi;
954
+
Binary.Writer.bytes w cmd.arsn
955
+
956
+
let read_set_arsn_cmd ~sn_len r =
957
+
let ( let* ) = Result.bind in
958
+
if Binary.Reader.remaining r < 2 + sn_len then Error `Truncated
959
+
else
960
+
let* spi = read_spi r in
961
+
let arsn = Binary.Reader.bytes r sn_len in
962
+
Ok { spi; arsn }
963
+
964
+
type set_arsnw_cmd = { spi : int; arsnw : int }
965
+
966
+
let pp_set_arsnw_cmd ppf (cmd : set_arsnw_cmd) =
967
+
Fmt.pf ppf "SA_SET_ARSNW_CMD { spi=%d; arsnw=%d }" cmd.spi cmd.arsnw
968
+
969
+
let write_set_arsnw_cmd w (cmd : set_arsnw_cmd) =
970
+
Binary.Writer.uint16_be w cmd.spi;
971
+
Binary.Writer.uint16_be w cmd.arsnw
972
+
973
+
let read_set_arsnw_cmd r =
974
+
let ( let* ) = Result.bind in
975
+
if Binary.Reader.remaining r < 4 then Error `Truncated
976
+
else
977
+
let* spi = read_spi r in
978
+
let arsnw = Binary.Reader.uint16_be r in
979
+
Ok { spi; arsnw }
980
+
981
+
type rekey_cmd = { spi : int; ekid : Keyid.t }
982
+
983
+
let pp_rekey_cmd ppf (cmd : rekey_cmd) =
984
+
Fmt.pf ppf "SA_REKEY_CMD { spi=%d; ekid=%a }" cmd.spi Keyid.pp cmd.ekid
985
+
986
+
let write_rekey_cmd w (cmd : rekey_cmd) =
987
+
Binary.Writer.uint16_be w cmd.spi;
988
+
Binary.Writer.uint16_be w (Keyid.to_int cmd.ekid)
989
+
990
+
let read_rekey_cmd r =
991
+
let ( let* ) = Result.bind in
992
+
if Binary.Reader.remaining r < 4 then Error `Truncated
993
+
else
994
+
let* spi = read_spi r in
995
+
let* ekid = read_keyid r in
996
+
Ok { spi; ekid }
997
+
998
+
type expire_cmd = { spi : int }
999
+
1000
+
let pp_expire_cmd ppf (cmd : expire_cmd) =
1001
+
Fmt.pf ppf "SA_EXPIRE_CMD { spi=%d }" cmd.spi
1002
+
1003
+
let write_expire_cmd w (cmd : expire_cmd) = Binary.Writer.uint16_be w cmd.spi
1004
+
1005
+
let read_expire_cmd r =
1006
+
if Binary.Reader.remaining r < 2 then Error `Truncated
1007
+
else match read_spi r with Ok spi -> Ok { spi } | Error _ as e -> e
1008
+
1009
+
type status_reply = {
1010
+
spi : int;
1011
+
state : state;
1012
+
ecs : ecs option;
1013
+
acs : acs option;
1014
+
iv_len : int;
1015
+
mac_len : int;
1016
+
sn_len : int;
1017
+
arsnw : int;
1018
+
}
1019
+
1020
+
let pp_status_reply ppf r =
1021
+
Fmt.pf ppf
1022
+
"@[<v 2>SA_STATUS_REPLY@,\
1023
+
spi=%d state=%a@,\
1024
+
ecs=%a acs=%a@,\
1025
+
iv_len=%d mac_len=%d sn_len=%d arsnw=%d@]"
1026
+
r.spi pp_state r.state
1027
+
Fmt.(option ~none:(any "none") pp_ecs)
1028
+
r.ecs
1029
+
Fmt.(option ~none:(any "none") pp_acs)
1030
+
r.acs r.iv_len r.mac_len r.sn_len r.arsnw
1031
+
1032
+
let write_status_reply w r =
1033
+
let has_ecs = Option.is_some r.ecs and has_acs = Option.is_some r.acs in
1034
+
Binary.Writer.uint16_be w r.spi;
1035
+
Binary.Writer.uint8 w (int_of_state r.state);
1036
+
let flags = (if has_ecs then 0x80 else 0) lor if has_acs then 0x40 else 0 in
1037
+
Binary.Writer.uint8 w flags;
1038
+
(match r.ecs with
1039
+
| Some e -> Binary.Writer.uint8 w (int_of_ecs e)
1040
+
| None -> ());
1041
+
(match r.acs with
1042
+
| Some a -> Binary.Writer.uint8 w (int_of_acs a)
1043
+
| None -> ());
1044
+
Binary.Writer.uint8 w r.iv_len;
1045
+
Binary.Writer.uint8 w r.mac_len;
1046
+
Binary.Writer.uint8 w r.sn_len;
1047
+
Binary.Writer.uint16_be w r.arsnw
1048
+
1049
+
let read_status_reply r =
1050
+
let ( let* ) = Result.bind in
1051
+
if Binary.Reader.remaining r < 9 then Error `Truncated
1052
+
else
1053
+
let* spi = read_spi r in
1054
+
let state_v = Binary.Reader.uint8 r in
1055
+
match state_of_int state_v with
1056
+
| None -> Error `Invalid
1057
+
| Some state ->
1058
+
let flags = Binary.Reader.uint8 r in
1059
+
let has_ecs = flags land 0x80 <> 0 and has_acs = flags land 0x40 <> 0 in
1060
+
let need_rest =
1061
+
(if has_ecs then 1 else 0) + (if has_acs then 1 else 0) + 5
1062
+
in
1063
+
if Binary.Reader.remaining r < need_rest then Error `Truncated
1064
+
else
1065
+
let ecs =
1066
+
if has_ecs then ecs_of_int (Binary.Reader.uint8 r) else None
1067
+
in
1068
+
let acs =
1069
+
if has_acs then acs_of_int (Binary.Reader.uint8 r) else None
1070
+
in
1071
+
let iv_len = Binary.Reader.uint8 r in
1072
+
let mac_len = Binary.Reader.uint8 r in
1073
+
let sn_len = Binary.Reader.uint8 r in
1074
+
let arsnw = Binary.Reader.uint16_be r in
1075
+
Ok { spi; state; ecs; acs; iv_len; mac_len; sn_len; arsnw }
1076
+
1077
+
type read_arsn_reply = { spi : int; arsn : bytes }
1078
+
1079
+
let pp_read_arsn_reply ppf r =
1080
+
Fmt.pf ppf "SA_READ_ARSN_REPLY { spi=%d; arsn=%a }" r.spi Hex.pp r.arsn
1081
+
1082
+
let write_read_arsn_reply w r =
1083
+
Binary.Writer.uint16_be w r.spi;
1084
+
Binary.Writer.bytes w r.arsn
1085
+
1086
+
let read_read_arsn_reply ~sn_len r =
1087
+
let ( let* ) = Result.bind in
1088
+
if Binary.Reader.remaining r < 2 + sn_len then Error `Truncated
1089
+
else
1090
+
let* spi = read_spi r in
1091
+
let arsn = Binary.Reader.bytes r sn_len in
1092
+
Ok { spi; arsn }
+252
lib/sa.mli
+252
lib/sa.mli
···
1
+
(** Security Association (SA) types and management (CCSDS 355.0-B-2, 355.1-B-1).
2
+
3
+
SPI, SCID, and VCID are represented as bare [int] values. *)
4
+
5
+
(** {1 Cipher Suites} *)
6
+
7
+
type ecs =
8
+
| Cipher_none
9
+
| AES_256_GCM
10
+
| AES_256_CBC
11
+
| AES_256_CBC_MAC
12
+
| AES_256_CCM
13
+
| AES_256_GCM_SIV
14
+
| AES_256_CTR
15
+
| ECS_agency_defined of int
16
+
17
+
val int_of_ecs : ecs -> int
18
+
val ecs_of_int : int -> ecs option
19
+
val pp_ecs : ecs Fmt.t
20
+
21
+
type acs =
22
+
| Mac_none
23
+
| AES_256_CMAC
24
+
| HMAC_SHA_256
25
+
| HMAC_SHA_384
26
+
| HMAC_SHA_512
27
+
| AES_256_GMAC
28
+
| ACS_agency_defined of int
29
+
30
+
val int_of_acs : acs -> int
31
+
val acs_of_int : int -> acs option
32
+
val pp_acs : acs Fmt.t
33
+
34
+
(** {1 SA State} *)
35
+
36
+
type state = Disabled | Unkeyed | Keyed | Operational
37
+
38
+
val pp_state : state Fmt.t
39
+
val int_of_state : state -> int
40
+
val state_of_int : int -> state option
41
+
42
+
(** {1 Authentication Bit Mask} *)
43
+
44
+
type abm = All | Mask of bytes
45
+
46
+
type config = {
47
+
spi : int; (** Security Parameter Index (16-bit) *)
48
+
gvcid : int * int; (** (SCID, VCID) *)
49
+
encryption : bool;
50
+
authentication : bool;
51
+
ecs : ecs option;
52
+
acs : acs option;
53
+
iv_len : int;
54
+
mac_len : int;
55
+
sn_len : int;
56
+
arsnw : int;
57
+
abm : abm;
58
+
}
59
+
60
+
val pp_config : config Fmt.t
61
+
62
+
type dyn = {
63
+
lifecycle : state;
64
+
ek_id : Keyid.t;
65
+
ak_id : Keyid.t;
66
+
iv : bytes;
67
+
arsn : bytes;
68
+
replay_window : Bitv.t;
69
+
}
70
+
71
+
val pp_dyn : dyn Fmt.t
72
+
73
+
(** {1 Combined SA} *)
74
+
75
+
type entry = { config : config; dyn : dyn }
76
+
77
+
val pp_entry : entry Fmt.t
78
+
79
+
(** {1 Serialization} *)
80
+
81
+
val write_config : Binary.Writer.t -> config -> unit
82
+
val read_config : Binary.Reader.t -> config option
83
+
val write_dyn : Binary.Writer.t -> dyn -> unit
84
+
val read_dyn : Binary.Reader.t -> dyn option
85
+
86
+
(** {1 Security Header/Trailer} *)
87
+
88
+
type security_header = { spi : int; iv : bytes; sn : bytes }
89
+
type security_trailer = { mac : bytes }
90
+
91
+
(** {1 Constants} *)
92
+
93
+
val max_sn_len : int
94
+
val max_arsnw : int
95
+
96
+
(** {1 IV/ARSN Management} *)
97
+
98
+
val increment_iv : bytes -> bytes
99
+
val increment_arsn : bytes -> bytes
100
+
val is_iv_max : bytes -> bool
101
+
val increment_iv_safe : bytes -> bytes option
102
+
val iv_remaining : bytes -> int64
103
+
val is_iv_near_max : ?threshold:int64 -> bytes -> bool
104
+
val cmp_be : bytes -> bytes -> int
105
+
val diff_be : bytes -> bytes -> int
106
+
val diff_be_bounded : bytes -> bytes -> limit:int -> int option
107
+
108
+
(** {1 Anti-Replay} *)
109
+
110
+
val check_anti_replay : config:config -> dyn:dyn -> bytes -> bool
111
+
val update_replay_window : config:config -> dyn:dyn -> bytes -> dyn
112
+
113
+
(** {1 SA Config Validation} *)
114
+
115
+
type config_error =
116
+
| Aead_requires_authentication of ecs
117
+
| Encryption_without_cipher
118
+
| Authentication_without_mac
119
+
| Auth_only_requires_acs
120
+
121
+
val pp_config_error : config_error Fmt.t
122
+
123
+
(** {1 SA Constructors} *)
124
+
125
+
val config :
126
+
?encryption:bool ->
127
+
?authentication:bool ->
128
+
?ecs:ecs option ->
129
+
?acs:acs option ->
130
+
?iv_len:int ->
131
+
?mac_len:int ->
132
+
?sn_len:int ->
133
+
?arsnw:int ->
134
+
?abm:abm ->
135
+
spi:int ->
136
+
scid:int ->
137
+
vcid:int ->
138
+
unit ->
139
+
config
140
+
141
+
val config_result :
142
+
?encryption:bool ->
143
+
?authentication:bool ->
144
+
?ecs:ecs option ->
145
+
?acs:acs option ->
146
+
?iv_len:int ->
147
+
?mac_len:int ->
148
+
?sn_len:int ->
149
+
?arsnw:int ->
150
+
?abm:abm ->
151
+
spi:int ->
152
+
scid:int ->
153
+
vcid:int ->
154
+
unit ->
155
+
(config, config_error) result
156
+
157
+
val dyn :
158
+
?lifecycle:state ->
159
+
?ek_id:Keyid.t ->
160
+
?ak_id:Keyid.t ->
161
+
config:config ->
162
+
unit ->
163
+
dyn
164
+
165
+
val v :
166
+
?encryption:bool ->
167
+
?authentication:bool ->
168
+
?ecs:ecs option ->
169
+
?acs:acs option ->
170
+
?ek_id:Keyid.t ->
171
+
?ak_id:Keyid.t ->
172
+
?iv_len:int ->
173
+
?mac_len:int ->
174
+
?sn_len:int ->
175
+
?arsnw:int ->
176
+
spi:int ->
177
+
scid:int ->
178
+
vcid:int ->
179
+
unit ->
180
+
entry
181
+
182
+
val gcm_only : spi:int -> scid:int -> vcid:int -> entry
183
+
val auth_only : spi:int -> scid:int -> vcid:int -> entry
184
+
185
+
(** {1 SA Store} *)
186
+
187
+
module type BACKEND = sig
188
+
type t
189
+
190
+
val get_config : t -> int -> config option
191
+
val get_dyn : t -> int -> dyn option
192
+
val set_config : t -> int -> config -> unit
193
+
val set_dyn : t -> int -> dyn -> unit
194
+
val remove : t -> int -> unit
195
+
val list : t -> int list
196
+
end
197
+
198
+
type t
199
+
200
+
module Make (B : BACKEND) : sig
201
+
val v : B.t -> t
202
+
end
203
+
204
+
val in_memory : unit -> t
205
+
val get_config : t -> int -> config option
206
+
val get_dyn : t -> int -> dyn option
207
+
val set_config : t -> int -> config -> unit
208
+
val set_dyn : t -> int -> dyn -> unit
209
+
val remove : t -> int -> unit
210
+
val list : t -> int list
211
+
val get : t -> int -> entry option
212
+
val set : t -> int -> entry -> unit
213
+
214
+
(** {1 SA Management Functions (SDLS-EP)} *)
215
+
216
+
type mgmt_error =
217
+
| Invalid_state_transition of { from : state; to_ : state }
218
+
| No_key_assigned
219
+
| Invalid_arsn_length of { expected : int; actual : int }
220
+
| Invalid_arsnw of { value : int; max : int }
221
+
222
+
val pp_mgmt_error : mgmt_error Fmt.t
223
+
224
+
type status = {
225
+
spi : int;
226
+
state : state;
227
+
iv : bytes;
228
+
arsn : bytes;
229
+
arsnw : int;
230
+
frames_until_iv_exhaustion : int option;
231
+
}
232
+
233
+
val pp_status : status Fmt.t
234
+
val start : entry -> (entry, mgmt_error) result
235
+
val stop : entry -> (entry, mgmt_error) result
236
+
237
+
val rekey :
238
+
?reset_iv:bool ->
239
+
?reset_arsn:bool ->
240
+
ek_id:Keyid.t ->
241
+
ak_id:Keyid.t ->
242
+
entry ->
243
+
entry
244
+
245
+
val expire : entry -> entry
246
+
val status : entry -> status
247
+
val set_arsn : arsn:bytes -> entry -> (entry, mgmt_error) result
248
+
val set_arsnw : arsnw:int -> entry -> (entry, mgmt_error) result
249
+
val unkeyed : spi:int -> scid:int -> vcid:int -> entry
250
+
251
+
val keyed :
252
+
spi:int -> scid:int -> vcid:int -> ek_id:Keyid.t -> ak_id:Keyid.t -> entry
+583
lib/sdls.ml
+583
lib/sdls.ml
···
1
+
(** Space Data Link Security (CCSDS 355.0-B-2). *)
2
+
3
+
(* {1 Error types} *)
4
+
5
+
type error =
6
+
| Unknown_sa of int
7
+
| SA_not_operational of int
8
+
| Crypto_error of Sdls_crypto.error
9
+
| Auth_failure
10
+
| Anti_replay_failure of { received : bytes; window : int }
11
+
| Invalid_frame_length
12
+
| Missing_key of Keyid.t
13
+
| Unsupported_ecs of Sa.ecs
14
+
| Unsupported_acs of Sa.acs
15
+
| IV_exhausted
16
+
| Invalid_mac_len of { expected : int; actual : int }
17
+
| Invalid_abm
18
+
| Abm_too_short of { expected : int; actual : int }
19
+
| Invalid_iv_len of { min_required : int; actual : int }
20
+
| Invalid_key_len of { key_id : Keyid.t; expected : int; actual : int }
21
+
| Persistence_failure of string
22
+
23
+
let pp_error ppf = function
24
+
| Unknown_sa _ -> Fmt.pf ppf "unknown security association"
25
+
| SA_not_operational _ -> Fmt.pf ppf "security association not operational"
26
+
| Crypto_error e -> Fmt.pf ppf "crypto error: %a" Sdls_crypto.pp_error e
27
+
| Auth_failure -> Fmt.pf ppf "authentication failure"
28
+
| Anti_replay_failure _ -> Fmt.pf ppf "anti-replay check failed"
29
+
| Invalid_frame_length -> Fmt.pf ppf "invalid frame length"
30
+
| IV_exhausted -> Fmt.pf ppf "IV exhausted - rekey required"
31
+
| Missing_key _ -> Fmt.pf ppf "missing cryptographic key"
32
+
| Unsupported_ecs _ -> Fmt.pf ppf "unsupported encryption cipher"
33
+
| Unsupported_acs _ -> Fmt.pf ppf "unsupported authentication cipher"
34
+
| Invalid_mac_len _ -> Fmt.pf ppf "invalid MAC length configuration"
35
+
| Invalid_abm -> Fmt.pf ppf "invalid ABM configuration"
36
+
| Abm_too_short _ -> Fmt.pf ppf "ABM mask too short for header"
37
+
| Invalid_iv_len _ -> Fmt.pf ppf "invalid IV length configuration"
38
+
| Invalid_key_len _ -> Fmt.pf ppf "invalid key length"
39
+
| Persistence_failure _ -> Fmt.pf ppf "SA state persistence failed"
40
+
41
+
let pp_error_debug ppf = function
42
+
| Unknown_sa spi -> Fmt.pf ppf "unknown SA for SPI %d" spi
43
+
| SA_not_operational spi -> Fmt.pf ppf "SA not operational: SPI %d" spi
44
+
| Crypto_error e -> Fmt.pf ppf "crypto error: %a" Sdls_crypto.pp_error_debug e
45
+
| Auth_failure -> Fmt.pf ppf "authentication failure"
46
+
| Anti_replay_failure { received; window } ->
47
+
Fmt.pf ppf "anti-replay failure: received %d bytes, window %d"
48
+
(Bytes.length received) window
49
+
| Invalid_frame_length -> Fmt.pf ppf "invalid frame length"
50
+
| IV_exhausted -> Fmt.pf ppf "IV/nonce exhausted - SA must be rekeyed"
51
+
| Missing_key id -> Fmt.pf ppf "missing key: %a" Keyid.pp id
52
+
| Unsupported_ecs ecs ->
53
+
Fmt.pf ppf "unsupported encryption cipher: %a" Sa.pp_ecs ecs
54
+
| Unsupported_acs acs ->
55
+
Fmt.pf ppf "unsupported authentication cipher: %a" Sa.pp_acs acs
56
+
| Invalid_mac_len { expected; actual } ->
57
+
Fmt.pf ppf "AEAD requires %d-byte tag, SA has mac_len=%d" expected actual
58
+
| Invalid_abm -> Fmt.pf ppf "ABM is all-zeros - would authenticate nothing"
59
+
| Abm_too_short { expected; actual } ->
60
+
Fmt.pf ppf "ABM mask too short: need %d bytes, have %d" expected actual
61
+
| Invalid_iv_len { min_required; actual } ->
62
+
Fmt.pf ppf "AEAD requires iv_len = %d, SA has iv_len=%d" min_required
63
+
actual
64
+
| Invalid_key_len { key_id; expected; actual } ->
65
+
Fmt.pf ppf "key %a has %d bytes, expected %d" Keyid.pp key_id actual
66
+
expected
67
+
| Persistence_failure msg -> Fmt.pf ppf "SA state persistence failed: %s" msg
68
+
69
+
let auth_failure_of_error = function
70
+
| Auth_failure -> Some Mc.Bad_mac
71
+
| Anti_replay_failure _ -> Some Mc.Bad_sequence_number
72
+
| SA_not_operational _ -> Some Mc.Bad_sa
73
+
| Unknown_sa _ -> Some Mc.Unknown_spi
74
+
| Missing_key _ -> Some Mc.Bad_sa
75
+
| _ -> None
76
+
77
+
(* {1 Security header/trailer} *)
78
+
79
+
let sec_hdr_len (sa : Sa.entry) = 2 + sa.config.iv_len + sa.config.sn_len
80
+
81
+
let write_security_header w (sh : Sa.security_header) =
82
+
Binary.Writer.uint16_be w sh.spi;
83
+
Binary.Writer.bytes w sh.iv;
84
+
Binary.Writer.bytes w sh.sn
85
+
86
+
let read_security_header ~(sa : Sa.entry) r =
87
+
let need = sec_hdr_len sa in
88
+
match Binary.Reader.ensure r need with
89
+
| Error (`Truncated _) -> Error Invalid_frame_length
90
+
| Ok () ->
91
+
let spi = Binary.Reader.uint16_be r in
92
+
let iv = Binary.Reader.bytes r sa.config.iv_len in
93
+
let sn = Binary.Reader.bytes r sa.config.sn_len in
94
+
Ok Sa.{ spi; iv; sn }
95
+
96
+
let write_security_trailer w (st : Sa.security_trailer) =
97
+
Binary.Writer.bytes w st.mac
98
+
99
+
let read_security_trailer ~(sa : Sa.entry) r =
100
+
match Binary.Reader.ensure r sa.config.mac_len with
101
+
| Error (`Truncated _) -> Error Invalid_frame_length
102
+
| Ok () -> Ok Sa.{ mac = Binary.Reader.bytes r sa.config.mac_len }
103
+
104
+
let encode_security_header (sh : Sa.security_header) =
105
+
let len = 2 + Bytes.length sh.iv + Bytes.length sh.sn in
106
+
let w = Binary.Writer.create len in
107
+
write_security_header w sh;
108
+
Binary.Writer.contents w
109
+
110
+
(* {1 Nonce construction} *)
111
+
112
+
let nonce_of_iv iv =
113
+
let len = Bytes.length iv in
114
+
if len = 12 then Bytes.copy iv
115
+
else if len > 12 then Bytes.sub iv (len - 12) 12
116
+
else
117
+
let nonce = Bytes.make 12 '\x00' in
118
+
Bytes.blit iv 0 nonce (12 - len) len;
119
+
nonce
120
+
121
+
(* {1 ABM} *)
122
+
123
+
let apply_abm_mask mask aad =
124
+
let result = Bytes.copy aad in
125
+
let mask_len = min (Bytes.length mask) (Bytes.length result) in
126
+
for i = 0 to mask_len - 1 do
127
+
let v = Char.code (Bytes.get result i) in
128
+
let m = Char.code (Bytes.get mask i) in
129
+
Bytes.set result i (Char.chr (v land m))
130
+
done;
131
+
for i = mask_len to Bytes.length result - 1 do
132
+
Bytes.set result i '\x00'
133
+
done;
134
+
result
135
+
136
+
let apply_abm abm aad =
137
+
match abm with Sa.All -> aad | Sa.Mask mask -> apply_abm_mask mask aad
138
+
139
+
let build_aad ~(sa : Sa.entry) ~frame_hdr_bytes sec_header =
140
+
let sec_hdr_bytes = encode_security_header sec_header in
141
+
let aad = Bytes.cat frame_hdr_bytes sec_hdr_bytes in
142
+
apply_abm sa.config.abm aad
143
+
144
+
(* {1 Crypto helpers} *)
145
+
146
+
let split_ct_tag ct_tag =
147
+
let len = Bytes.length ct_tag in
148
+
if len < 16 then None
149
+
else
150
+
let ct_len = len - 16 in
151
+
Some (Bytes.sub ct_tag 0 ct_len, Bytes.sub ct_tag ct_len 16)
152
+
153
+
let truncate_mac mac len =
154
+
if Bytes.length mac <= len then mac else Bytes.sub mac 0 len
155
+
156
+
let encrypt_gcm ~key ~nonce ~aad plaintext =
157
+
match Sdls_crypto.encrypt_aes_gcm ~key ~nonce ~aad plaintext with
158
+
| Error e -> Error (Crypto_error e)
159
+
| Ok ct_tag -> (
160
+
match split_ct_tag ct_tag with
161
+
| None -> Error (Crypto_error Sdls_crypto.Invalid_key_length)
162
+
| Some pair -> Ok pair)
163
+
164
+
let encrypt_ccm ~key ~nonce ~aad plaintext =
165
+
match Sdls_crypto.encrypt_aes_ccm ~key ~nonce ~aad plaintext with
166
+
| Error e -> Error (Crypto_error e)
167
+
| Ok ct_tag -> (
168
+
match split_ct_tag ct_tag with
169
+
| None -> Error (Crypto_error Sdls_crypto.Invalid_key_length)
170
+
| Some pair -> Ok pair)
171
+
172
+
let auth_cmac ~key ~aad ~data ~mac_len =
173
+
let to_auth = Bytes.cat aad data in
174
+
match Sdls_crypto.cmac ~key to_auth with
175
+
| Error e -> Error (Crypto_error e)
176
+
| Ok mac -> Ok (data, truncate_mac mac mac_len)
177
+
178
+
let auth_hmac_sha256 ~key ~aad ~data ~mac_len =
179
+
let to_auth = Bytes.cat aad data in
180
+
match Sdls_crypto.hmac_sha256 ~key to_auth with
181
+
| Error e -> Error (Crypto_error e)
182
+
| Ok mac -> Ok (data, truncate_mac mac mac_len)
183
+
184
+
let auth_hmac_sha384 ~key ~aad ~data ~mac_len =
185
+
let to_auth = Bytes.cat aad data in
186
+
match Sdls_crypto.hmac_sha384 ~key to_auth with
187
+
| Error e -> Error (Crypto_error e)
188
+
| Ok mac -> Ok (data, truncate_mac mac mac_len)
189
+
190
+
let auth_hmac_sha512 ~key ~aad ~data ~mac_len =
191
+
let to_auth = Bytes.cat aad data in
192
+
match Sdls_crypto.hmac_sha512 ~key to_auth with
193
+
| Error e -> Error (Crypto_error e)
194
+
| Ok mac -> Ok (data, truncate_mac mac mac_len)
195
+
196
+
let decrypt_gcm ~key ~nonce ~aad ~ciphertext ~mac =
197
+
let ct_tag = Bytes.cat ciphertext mac in
198
+
match Sdls_crypto.decrypt_aes_gcm ~key ~nonce ~aad ct_tag with
199
+
| Error Sdls_crypto.Auth_failure -> Error Auth_failure
200
+
| Error e -> Error (Crypto_error e)
201
+
| Ok pt -> Ok pt
202
+
203
+
let decrypt_ccm ~key ~nonce ~aad ~ciphertext ~mac =
204
+
let ct_tag = Bytes.cat ciphertext mac in
205
+
match Sdls_crypto.decrypt_aes_ccm ~key ~nonce ~aad ct_tag with
206
+
| Error Sdls_crypto.Auth_failure -> Error Auth_failure
207
+
| Error e -> Error (Crypto_error e)
208
+
| Ok pt -> Ok pt
209
+
210
+
let verify_cmac ~key ~aad ~data ~mac_len ~expected =
211
+
let to_auth = Bytes.cat aad data in
212
+
match Sdls_crypto.cmac ~key to_auth with
213
+
| Error e -> Error (Crypto_error e)
214
+
| Ok computed ->
215
+
let truncated = truncate_mac computed mac_len in
216
+
if
217
+
Eqaf.equal
218
+
(Bytes.unsafe_to_string truncated)
219
+
(Bytes.unsafe_to_string expected)
220
+
then Ok data
221
+
else Error Auth_failure
222
+
223
+
let verify_hmac_sha256 ~key ~aad ~data ~mac_len ~expected =
224
+
let to_auth = Bytes.cat aad data in
225
+
match Sdls_crypto.hmac_sha256 ~key to_auth with
226
+
| Error e -> Error (Crypto_error e)
227
+
| Ok computed ->
228
+
let truncated = truncate_mac computed mac_len in
229
+
if
230
+
Eqaf.equal
231
+
(Bytes.unsafe_to_string truncated)
232
+
(Bytes.unsafe_to_string expected)
233
+
then Ok data
234
+
else Error Auth_failure
235
+
236
+
let verify_hmac_sha384 ~key ~aad ~data ~mac_len ~expected =
237
+
let to_auth = Bytes.cat aad data in
238
+
match Sdls_crypto.hmac_sha384 ~key to_auth with
239
+
| Error e -> Error (Crypto_error e)
240
+
| Ok computed ->
241
+
let truncated = truncate_mac computed mac_len in
242
+
if
243
+
Eqaf.equal
244
+
(Bytes.unsafe_to_string truncated)
245
+
(Bytes.unsafe_to_string expected)
246
+
then Ok data
247
+
else Error Auth_failure
248
+
249
+
let verify_hmac_sha512 ~key ~aad ~data ~mac_len ~expected =
250
+
let to_auth = Bytes.cat aad data in
251
+
match Sdls_crypto.hmac_sha512 ~key to_auth with
252
+
| Error e -> Error (Crypto_error e)
253
+
| Ok computed ->
254
+
let truncated = truncate_mac computed mac_len in
255
+
if
256
+
Eqaf.equal
257
+
(Bytes.unsafe_to_string truncated)
258
+
(Bytes.unsafe_to_string expected)
259
+
then Ok data
260
+
else Error Auth_failure
261
+
262
+
(* {1 Key lookup} *)
263
+
264
+
let aes256_key_len = 32
265
+
266
+
let require_key_aes256 keys get_key id =
267
+
match get_key keys id with
268
+
| None -> Error (Missing_key id)
269
+
| Some k ->
270
+
let actual = Bytes.length k in
271
+
if actual = aes256_key_len then Ok k
272
+
else
273
+
Error
274
+
(Invalid_key_len { key_id = id; expected = aes256_key_len; actual })
275
+
276
+
let hmac_min_key_len = function
277
+
| Sa.HMAC_SHA_256 -> 32
278
+
| Sa.HMAC_SHA_384 -> 48
279
+
| Sa.HMAC_SHA_512 -> 64
280
+
| _ -> 32
281
+
282
+
let require_key_hmac acs keys get_key id =
283
+
match get_key keys id with
284
+
| None -> Error (Missing_key id)
285
+
| Some k ->
286
+
let actual = Bytes.length k in
287
+
let min_len = hmac_min_key_len acs in
288
+
if actual >= min_len then Ok k
289
+
else Error (Invalid_key_len { key_id = id; expected = min_len; actual })
290
+
291
+
(* {1 SA Validation} *)
292
+
293
+
let aead_tag_len = 16
294
+
let aead_iv_len = 12
295
+
let cmac_min_mac_len = 8
296
+
297
+
let is_aead_sa (sa : Sa.entry) =
298
+
sa.config.encryption && sa.config.authentication
299
+
&&
300
+
match sa.config.ecs with
301
+
| Some Sa.AES_256_GCM | Some Sa.AES_256_CCM -> true
302
+
| _ -> false
303
+
304
+
let is_auth_only (sa : Sa.entry) =
305
+
(not sa.config.encryption) && sa.config.authentication
306
+
&&
307
+
match sa.config.acs with
308
+
| Some Sa.AES_256_CMAC
309
+
| Some Sa.HMAC_SHA_256
310
+
| Some Sa.HMAC_SHA_384
311
+
| Some Sa.HMAC_SHA_512
312
+
| Some Sa.AES_256_GMAC
313
+
| Some (Sa.ACS_agency_defined _) ->
314
+
true
315
+
| None | Some Sa.Mac_none -> false
316
+
317
+
let is_zero_mask mask =
318
+
Bytes.length mask = 0 || Bytes.for_all (fun c -> c = '\x00') mask
319
+
320
+
let validate_sa ?aad_len (sa : Sa.entry) =
321
+
if is_aead_sa sa && sa.config.mac_len <> aead_tag_len then
322
+
Error
323
+
(Invalid_mac_len { expected = aead_tag_len; actual = sa.config.mac_len })
324
+
else if is_aead_sa sa && sa.config.iv_len <> aead_iv_len then
325
+
Error
326
+
(Invalid_iv_len { min_required = aead_iv_len; actual = sa.config.iv_len })
327
+
else if is_auth_only sa && sa.config.mac_len < cmac_min_mac_len then
328
+
Error
329
+
(Invalid_mac_len
330
+
{ expected = cmac_min_mac_len; actual = sa.config.mac_len })
331
+
else
332
+
match sa.config.abm with
333
+
| All -> Ok ()
334
+
| Mask mask when is_zero_mask mask -> Error Invalid_abm
335
+
| Mask mask -> (
336
+
match aad_len with
337
+
| None -> Ok ()
338
+
| Some expected when Bytes.length mask >= expected -> Ok ()
339
+
| Some expected ->
340
+
Error (Abm_too_short { expected; actual = Bytes.length mask }))
341
+
342
+
(* {1 Protection core} *)
343
+
344
+
let protect_frame ~(sa : Sa.entry) ~keys ~get_ek ~get_ak ~frame_hdr_bytes
345
+
~plaintext w =
346
+
if sa.dyn.lifecycle <> Operational then
347
+
Error (SA_not_operational sa.config.spi)
348
+
else if sa.config.encryption && Sa.is_iv_max sa.dyn.iv then Error IV_exhausted
349
+
else
350
+
let aad_len = Bytes.length frame_hdr_bytes + sec_hdr_len sa in
351
+
match validate_sa ~aad_len sa with
352
+
| Error _ as e -> e
353
+
| Ok () -> (
354
+
let sn =
355
+
if sa.config.sn_len > 0 then Bytes.sub sa.dyn.arsn 0 sa.config.sn_len
356
+
else Bytes.empty
357
+
in
358
+
let sec_hdr = Sa.{ spi = sa.config.spi; iv = sa.dyn.iv; sn } in
359
+
let nonce = nonce_of_iv sa.dyn.iv in
360
+
let encrypt_result =
361
+
match
362
+
( sa.config.encryption,
363
+
sa.config.authentication,
364
+
sa.config.ecs,
365
+
sa.config.acs )
366
+
with
367
+
| true, true, Some Sa.AES_256_GCM, _ -> (
368
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
369
+
match require_key_aes256 keys get_ek sa.dyn.ek_id with
370
+
| Error _ as e -> e
371
+
| Ok key -> encrypt_gcm ~key ~nonce ~aad plaintext)
372
+
| true, true, Some Sa.AES_256_CCM, _ -> (
373
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
374
+
match require_key_aes256 keys get_ek sa.dyn.ek_id with
375
+
| Error _ as e -> e
376
+
| Ok key -> encrypt_ccm ~key ~nonce ~aad plaintext)
377
+
| true, _, Some Sa.AES_256_CTR, _ ->
378
+
Error (Unsupported_ecs Sa.AES_256_CTR)
379
+
| true, _, Some Sa.AES_256_CBC, _ ->
380
+
Error (Unsupported_ecs Sa.AES_256_CBC)
381
+
| true, _, Some Sa.AES_256_CBC_MAC, _ ->
382
+
Error (Unsupported_ecs Sa.AES_256_CBC_MAC)
383
+
| true, true, Some Sa.AES_256_GCM_SIV, _ ->
384
+
Error (Unsupported_ecs Sa.AES_256_GCM_SIV)
385
+
| false, true, _, Some Sa.AES_256_CMAC -> (
386
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
387
+
match require_key_aes256 keys get_ak sa.dyn.ak_id with
388
+
| Error _ as e -> e
389
+
| Ok key ->
390
+
auth_cmac ~key ~aad ~data:plaintext ~mac_len:sa.config.mac_len
391
+
)
392
+
| false, true, _, Some Sa.HMAC_SHA_256 -> (
393
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
394
+
match
395
+
require_key_hmac Sa.HMAC_SHA_256 keys get_ak sa.dyn.ak_id
396
+
with
397
+
| Error _ as e -> e
398
+
| Ok key ->
399
+
auth_hmac_sha256 ~key ~aad ~data:plaintext
400
+
~mac_len:sa.config.mac_len)
401
+
| false, true, _, Some Sa.HMAC_SHA_384 -> (
402
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
403
+
match
404
+
require_key_hmac Sa.HMAC_SHA_384 keys get_ak sa.dyn.ak_id
405
+
with
406
+
| Error _ as e -> e
407
+
| Ok key ->
408
+
auth_hmac_sha384 ~key ~aad ~data:plaintext
409
+
~mac_len:sa.config.mac_len)
410
+
| false, true, _, Some Sa.HMAC_SHA_512 -> (
411
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
412
+
match
413
+
require_key_hmac Sa.HMAC_SHA_512 keys get_ak sa.dyn.ak_id
414
+
with
415
+
| Error _ as e -> e
416
+
| Ok key ->
417
+
auth_hmac_sha512 ~key ~aad ~data:plaintext
418
+
~mac_len:sa.config.mac_len)
419
+
| false, true, _, Some Sa.AES_256_GMAC ->
420
+
Error (Unsupported_acs Sa.AES_256_GMAC)
421
+
| false, false, _, _ -> Ok (plaintext, Bytes.empty)
422
+
| true, _, Some ecs, _ -> Error (Unsupported_ecs ecs)
423
+
| false, true, _, Some acs -> Error (Unsupported_acs acs)
424
+
| _ -> Error (Unsupported_ecs Sa.Cipher_none)
425
+
in
426
+
match encrypt_result with
427
+
| Error _ as e -> e
428
+
| Ok (ct, mac) ->
429
+
Binary.Writer.bytes w frame_hdr_bytes;
430
+
write_security_header w sec_hdr;
431
+
Binary.Writer.bytes w ct;
432
+
write_security_trailer w { mac };
433
+
let sa' =
434
+
{
435
+
sa with
436
+
dyn =
437
+
{
438
+
sa.dyn with
439
+
iv = Sa.increment_iv sa.dyn.iv;
440
+
arsn = Sa.increment_arsn sa.dyn.arsn;
441
+
};
442
+
}
443
+
in
444
+
Ok sa')
445
+
446
+
(* {1 Unprotection core} *)
447
+
448
+
let unprotect_frame ~(sa : Sa.entry) ~keys ~get_ek ~get_ak ~frame_hdr_len
449
+
~frame_hdr_bytes ~total_len r =
450
+
if sa.dyn.lifecycle <> Operational then
451
+
Error (SA_not_operational sa.config.spi)
452
+
else
453
+
let sh_len = sec_hdr_len sa in
454
+
let ct_len = total_len - frame_hdr_len - sh_len - sa.config.mac_len in
455
+
if ct_len < 0 then Error Invalid_frame_length
456
+
else
457
+
let aad_len = frame_hdr_len + sh_len in
458
+
match validate_sa ~aad_len sa with
459
+
| Error _ as e -> e
460
+
| Ok () -> (
461
+
match read_security_header ~sa r with
462
+
| Error _ as e -> e
463
+
| Ok sec_hdr -> (
464
+
let replay_ok =
465
+
if sa.config.sn_len > 0 then
466
+
Sa.check_anti_replay ~config:sa.config ~dyn:sa.dyn sec_hdr.sn
467
+
else true
468
+
in
469
+
if not replay_ok then
470
+
Error
471
+
(Anti_replay_failure
472
+
{ received = sec_hdr.sn; window = sa.config.arsnw })
473
+
else
474
+
let ct = Binary.Reader.bytes r ct_len in
475
+
match read_security_trailer ~sa r with
476
+
| Error _ as e -> e
477
+
| Ok sec_trl -> (
478
+
let nonce = nonce_of_iv sec_hdr.iv in
479
+
let decrypt_result =
480
+
match
481
+
( sa.config.encryption,
482
+
sa.config.authentication,
483
+
sa.config.ecs,
484
+
sa.config.acs )
485
+
with
486
+
| true, true, Some Sa.AES_256_GCM, _ -> (
487
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
488
+
match require_key_aes256 keys get_ek sa.dyn.ek_id with
489
+
| Error _ as e -> e
490
+
| Ok key ->
491
+
decrypt_gcm ~key ~nonce ~aad ~ciphertext:ct
492
+
~mac:sec_trl.mac)
493
+
| true, true, Some Sa.AES_256_CCM, _ -> (
494
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
495
+
match require_key_aes256 keys get_ek sa.dyn.ek_id with
496
+
| Error _ as e -> e
497
+
| Ok key ->
498
+
decrypt_ccm ~key ~nonce ~aad ~ciphertext:ct
499
+
~mac:sec_trl.mac)
500
+
| true, _, Some Sa.AES_256_CTR, _ ->
501
+
Error (Unsupported_ecs Sa.AES_256_CTR)
502
+
| true, _, Some Sa.AES_256_CBC, _ ->
503
+
Error (Unsupported_ecs Sa.AES_256_CBC)
504
+
| true, _, Some Sa.AES_256_CBC_MAC, _ ->
505
+
Error (Unsupported_ecs Sa.AES_256_CBC_MAC)
506
+
| true, true, Some Sa.AES_256_GCM_SIV, _ ->
507
+
Error (Unsupported_ecs Sa.AES_256_GCM_SIV)
508
+
| false, true, _, Some Sa.AES_256_CMAC -> (
509
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
510
+
match require_key_aes256 keys get_ak sa.dyn.ak_id with
511
+
| Error _ as e -> e
512
+
| Ok key ->
513
+
verify_cmac ~key ~aad ~data:ct
514
+
~mac_len:sa.config.mac_len ~expected:sec_trl.mac
515
+
)
516
+
| false, true, _, Some Sa.HMAC_SHA_256 -> (
517
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
518
+
match
519
+
require_key_hmac Sa.HMAC_SHA_256 keys get_ak
520
+
sa.dyn.ak_id
521
+
with
522
+
| Error _ as e -> e
523
+
| Ok key ->
524
+
verify_hmac_sha256 ~key ~aad ~data:ct
525
+
~mac_len:sa.config.mac_len ~expected:sec_trl.mac
526
+
)
527
+
| false, true, _, Some Sa.HMAC_SHA_384 -> (
528
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
529
+
match
530
+
require_key_hmac Sa.HMAC_SHA_384 keys get_ak
531
+
sa.dyn.ak_id
532
+
with
533
+
| Error _ as e -> e
534
+
| Ok key ->
535
+
verify_hmac_sha384 ~key ~aad ~data:ct
536
+
~mac_len:sa.config.mac_len ~expected:sec_trl.mac
537
+
)
538
+
| false, true, _, Some Sa.HMAC_SHA_512 -> (
539
+
let aad = build_aad ~sa ~frame_hdr_bytes sec_hdr in
540
+
match
541
+
require_key_hmac Sa.HMAC_SHA_512 keys get_ak
542
+
sa.dyn.ak_id
543
+
with
544
+
| Error _ as e -> e
545
+
| Ok key ->
546
+
verify_hmac_sha512 ~key ~aad ~data:ct
547
+
~mac_len:sa.config.mac_len ~expected:sec_trl.mac
548
+
)
549
+
| false, true, _, Some Sa.AES_256_GMAC ->
550
+
Error (Unsupported_acs Sa.AES_256_GMAC)
551
+
| false, false, _, _ -> Ok ct
552
+
| true, _, Some ecs, _ -> Error (Unsupported_ecs ecs)
553
+
| false, true, _, Some acs -> Error (Unsupported_acs acs)
554
+
| _ -> Error (Unsupported_ecs Sa.Cipher_none)
555
+
in
556
+
match decrypt_result with
557
+
| Error _ as e -> e
558
+
| Ok pt ->
559
+
let sa' =
560
+
if sa.config.sn_len > 0 then
561
+
{
562
+
sa with
563
+
dyn =
564
+
Sa.update_replay_window ~config:sa.config
565
+
~dyn:sa.dyn sec_hdr.sn;
566
+
}
567
+
else sa
568
+
in
569
+
Ok (pt, sa'))))
570
+
571
+
(* {1 Re-exports} *)
572
+
573
+
module Crypto = Sdls_crypto
574
+
module Cmac = Cmac
575
+
module Hmac = Hmac
576
+
module Hex = Hex
577
+
module Key = Key
578
+
module Keyid = Keyid
579
+
module Keystore = Keystore
580
+
module Sa = Sa
581
+
module Cbor = Cbor
582
+
module Ep = Ep
583
+
module Mc = Mc
+91
lib/sdls.mli
+91
lib/sdls.mli
···
1
+
(** Space Data Link Security (CCSDS 355.0-B-2).
2
+
3
+
Provides authenticated encryption for CCSDS frames using AES-GCM, AES-CCM,
4
+
or authentication-only with AES-CMAC.
5
+
6
+
Frame types (TC, TM, AOS, USLP) are not directly supported as their
7
+
definitions live in the borealis frames library. Instead, use the generic
8
+
{!protect_frame} and {!unprotect_frame} functions with raw frame header
9
+
bytes. *)
10
+
11
+
(** {1 Errors} *)
12
+
13
+
type error =
14
+
| Unknown_sa of int (** SPI not found *)
15
+
| SA_not_operational of int
16
+
| Crypto_error of Sdls_crypto.error
17
+
| Auth_failure
18
+
| Anti_replay_failure of { received : bytes; window : int }
19
+
| Invalid_frame_length
20
+
| Missing_key of Keyid.t
21
+
| Unsupported_ecs of Sa.ecs
22
+
| Unsupported_acs of Sa.acs
23
+
| IV_exhausted
24
+
| Invalid_mac_len of { expected : int; actual : int }
25
+
| Invalid_abm
26
+
| Abm_too_short of { expected : int; actual : int }
27
+
| Invalid_iv_len of { min_required : int; actual : int }
28
+
| Invalid_key_len of { key_id : Keyid.t; expected : int; actual : int }
29
+
| Persistence_failure of string
30
+
31
+
val pp_error : error Fmt.t
32
+
val pp_error_debug : error Fmt.t
33
+
val auth_failure_of_error : error -> Mc.auth_failure_reason option
34
+
35
+
(** {1 Security Header/Trailer} *)
36
+
37
+
val write_security_header : Binary.Writer.t -> Sa.security_header -> unit
38
+
39
+
val read_security_header :
40
+
sa:Sa.entry -> Binary.Reader.t -> (Sa.security_header, error) result
41
+
42
+
val write_security_trailer : Binary.Writer.t -> Sa.security_trailer -> unit
43
+
44
+
val read_security_trailer :
45
+
sa:Sa.entry -> Binary.Reader.t -> (Sa.security_trailer, error) result
46
+
47
+
val nonce_of_iv : bytes -> bytes
48
+
49
+
(** {1 Generic Frame Protection}
50
+
51
+
These functions operate on raw frame header bytes, allowing any frame type
52
+
to be protected without depending on specific frame type definitions. *)
53
+
54
+
val protect_frame :
55
+
sa:Sa.entry ->
56
+
keys:Keystore.t ->
57
+
get_ek:(Keystore.t -> Keyid.t -> bytes option) ->
58
+
get_ak:(Keystore.t -> Keyid.t -> bytes option) ->
59
+
frame_hdr_bytes:bytes ->
60
+
plaintext:bytes ->
61
+
Binary.Writer.t ->
62
+
(Sa.entry, error) result
63
+
(** [protect_frame ~sa ~keys ~get_ek ~get_ak ~frame_hdr_bytes ~plaintext w]
64
+
protects a frame, writing the result to [w]. Returns updated SA. *)
65
+
66
+
val unprotect_frame :
67
+
sa:Sa.entry ->
68
+
keys:Keystore.t ->
69
+
get_ek:(Keystore.t -> Keyid.t -> bytes option) ->
70
+
get_ak:(Keystore.t -> Keyid.t -> bytes option) ->
71
+
frame_hdr_len:int ->
72
+
frame_hdr_bytes:bytes ->
73
+
total_len:int ->
74
+
Binary.Reader.t ->
75
+
(bytes * Sa.entry, error) result
76
+
(** [unprotect_frame ~sa ~keys ~get_ek ~get_ak ~frame_hdr_len ~frame_hdr_bytes
77
+
~total_len r] unprotects a frame. Returns (plaintext, updated SA). *)
78
+
79
+
(** {1 Re-exports} *)
80
+
81
+
module Crypto = Sdls_crypto
82
+
module Cmac = Cmac
83
+
module Hmac = Hmac
84
+
module Hex = Hex
85
+
module Key = Key
86
+
module Keyid = Keyid
87
+
module Keystore = Keystore
88
+
module Sa = Sa
89
+
module Cbor = Cbor
90
+
module Ep = Ep
91
+
module Mc = Mc
+222
lib/sdls_crypto.ml
+222
lib/sdls_crypto.ml
···
1
+
(** Cryptographic operations for SDLS.
2
+
3
+
Default implementation uses crypto with 16-byte tags only. Shorter tags are
4
+
not supported until proper truncation is implemented.
5
+
6
+
{b Error handling:} Internal exceptions from crypto are caught and mapped to
7
+
[Crypto_error]. The [pp_error] function provides sanitized output suitable
8
+
for production logs - it does not include exception backtraces or internal
9
+
details that could aid attackers. Use [pp_error_debug] during development
10
+
for full details. *)
11
+
12
+
module C = Crypto.AES
13
+
14
+
type error =
15
+
| Crypto_error of string
16
+
| Auth_failure
17
+
| Invalid_key_length
18
+
| Invalid_nonce_length
19
+
20
+
(** Production-safe error printer. Does not leak internal details. *)
21
+
let pp_error ppf = function
22
+
| Crypto_error _ -> Fmt.pf ppf "cryptographic operation failed"
23
+
| Auth_failure -> Fmt.pf ppf "authentication failure"
24
+
| Invalid_key_length -> Fmt.pf ppf "invalid key length"
25
+
| Invalid_nonce_length -> Fmt.pf ppf "invalid nonce length"
26
+
27
+
(** Debug error printer. Includes internal details - use only in development. *)
28
+
let pp_error_debug ppf = function
29
+
| Crypto_error msg -> Fmt.pf ppf "crypto error: %s" msg
30
+
| Auth_failure -> Fmt.pf ppf "authentication failure"
31
+
| Invalid_key_length ->
32
+
Fmt.pf ppf "invalid key length (must be 16, 24, or 32 bytes)"
33
+
| Invalid_nonce_length -> Fmt.pf ppf "invalid nonce length"
34
+
35
+
module type S = sig
36
+
val encrypt_aes_ccm :
37
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
38
+
39
+
val decrypt_aes_ccm :
40
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
41
+
42
+
val encrypt_aes_gcm :
43
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
44
+
45
+
val decrypt_aes_gcm :
46
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
47
+
48
+
val cmac : key:bytes -> bytes -> (bytes, error) result
49
+
val cmac_verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
50
+
val tag_len : int
51
+
end
52
+
53
+
(** Authentication tag length. CCM16 and GCM both use 16-byte tags. *)
54
+
let tag_len = 16
55
+
56
+
(* Map Cmac errors to Crypto errors *)
57
+
let map_cmac_error = function
58
+
| Cmac.Invalid_key_length -> Invalid_key_length
59
+
| Cmac.Internal_error msg -> Crypto_error msg
60
+
61
+
(* Key length validation - generic AES (128/192/256) *)
62
+
let validate_key_length key =
63
+
let len = Bytes.length key in
64
+
if len = 16 || len = 24 || len = 32 then Ok () else Error Invalid_key_length
65
+
66
+
(* Key length validation - AES-256 only (SDLS requirement) *)
67
+
let validate_aes256_key_length key =
68
+
if Bytes.length key = 32 then Ok () else Error Invalid_key_length
69
+
70
+
(* CCM nonce: 7-13 bytes per NIST SP 800-38C.
71
+
Note: SDLS layer enforces 12 bytes for CCSDS compliance. *)
72
+
let validate_ccm_nonce nonce =
73
+
let len = Bytes.length nonce in
74
+
if len >= 7 && len <= 13 then Ok () else Error Invalid_nonce_length
75
+
76
+
(* GCM nonce: exactly 12 bytes required. *)
77
+
let validate_gcm_nonce nonce =
78
+
let len = Bytes.length nonce in
79
+
if len = 12 then Ok () else Error Invalid_nonce_length
80
+
81
+
let encrypt_aes_ccm ~key ~nonce ~aad plaintext =
82
+
match validate_key_length key with
83
+
| Error e -> Error e
84
+
| Ok () -> (
85
+
match validate_ccm_nonce nonce with
86
+
| Error e -> Error e
87
+
| Ok () -> (
88
+
try
89
+
let key = C.CCM16.of_secret (Bytes.to_string key) in
90
+
let nonce = Bytes.to_string nonce in
91
+
let adata = Bytes.to_string aad in
92
+
let result =
93
+
C.CCM16.authenticate_encrypt ~key ~nonce ~adata
94
+
(Bytes.to_string plaintext)
95
+
in
96
+
Ok (Bytes.of_string result)
97
+
with Invalid_argument _ -> Error Invalid_key_length))
98
+
99
+
let decrypt_aes_ccm ~key ~nonce ~aad ciphertext_tag =
100
+
match validate_key_length key with
101
+
| Error e -> Error e
102
+
| Ok () -> (
103
+
match validate_ccm_nonce nonce with
104
+
| Error e -> Error e
105
+
| Ok () -> (
106
+
let ct_len = Bytes.length ciphertext_tag in
107
+
if ct_len < tag_len then Error Auth_failure
108
+
else
109
+
try
110
+
let key = C.CCM16.of_secret (Bytes.to_string key) in
111
+
let nonce = Bytes.to_string nonce in
112
+
let adata = Bytes.to_string aad in
113
+
match
114
+
C.CCM16.authenticate_decrypt ~key ~nonce ~adata
115
+
(Bytes.to_string ciphertext_tag)
116
+
with
117
+
| Some plaintext -> Ok (Bytes.of_string plaintext)
118
+
| None -> Error Auth_failure
119
+
with Invalid_argument _ -> Error Invalid_key_length))
120
+
121
+
let encrypt_aes_gcm ~key ~nonce ~aad plaintext =
122
+
match validate_key_length key with
123
+
| Error e -> Error e
124
+
| Ok () -> (
125
+
match validate_gcm_nonce nonce with
126
+
| Error e -> Error e
127
+
| Ok () -> (
128
+
try
129
+
let key = C.GCM.of_secret (Bytes.to_string key) in
130
+
let nonce = Bytes.to_string nonce in
131
+
let adata = Bytes.to_string aad in
132
+
let result =
133
+
C.GCM.authenticate_encrypt ~key ~nonce ~adata
134
+
(Bytes.to_string plaintext)
135
+
in
136
+
Ok (Bytes.of_string result)
137
+
with Invalid_argument _ -> Error Invalid_key_length))
138
+
139
+
let decrypt_aes_gcm ~key ~nonce ~aad ciphertext_tag =
140
+
match validate_key_length key with
141
+
| Error e -> Error e
142
+
| Ok () -> (
143
+
match validate_gcm_nonce nonce with
144
+
| Error e -> Error e
145
+
| Ok () -> (
146
+
let ct_len = Bytes.length ciphertext_tag in
147
+
if ct_len < tag_len then Error Auth_failure
148
+
else
149
+
try
150
+
let key = C.GCM.of_secret (Bytes.to_string key) in
151
+
let nonce = Bytes.to_string nonce in
152
+
let adata = Bytes.to_string aad in
153
+
match
154
+
C.GCM.authenticate_decrypt ~key ~nonce ~adata
155
+
(Bytes.to_string ciphertext_tag)
156
+
with
157
+
| Some plaintext -> Ok (Bytes.of_string plaintext)
158
+
| None -> Error Auth_failure
159
+
with Invalid_argument _ -> Error Invalid_key_length))
160
+
161
+
let cmac ~key data = Cmac.mac ~key data |> Result.map_error map_cmac_error
162
+
163
+
let cmac_verify ~key ~mac data =
164
+
Cmac.verify ~key ~mac data |> Result.map_error map_cmac_error
165
+
166
+
(* {1 AES-CTR Mode} *)
167
+
168
+
let validate_ctr_nonce nonce =
169
+
let len = Bytes.length nonce in
170
+
if len = 16 then Ok () else Error Invalid_nonce_length
171
+
172
+
let encrypt_aes_ctr ~key ~nonce plaintext =
173
+
match validate_key_length key with
174
+
| Error e -> Error e
175
+
| Ok () -> (
176
+
match validate_ctr_nonce nonce with
177
+
| Error e -> Error e
178
+
| Ok () -> (
179
+
try
180
+
let key = C.CTR.of_secret (Bytes.to_string key) in
181
+
let ctr = C.CTR.ctr_of_octets (Bytes.to_string nonce) in
182
+
let result = C.CTR.encrypt ~key ~ctr (Bytes.to_string plaintext) in
183
+
Ok (Bytes.of_string result)
184
+
with Invalid_argument _ -> Error Invalid_key_length))
185
+
186
+
let decrypt_aes_ctr ~key ~nonce ciphertext =
187
+
encrypt_aes_ctr ~key ~nonce ciphertext
188
+
189
+
(* Map HMAC errors to Crypto errors *)
190
+
let map_hmac_error = function
191
+
| Hmac.Invalid_key_length -> Invalid_key_length
192
+
| Hmac.Internal_error msg -> Crypto_error msg
193
+
194
+
(* {1 HMAC-SHA-256} *)
195
+
196
+
let hmac_sha256_len = Hmac.sha256_mac_len
197
+
198
+
let hmac_sha256 ~key data =
199
+
Hmac.sha256 ~key data |> Result.map_error map_hmac_error
200
+
201
+
let hmac_sha256_verify ~key ~mac data =
202
+
Hmac.sha256_verify ~key ~mac data |> Result.map_error map_hmac_error
203
+
204
+
(* {1 HMAC-SHA-384} *)
205
+
206
+
let hmac_sha384_len = Hmac.sha384_mac_len
207
+
208
+
let hmac_sha384 ~key data =
209
+
Hmac.sha384 ~key data |> Result.map_error map_hmac_error
210
+
211
+
let hmac_sha384_verify ~key ~mac data =
212
+
Hmac.sha384_verify ~key ~mac data |> Result.map_error map_hmac_error
213
+
214
+
(* {1 HMAC-SHA-512} *)
215
+
216
+
let hmac_sha512_len = Hmac.sha512_mac_len
217
+
218
+
let hmac_sha512 ~key data =
219
+
Hmac.sha512 ~key data |> Result.map_error map_hmac_error
220
+
221
+
let hmac_sha512_verify ~key ~mac data =
222
+
Hmac.sha512_verify ~key ~mac data |> Result.map_error map_hmac_error
+111
lib/sdls_crypto.mli
+111
lib/sdls_crypto.mli
···
1
+
(** Cryptographic operations for SDLS.
2
+
3
+
Provides AES-CCM, AES-GCM, and AES-CMAC using crypto. All AEAD operations
4
+
use 16-byte authentication tags (CCM16/GCM).
5
+
6
+
{b Nonce requirements:}
7
+
- GCM: exactly 12 bytes (mandatory per NIST SP 800-38D)
8
+
- CCM: 7-13 bytes per NIST SP 800-38C (this layer); SDLS enforces 12 bytes
9
+
for CCSDS compliance at the protocol layer
10
+
11
+
{b Key requirements:}
12
+
- Generic functions: 16, 24, or 32 bytes (AES-128/192/256)
13
+
- SDLS: 32 bytes only (AES-256 suites per CCSDS 355.0-B-2)
14
+
15
+
{b Important:} Nonces MUST be unique per key. Reusing a nonce with the same
16
+
key completely breaks security.
17
+
18
+
{b Error handling:} Use [pp_error] for production logs (sanitized, no
19
+
internal details). Use [pp_error_debug] during development for full
20
+
diagnostics. *)
21
+
22
+
(** {1 Errors} *)
23
+
24
+
type error =
25
+
| Crypto_error of string (** Internal crypto error with details *)
26
+
| Auth_failure (** Authentication tag verification failed *)
27
+
| Invalid_key_length (** Key length invalid for algorithm *)
28
+
| Invalid_nonce_length (** Nonce length out of range *)
29
+
30
+
val pp_error : error Fmt.t
31
+
(** Production-safe error printer. Provides sanitized messages without internal
32
+
details that could aid attackers. Use this in production logs. *)
33
+
34
+
val pp_error_debug : error Fmt.t
35
+
(** Debug error printer with full details. Use only during development. *)
36
+
37
+
(** {1 Constants} *)
38
+
39
+
val tag_len : int
40
+
(** Authentication tag length in bytes (always 16). *)
41
+
42
+
(** {1 Key Validation} *)
43
+
44
+
val validate_aes256_key_length : bytes -> (unit, error) result
45
+
(** [validate_aes256_key_length key] returns [Ok ()] if [key] is exactly 32
46
+
bytes (AES-256). Use for SDLS which requires AES-256 suites only. *)
47
+
48
+
(** {1 Module Signature} *)
49
+
50
+
(** Signature for alternative crypto implementations. *)
51
+
module type S = sig
52
+
val encrypt_aes_ccm :
53
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
54
+
55
+
val decrypt_aes_ccm :
56
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
57
+
58
+
val encrypt_aes_gcm :
59
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
60
+
61
+
val decrypt_aes_gcm :
62
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
63
+
64
+
val cmac : key:bytes -> bytes -> (bytes, error) result
65
+
val cmac_verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
66
+
val tag_len : int
67
+
end
68
+
69
+
(** {1 AES-CCM (Counter with CBC-MAC)} *)
70
+
71
+
val encrypt_aes_ccm :
72
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
73
+
74
+
val decrypt_aes_ccm :
75
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
76
+
77
+
(** {1 AES-GCM (Galois/Counter Mode)} *)
78
+
79
+
val encrypt_aes_gcm :
80
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
81
+
82
+
val decrypt_aes_gcm :
83
+
key:bytes -> nonce:bytes -> aad:bytes -> bytes -> (bytes, error) result
84
+
85
+
(** {1 AES-CTR (Counter Mode)} *)
86
+
87
+
val encrypt_aes_ctr : key:bytes -> nonce:bytes -> bytes -> (bytes, error) result
88
+
val decrypt_aes_ctr : key:bytes -> nonce:bytes -> bytes -> (bytes, error) result
89
+
90
+
(** {1 AES-CMAC (NIST SP 800-38B)} *)
91
+
92
+
val cmac : key:bytes -> bytes -> (bytes, error) result
93
+
val cmac_verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
94
+
95
+
(** {1 HMAC-SHA-256 (FIPS 198-1)} *)
96
+
97
+
val hmac_sha256 : key:bytes -> bytes -> (bytes, error) result
98
+
val hmac_sha256_verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
99
+
val hmac_sha256_len : int
100
+
101
+
(** {1 HMAC-SHA-384 (FIPS 198-1)} *)
102
+
103
+
val hmac_sha384 : key:bytes -> bytes -> (bytes, error) result
104
+
val hmac_sha384_verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
105
+
val hmac_sha384_len : int
106
+
107
+
(** {1 HMAC-SHA-512 (FIPS 198-1)} *)
108
+
109
+
val hmac_sha512 : key:bytes -> bytes -> (bytes, error) result
110
+
val hmac_sha512_verify : key:bytes -> mac:bytes -> bytes -> (bool, error) result
111
+
val hmac_sha512_len : int
+446
lib/security.ml
+446
lib/security.ml
···
1
+
(** Security Log (CCSDS 355.1-B-1 Section 3.4.2/3.4.3). *)
2
+
3
+
(* {1 Event Types} *)
4
+
5
+
type auth_failure_reason =
6
+
| Bad_mac
7
+
| Bad_sequence_number
8
+
| Bad_sa
9
+
| Unknown_spi
10
+
| Unknown_auth_reason of int
11
+
12
+
let pp_auth_failure_reason ppf = function
13
+
| Bad_mac -> Fmt.pf ppf "BAD_MAC"
14
+
| Bad_sequence_number -> Fmt.pf ppf "BAD_SN"
15
+
| Bad_sa -> Fmt.pf ppf "BAD_SA"
16
+
| Unknown_spi -> Fmt.pf ppf "UNKNOWN_SPI"
17
+
| Unknown_auth_reason n -> Fmt.pf ppf "UNKNOWN(%d)" n
18
+
19
+
type sa_transition =
20
+
| Sa_created
21
+
| Sa_started
22
+
| Sa_stopped
23
+
| Sa_rekeyed
24
+
| Sa_expired
25
+
| Sa_deleted
26
+
| Unknown_sa_transition of int
27
+
28
+
let pp_sa_transition ppf = function
29
+
| Sa_created -> Fmt.pf ppf "CREATED"
30
+
| Sa_started -> Fmt.pf ppf "STARTED"
31
+
| Sa_stopped -> Fmt.pf ppf "STOPPED"
32
+
| Sa_rekeyed -> Fmt.pf ppf "REKEYED"
33
+
| Sa_expired -> Fmt.pf ppf "EXPIRED"
34
+
| Sa_deleted -> Fmt.pf ppf "DELETED"
35
+
| Unknown_sa_transition n -> Fmt.pf ppf "UNKNOWN(%d)" n
36
+
37
+
type key_transition =
38
+
| Key_received
39
+
| Key_activated
40
+
| Key_deactivated
41
+
| Key_destroyed
42
+
| Unknown_key_transition of int
43
+
44
+
let pp_key_transition ppf = function
45
+
| Key_received -> Fmt.pf ppf "RECEIVED"
46
+
| Key_activated -> Fmt.pf ppf "ACTIVATED"
47
+
| Key_deactivated -> Fmt.pf ppf "DEACTIVATED"
48
+
| Key_destroyed -> Fmt.pf ppf "DESTROYED"
49
+
| Unknown_key_transition n -> Fmt.pf ppf "UNKNOWN(%d)" n
50
+
51
+
type frame_direction = Uplink | Downlink | Unknown_direction of int
52
+
53
+
let pp_frame_direction ppf = function
54
+
| Uplink -> Fmt.pf ppf "UPLINK"
55
+
| Downlink -> Fmt.pf ppf "DOWNLINK"
56
+
| Unknown_direction n -> Fmt.pf ppf "UNKNOWN(%d)" n
57
+
58
+
type event_data =
59
+
| Auth_failure of {
60
+
spi : int;
61
+
reason : auth_failure_reason;
62
+
vcid : int option;
63
+
}
64
+
| Frame_protected of {
65
+
spi : int;
66
+
direction : frame_direction;
67
+
vcid : int option;
68
+
}
69
+
| Frame_unprotected of {
70
+
spi : int;
71
+
direction : frame_direction;
72
+
vcid : int option;
73
+
}
74
+
| Iv_warning of { spi : int; remaining : int64 }
75
+
| Sa_change of { spi : int; transition : sa_transition }
76
+
| Key_change of { kid : int; transition : key_transition }
77
+
| Alarm_reset
78
+
| Self_test of { success : bool }
79
+
| Log_erased
80
+
81
+
let pp_vcid_opt ppf = function Some v -> Fmt.pf ppf "; vcid=%d" v | None -> ()
82
+
83
+
let pp_event_data ppf = function
84
+
| Auth_failure { spi; reason; vcid } ->
85
+
Fmt.pf ppf "AUTH_FAILURE { spi=%d; reason=%a%a }" spi
86
+
pp_auth_failure_reason reason pp_vcid_opt vcid
87
+
| Frame_protected { spi; direction; vcid } ->
88
+
Fmt.pf ppf "FRAME_PROTECTED { spi=%d; dir=%a%a }" spi pp_frame_direction
89
+
direction pp_vcid_opt vcid
90
+
| Frame_unprotected { spi; direction; vcid } ->
91
+
Fmt.pf ppf "FRAME_UNPROTECTED { spi=%d; dir=%a%a }" spi pp_frame_direction
92
+
direction pp_vcid_opt vcid
93
+
| Iv_warning { spi; remaining } ->
94
+
Fmt.pf ppf "IV_WARNING { spi=%d; remaining=%Ld }" spi remaining
95
+
| Sa_change { spi; transition } ->
96
+
Fmt.pf ppf "SA_CHANGE { spi=%d; %a }" spi pp_sa_transition transition
97
+
| Key_change { kid; transition } ->
98
+
Fmt.pf ppf "KEY_CHANGE { kid=%d; %a }" kid pp_key_transition transition
99
+
| Alarm_reset -> Fmt.pf ppf "ALARM_RESET"
100
+
| Self_test { success } ->
101
+
Fmt.pf ppf "SELF_TEST { %s }" (if success then "OK" else "FAILED")
102
+
| Log_erased -> Fmt.pf ppf "LOG_ERASED"
103
+
104
+
type event = { timestamp : int64; data : event_data }
105
+
106
+
let event_timestamp e = e.timestamp
107
+
let event_data e = e.data
108
+
let event ~timestamp data = { timestamp; data }
109
+
let pp_event ppf e = Fmt.pf ppf "[%Ld] %a" e.timestamp pp_event_data e.data
110
+
111
+
(* {1 Event Tags} *)
112
+
113
+
let tag_auth_failure = 0x01
114
+
let tag_frame_protected = 0x07
115
+
let tag_frame_unprotected = 0x08
116
+
let tag_iv_warning = 0x09
117
+
let tag_sa_change = 0x02
118
+
let tag_key_change = 0x03
119
+
let tag_alarm_reset = 0x04
120
+
let tag_self_test = 0x05
121
+
let tag_log_erased = 0x06
122
+
123
+
(* Auth failure reason encoding *)
124
+
let int_of_auth_reason = function
125
+
| Bad_mac -> 0
126
+
| Bad_sequence_number -> 1
127
+
| Bad_sa -> 2
128
+
| Unknown_spi -> 3
129
+
| Unknown_auth_reason n -> n
130
+
131
+
let auth_reason_of_int = function
132
+
| 0 -> Bad_mac
133
+
| 1 -> Bad_sequence_number
134
+
| 2 -> Bad_sa
135
+
| 3 -> Unknown_spi
136
+
| n -> Unknown_auth_reason n
137
+
138
+
(* Frame direction encoding *)
139
+
let int_of_direction = function
140
+
| Uplink -> 0
141
+
| Downlink -> 1
142
+
| Unknown_direction n -> n
143
+
144
+
let direction_of_int = function
145
+
| 0 -> Uplink
146
+
| 1 -> Downlink
147
+
| n -> Unknown_direction n
148
+
149
+
(* SA transition encoding *)
150
+
let int_of_sa_trans = function
151
+
| Sa_created -> 0
152
+
| Sa_started -> 1
153
+
| Sa_stopped -> 2
154
+
| Sa_rekeyed -> 3
155
+
| Sa_expired -> 4
156
+
| Sa_deleted -> 5
157
+
| Unknown_sa_transition n -> n
158
+
159
+
let sa_trans_of_int = function
160
+
| 0 -> Sa_created
161
+
| 1 -> Sa_started
162
+
| 2 -> Sa_stopped
163
+
| 3 -> Sa_rekeyed
164
+
| 4 -> Sa_expired
165
+
| 5 -> Sa_deleted
166
+
| n -> Unknown_sa_transition n
167
+
168
+
(* Key transition encoding *)
169
+
let int_of_key_trans = function
170
+
| Key_received -> 0
171
+
| Key_activated -> 1
172
+
| Key_deactivated -> 2
173
+
| Key_destroyed -> 3
174
+
| Unknown_key_transition n -> n
175
+
176
+
let key_trans_of_int = function
177
+
| 0 -> Key_received
178
+
| 1 -> Key_activated
179
+
| 2 -> Key_deactivated
180
+
| 3 -> Key_destroyed
181
+
| n -> Unknown_key_transition n
182
+
183
+
(* {1 Encoding/Decoding} *)
184
+
185
+
let write_event_data w = function
186
+
| Auth_failure { spi; reason; vcid } ->
187
+
Binary.Writer.uint8 w tag_auth_failure;
188
+
let has_vcid = Option.is_some vcid in
189
+
let data_len = 2 + 1 + if has_vcid then 1 else 0 in
190
+
Binary.Writer.uint16_be w data_len;
191
+
Binary.Writer.uint16_be w spi;
192
+
let reason_byte =
193
+
int_of_auth_reason reason land 0x7F lor if has_vcid then 0x80 else 0
194
+
in
195
+
Binary.Writer.uint8 w reason_byte;
196
+
Option.iter (fun v -> Binary.Writer.uint8 w v) vcid
197
+
| Frame_protected { spi; direction; vcid } ->
198
+
Binary.Writer.uint8 w tag_frame_protected;
199
+
let has_vcid = Option.is_some vcid in
200
+
let data_len = 2 + 1 + if has_vcid then 1 else 0 in
201
+
Binary.Writer.uint16_be w data_len;
202
+
Binary.Writer.uint16_be w spi;
203
+
let dir_byte =
204
+
int_of_direction direction land 0x7F lor if has_vcid then 0x80 else 0
205
+
in
206
+
Binary.Writer.uint8 w dir_byte;
207
+
Option.iter (fun v -> Binary.Writer.uint8 w v) vcid
208
+
| Frame_unprotected { spi; direction; vcid } ->
209
+
Binary.Writer.uint8 w tag_frame_unprotected;
210
+
let has_vcid = Option.is_some vcid in
211
+
let data_len = 2 + 1 + if has_vcid then 1 else 0 in
212
+
Binary.Writer.uint16_be w data_len;
213
+
Binary.Writer.uint16_be w spi;
214
+
let dir_byte =
215
+
int_of_direction direction land 0x7F lor if has_vcid then 0x80 else 0
216
+
in
217
+
Binary.Writer.uint8 w dir_byte;
218
+
Option.iter (fun v -> Binary.Writer.uint8 w v) vcid
219
+
| Iv_warning { spi; remaining } ->
220
+
Binary.Writer.uint8 w tag_iv_warning;
221
+
Binary.Writer.uint16_be w 10;
222
+
Binary.Writer.uint16_be w spi;
223
+
Binary.Writer.uint64_be w remaining
224
+
| Sa_change { spi; transition } ->
225
+
Binary.Writer.uint8 w tag_sa_change;
226
+
Binary.Writer.uint16_be w 3;
227
+
Binary.Writer.uint16_be w spi;
228
+
Binary.Writer.uint8 w (int_of_sa_trans transition)
229
+
| Key_change { kid; transition } ->
230
+
Binary.Writer.uint8 w tag_key_change;
231
+
Binary.Writer.uint16_be w 3;
232
+
Binary.Writer.uint16_be w kid;
233
+
Binary.Writer.uint8 w (int_of_key_trans transition)
234
+
| Alarm_reset ->
235
+
Binary.Writer.uint8 w tag_alarm_reset;
236
+
Binary.Writer.uint16_be w 0
237
+
| Self_test { success } ->
238
+
Binary.Writer.uint8 w tag_self_test;
239
+
Binary.Writer.uint16_be w 1;
240
+
Binary.Writer.uint8 w (if success then 0 else 1)
241
+
| Log_erased ->
242
+
Binary.Writer.uint8 w tag_log_erased;
243
+
Binary.Writer.uint16_be w 0
244
+
245
+
let write_event w e =
246
+
Binary.Writer.uint64_be w e.timestamp;
247
+
write_event_data w e.data
248
+
249
+
type event_error = [ `Truncated | `Invalid_tag of int | `Invalid_vcid of int ]
250
+
251
+
let pp_event_error ppf = function
252
+
| `Truncated -> Fmt.pf ppf "truncated"
253
+
| `Invalid_tag t -> Fmt.pf ppf "invalid tag: %d" t
254
+
| `Invalid_vcid v -> Fmt.pf ppf "invalid vcid: %d" v
255
+
256
+
let read_spi r = Binary.Reader.uint16_be r
257
+
258
+
let read_vcid_opt r ~has_vcid ~data_len ~min_len =
259
+
if has_vcid && data_len >= min_len then
260
+
let v = Binary.Reader.uint8 r in
261
+
if v <= 63 then Ok (Some v) else Error (`Invalid_vcid v)
262
+
else Ok None
263
+
264
+
let read_event_data r =
265
+
match Binary.Reader.ensure r 3 with
266
+
| Error (`Truncated _) -> Error `Truncated
267
+
| Ok () -> (
268
+
let tag = Binary.Reader.uint8 r in
269
+
let data_len = Binary.Reader.uint16_be r in
270
+
match Binary.Reader.ensure r data_len with
271
+
| Error (`Truncated _) -> Error `Truncated
272
+
| Ok () -> (
273
+
match tag with
274
+
| t when t = tag_auth_failure -> (
275
+
if data_len < 3 then Error `Truncated
276
+
else
277
+
let spi = read_spi r in
278
+
let reason_byte = Binary.Reader.uint8 r in
279
+
let has_vcid = reason_byte land 0x80 <> 0 in
280
+
let reason = auth_reason_of_int (reason_byte land 0x7F) in
281
+
match read_vcid_opt r ~has_vcid ~data_len ~min_len:4 with
282
+
| Error _ as e -> e
283
+
| Ok vcid -> Ok (Auth_failure { spi; reason; vcid }))
284
+
| t when t = tag_frame_protected -> (
285
+
if data_len < 3 then Error `Truncated
286
+
else
287
+
let spi = read_spi r in
288
+
let dir_byte = Binary.Reader.uint8 r in
289
+
let has_vcid = dir_byte land 0x80 <> 0 in
290
+
let direction = direction_of_int (dir_byte land 0x7F) in
291
+
match read_vcid_opt r ~has_vcid ~data_len ~min_len:4 with
292
+
| Error _ as e -> e
293
+
| Ok vcid -> Ok (Frame_protected { spi; direction; vcid }))
294
+
| t when t = tag_frame_unprotected -> (
295
+
if data_len < 3 then Error `Truncated
296
+
else
297
+
let spi = read_spi r in
298
+
let dir_byte = Binary.Reader.uint8 r in
299
+
let has_vcid = dir_byte land 0x80 <> 0 in
300
+
let direction = direction_of_int (dir_byte land 0x7F) in
301
+
match read_vcid_opt r ~has_vcid ~data_len ~min_len:4 with
302
+
| Error _ as e -> e
303
+
| Ok vcid -> Ok (Frame_unprotected { spi; direction; vcid }))
304
+
| t when t = tag_iv_warning ->
305
+
if data_len < 10 then Error `Truncated
306
+
else
307
+
let spi = read_spi r in
308
+
let remaining = Binary.Reader.uint64_be r in
309
+
Ok (Iv_warning { spi; remaining })
310
+
| t when t = tag_sa_change ->
311
+
if data_len < 3 then Error `Truncated
312
+
else
313
+
let spi = read_spi r in
314
+
let transition = sa_trans_of_int (Binary.Reader.uint8 r) in
315
+
Ok (Sa_change { spi; transition })
316
+
| t when t = tag_key_change ->
317
+
if data_len < 3 then Error `Truncated
318
+
else
319
+
let kid = Binary.Reader.uint16_be r in
320
+
let transition = key_trans_of_int (Binary.Reader.uint8 r) in
321
+
Ok (Key_change { kid; transition })
322
+
| t when t = tag_alarm_reset -> Ok Alarm_reset
323
+
| t when t = tag_self_test ->
324
+
let success =
325
+
if data_len >= 1 then Binary.Reader.uint8 r = 0 else true
326
+
in
327
+
Ok (Self_test { success })
328
+
| t when t = tag_log_erased -> Ok Log_erased
329
+
| t -> Error (`Invalid_tag t)))
330
+
331
+
let read_event r =
332
+
match Binary.Reader.ensure r 8 with
333
+
| Error (`Truncated _) -> Error `Truncated
334
+
| Ok () -> (
335
+
let timestamp = Binary.Reader.uint64_be r in
336
+
match read_event_data r with
337
+
| Error e -> Error e
338
+
| Ok data -> Ok { timestamp; data })
339
+
340
+
(* {1 Backend Interface} *)
341
+
342
+
module type S = sig
343
+
type t
344
+
345
+
val get_alarm : t -> bool
346
+
val set_alarm : t -> bool -> unit
347
+
val append : t -> event -> unit
348
+
val count : t -> int
349
+
val capacity : t -> int
350
+
val dump : t -> event list
351
+
val erase : t -> unit
352
+
end
353
+
354
+
(* {1 First-class module wrapper} *)
355
+
356
+
type t = T : (module S with type t = 'a) * 'a -> t
357
+
358
+
(* {1 Functor} *)
359
+
360
+
module Make (B : S) = struct
361
+
let v backend = T ((module B), backend)
362
+
end
363
+
364
+
(* {1 In-Memory Backend} *)
365
+
366
+
module Mem = struct
367
+
type t = {
368
+
mutable alarm : bool;
369
+
mutable events : event list;
370
+
max_events : int;
371
+
}
372
+
373
+
let get_alarm t = t.alarm
374
+
let set_alarm t v = t.alarm <- v
375
+
376
+
let append t e =
377
+
if List.length t.events < t.max_events then t.events <- t.events @ [ e ]
378
+
379
+
let count t = List.length t.events
380
+
let capacity t = (t.max_events - List.length t.events) * 32
381
+
let dump t = t.events
382
+
let erase t = t.events <- []
383
+
end
384
+
385
+
let in_memory ?max_events () =
386
+
let max_events = Option.value ~default:1000 max_events in
387
+
let backend = Mem.{ alarm = false; events = []; max_events } in
388
+
T ((module Mem), backend)
389
+
390
+
(* {1 Alarm Operations} *)
391
+
392
+
let get_alarm (T ((module B), backend)) = B.get_alarm backend
393
+
let set_alarm (T ((module B), backend)) = B.set_alarm backend true
394
+
395
+
(* {1 Log Status} *)
396
+
397
+
let count (T ((module B), backend)) = B.count backend
398
+
let capacity (T ((module B), backend)) = B.capacity backend
399
+
let dump (T ((module B), backend)) = B.dump backend
400
+
401
+
(* {1 Internal Helpers} *)
402
+
403
+
let append_event (T ((module B), backend)) e = B.append backend e
404
+
405
+
(* {1 Logging Functions} *)
406
+
407
+
let auth_failure t ~timestamp ~spi ~reason ?vcid () =
408
+
let e = event ~timestamp (Auth_failure { spi; reason; vcid }) in
409
+
append_event t e;
410
+
set_alarm t
411
+
412
+
let frame_protected t ~timestamp ~spi ~direction ?vcid () =
413
+
let e = event ~timestamp (Frame_protected { spi; direction; vcid }) in
414
+
append_event t e
415
+
416
+
let frame_unprotected t ~timestamp ~spi ~direction ?vcid () =
417
+
let e = event ~timestamp (Frame_unprotected { spi; direction; vcid }) in
418
+
append_event t e
419
+
420
+
let iv_warning t ~timestamp ~spi ~remaining =
421
+
let e = event ~timestamp (Iv_warning { spi; remaining }) in
422
+
append_event t e
423
+
424
+
let sa_change t ~timestamp ~spi ~transition =
425
+
let e = event ~timestamp (Sa_change { spi; transition }) in
426
+
append_event t e
427
+
428
+
let key_change t ~timestamp ~kid ~transition =
429
+
let e = event ~timestamp (Key_change { kid; transition }) in
430
+
append_event t e
431
+
432
+
let self_test t ~timestamp ~success =
433
+
let e = event ~timestamp (Self_test { success }) in
434
+
append_event t e
435
+
436
+
let alarm_reset (T ((module B), backend) as t) ~timestamp =
437
+
if B.get_alarm backend then begin
438
+
B.set_alarm backend false;
439
+
let e = event ~timestamp Alarm_reset in
440
+
append_event t e
441
+
end
442
+
443
+
let erase (T ((module B), backend) as t) ~timestamp =
444
+
B.erase backend;
445
+
let e = event ~timestamp Log_erased in
446
+
append_event t e
+165
lib/security.mli
+165
lib/security.mli
···
1
+
(** Security Log and Alarm (CCSDS 355.1-B-1 Section 3.4.2/3.4.3).
2
+
3
+
The Security Log stores security-relevant events for audit and monitoring.
4
+
SPI and VCID are represented as bare [int] values (16-bit and 6-bit
5
+
respectively). *)
6
+
7
+
(** {1 Event Types} *)
8
+
9
+
type auth_failure_reason =
10
+
| Bad_mac
11
+
| Bad_sequence_number
12
+
| Bad_sa
13
+
| Unknown_spi
14
+
| Unknown_auth_reason of int
15
+
16
+
type sa_transition =
17
+
| Sa_created
18
+
| Sa_started
19
+
| Sa_stopped
20
+
| Sa_rekeyed
21
+
| Sa_expired
22
+
| Sa_deleted
23
+
| Unknown_sa_transition of int
24
+
25
+
type key_transition =
26
+
| Key_received
27
+
| Key_activated
28
+
| Key_deactivated
29
+
| Key_destroyed
30
+
| Unknown_key_transition of int
31
+
32
+
type frame_direction = Uplink | Downlink | Unknown_direction of int
33
+
34
+
type event_data =
35
+
| Auth_failure of {
36
+
spi : int;
37
+
reason : auth_failure_reason;
38
+
vcid : int option;
39
+
}
40
+
| Frame_protected of {
41
+
spi : int;
42
+
direction : frame_direction;
43
+
vcid : int option;
44
+
}
45
+
| Frame_unprotected of {
46
+
spi : int;
47
+
direction : frame_direction;
48
+
vcid : int option;
49
+
}
50
+
| Iv_warning of { spi : int; remaining : int64 }
51
+
| Sa_change of { spi : int; transition : sa_transition }
52
+
| Key_change of { kid : int; transition : key_transition }
53
+
| Alarm_reset
54
+
| Self_test of { success : bool }
55
+
| Log_erased
56
+
57
+
val pp_auth_failure_reason : auth_failure_reason Fmt.t
58
+
val pp_sa_transition : sa_transition Fmt.t
59
+
val pp_key_transition : key_transition Fmt.t
60
+
val pp_frame_direction : frame_direction Fmt.t
61
+
val pp_event_data : event_data Fmt.t
62
+
63
+
(** {1 Event Type} *)
64
+
65
+
type event
66
+
67
+
val event_timestamp : event -> int64
68
+
val event_data : event -> event_data
69
+
val pp_event : event Fmt.t
70
+
71
+
(** {1 Security Store} *)
72
+
73
+
type t
74
+
75
+
module type S = sig
76
+
type t
77
+
78
+
val get_alarm : t -> bool
79
+
val set_alarm : t -> bool -> unit
80
+
val append : t -> event -> unit
81
+
val count : t -> int
82
+
val capacity : t -> int
83
+
val dump : t -> event list
84
+
val erase : t -> unit
85
+
end
86
+
87
+
module Make (B : S) : sig
88
+
val v : B.t -> t
89
+
end
90
+
91
+
val in_memory : ?max_events:int -> unit -> t
92
+
93
+
(** {1 Alarm Flag Operations} *)
94
+
95
+
val get_alarm : t -> bool
96
+
val set_alarm : t -> unit
97
+
98
+
(** {1 Log Status} *)
99
+
100
+
val count : t -> int
101
+
val capacity : t -> int
102
+
val dump : t -> event list
103
+
104
+
(** {1 Logging Functions} *)
105
+
106
+
val auth_failure :
107
+
t ->
108
+
timestamp:int64 ->
109
+
spi:int ->
110
+
reason:auth_failure_reason ->
111
+
?vcid:int ->
112
+
unit ->
113
+
unit
114
+
115
+
val frame_protected :
116
+
t ->
117
+
timestamp:int64 ->
118
+
spi:int ->
119
+
direction:frame_direction ->
120
+
?vcid:int ->
121
+
unit ->
122
+
unit
123
+
124
+
val frame_unprotected :
125
+
t ->
126
+
timestamp:int64 ->
127
+
spi:int ->
128
+
direction:frame_direction ->
129
+
?vcid:int ->
130
+
unit ->
131
+
unit
132
+
133
+
val iv_warning : t -> timestamp:int64 -> spi:int -> remaining:int64 -> unit
134
+
135
+
val sa_change :
136
+
t -> timestamp:int64 -> spi:int -> transition:sa_transition -> unit
137
+
138
+
val key_change :
139
+
t -> timestamp:int64 -> kid:int -> transition:key_transition -> unit
140
+
141
+
val self_test : t -> timestamp:int64 -> success:bool -> unit
142
+
val alarm_reset : t -> timestamp:int64 -> unit
143
+
val erase : t -> timestamp:int64 -> unit
144
+
145
+
(** {1 Event Tags} *)
146
+
147
+
val tag_auth_failure : int
148
+
val tag_frame_protected : int
149
+
val tag_frame_unprotected : int
150
+
val tag_iv_warning : int
151
+
val tag_sa_change : int
152
+
val tag_key_change : int
153
+
val tag_alarm_reset : int
154
+
val tag_self_test : int
155
+
val tag_log_erased : int
156
+
157
+
(** {1 Encoding/Decoding} *)
158
+
159
+
type event_error = [ `Truncated | `Invalid_tag of int | `Invalid_vcid of int ]
160
+
161
+
val pp_event_error : Format.formatter -> event_error -> unit
162
+
val write_event : Binary.Writer.t -> event -> unit
163
+
val read_event : Binary.Reader.t -> (event, event_error) result
164
+
val write_event_data : Binary.Writer.t -> event_data -> unit
165
+
val read_event_data : Binary.Reader.t -> (event_data, event_error) result
+37
sdls.opam
+37
sdls.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "CCSDS Space Data Link Security (355.0-B-2)"
4
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
5
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
6
+
license: "ISC"
7
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-sdls"
8
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-sdls/issues"
9
+
depends: [
10
+
"dune" {>= "3.21"}
11
+
"ocaml" {>= "5.1"}
12
+
"crypto" {>= "0.1"}
13
+
"fmt" {>= "0.9"}
14
+
"logs" {>= "0.7"}
15
+
"digestif" {>= "1.0"}
16
+
"eqaf" {>= "0.9"}
17
+
"bitv" {>= "1.0"}
18
+
"wire" {>= "0.9"}
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://tangled.org/gazagnaire.org/ocaml-sdls"
37
+
x-maintenance-intent: ["(latest)"]
+187
test/test_ep.ml
+187
test/test_ep.ml
···
1
+
open Sdls
2
+
3
+
(* {1 EP Header Round-trip} *)
4
+
5
+
let test_header_roundtrip () =
6
+
let hdr =
7
+
Ep.
8
+
{
9
+
is_reply = false;
10
+
user_flag = true;
11
+
service_group = SG_key_management;
12
+
procedure_id = 1;
13
+
pdu_len = 42;
14
+
}
15
+
in
16
+
let buf = Ep.encode_header hdr in
17
+
match Ep.decode_header buf 0 with
18
+
| Error `Truncated -> Alcotest.fail "unexpected truncation"
19
+
| Error `Invalid_sg -> Alcotest.fail "unexpected invalid service group"
20
+
| Ok hdr' ->
21
+
Alcotest.(check bool) "is_reply" hdr.is_reply hdr'.is_reply;
22
+
Alcotest.(check bool) "user_flag" hdr.user_flag hdr'.user_flag;
23
+
Alcotest.(check int)
24
+
"service_group"
25
+
(Ep.int_of_service_group hdr.service_group)
26
+
(Ep.int_of_service_group hdr'.service_group);
27
+
Alcotest.(check int) "procedure_id" hdr.procedure_id hdr'.procedure_id;
28
+
Alcotest.(check int) "pdu_len" hdr.pdu_len hdr'.pdu_len
29
+
30
+
let test_header_reply () =
31
+
let hdr =
32
+
Ep.
33
+
{
34
+
is_reply = true;
35
+
user_flag = false;
36
+
service_group = SG_sec_mon_ctrl;
37
+
procedure_id = 5;
38
+
pdu_len = 1;
39
+
}
40
+
in
41
+
let buf = Ep.encode_header hdr in
42
+
match Ep.decode_header buf 0 with
43
+
| Error _ -> Alcotest.fail "unexpected error"
44
+
| Ok hdr' ->
45
+
Alcotest.(check bool) "is_reply" true hdr'.is_reply;
46
+
Alcotest.(check int) "sg" 3 (Ep.int_of_service_group hdr'.service_group);
47
+
Alcotest.(check int) "pid" 5 hdr'.procedure_id;
48
+
Alcotest.(check int) "pdu_len" 1 hdr'.pdu_len
49
+
50
+
let test_header_all_service_groups () =
51
+
List.iter
52
+
(fun sg ->
53
+
let hdr =
54
+
Ep.
55
+
{
56
+
is_reply = false;
57
+
user_flag = false;
58
+
service_group = sg;
59
+
procedure_id = 0;
60
+
pdu_len = 0;
61
+
}
62
+
in
63
+
let buf = Ep.encode_header hdr in
64
+
match Ep.decode_header buf 0 with
65
+
| Error _ ->
66
+
Alcotest.failf "roundtrip failed for sg=%a" Ep.pp_service_group sg
67
+
| Ok hdr' ->
68
+
Alcotest.(check int)
69
+
"sg roundtrip"
70
+
(Ep.int_of_service_group sg)
71
+
(Ep.int_of_service_group hdr'.service_group))
72
+
Ep.
73
+
[
74
+
SG_key_management;
75
+
SG_sa_management_ir;
76
+
SG_sa_management_ri;
77
+
SG_sec_mon_ctrl;
78
+
]
79
+
80
+
let test_header_truncated () =
81
+
let buf = Bytes.create 2 in
82
+
match Ep.decode_header buf 0 with
83
+
| Error `Truncated -> ()
84
+
| Error `Invalid_sg -> Alcotest.fail "expected truncated, got invalid_sg"
85
+
| Ok _ -> Alcotest.fail "expected error on truncated buffer"
86
+
87
+
(* {1 MC Status Reply Round-trip} *)
88
+
89
+
let test_mc_status_roundtrip () =
90
+
let r = Ep.{ operational = true; key_count = 7; sa_count = 3 } in
91
+
let buf = Ep.encode_mc_status_reply r in
92
+
match Ep.decode_mc_status_reply buf 0 with
93
+
| Error `Truncated -> Alcotest.fail "unexpected truncation"
94
+
| Ok r' ->
95
+
Alcotest.(check bool) "operational" r.operational r'.operational;
96
+
Alcotest.(check int) "key_count" r.key_count r'.key_count;
97
+
Alcotest.(check int) "sa_count" r.sa_count r'.sa_count
98
+
99
+
(* {1 Procedure ID Conversions} *)
100
+
101
+
let test_key_procedures () =
102
+
let procs =
103
+
Ep.
104
+
[
105
+
Key_otar;
106
+
Key_activation;
107
+
Key_deactivation;
108
+
Key_verification;
109
+
Key_destruction;
110
+
Key_inventory;
111
+
]
112
+
in
113
+
List.iter
114
+
(fun p ->
115
+
let i = Ep.int_of_key_procedure p in
116
+
match Ep.key_procedure_of_int i with
117
+
| None -> Alcotest.failf "roundtrip failed for %a" Ep.pp_key_procedure p
118
+
| Some p' ->
119
+
Alcotest.(check int)
120
+
"key_procedure roundtrip"
121
+
(Ep.int_of_key_procedure p)
122
+
(Ep.int_of_key_procedure p'))
123
+
procs
124
+
125
+
let test_sa_procedures () =
126
+
let procs =
127
+
Ep.
128
+
[
129
+
SA_read_arsn;
130
+
SA_create;
131
+
SA_delete;
132
+
SA_set_arsnw;
133
+
SA_rekey;
134
+
SA_expire;
135
+
SA_set_arsn;
136
+
SA_start;
137
+
SA_stop;
138
+
SA_status;
139
+
]
140
+
in
141
+
List.iter
142
+
(fun p ->
143
+
let i = Ep.int_of_sa_procedure p in
144
+
match Ep.sa_procedure_of_int i with
145
+
| None -> Alcotest.failf "roundtrip failed for %a" Ep.pp_sa_procedure p
146
+
| Some p' ->
147
+
Alcotest.(check int)
148
+
"sa_procedure roundtrip" (Ep.int_of_sa_procedure p)
149
+
(Ep.int_of_sa_procedure p'))
150
+
procs
151
+
152
+
let test_monitoring_procedures () =
153
+
let procs =
154
+
Ep.
155
+
[
156
+
MC_ping;
157
+
MC_log_status;
158
+
MC_dump_log;
159
+
MC_erase_log;
160
+
MC_self_test;
161
+
MC_alarm_reset;
162
+
]
163
+
in
164
+
List.iter
165
+
(fun p ->
166
+
let i = Ep.int_of_monitoring_procedure p in
167
+
match Ep.monitoring_procedure_of_int i with
168
+
| None ->
169
+
Alcotest.failf "roundtrip failed for %a" Ep.pp_monitoring_procedure p
170
+
| Some p' ->
171
+
Alcotest.(check int)
172
+
"monitoring_procedure roundtrip"
173
+
(Ep.int_of_monitoring_procedure p)
174
+
(Ep.int_of_monitoring_procedure p'))
175
+
procs
176
+
177
+
let tests =
178
+
[
179
+
Alcotest.test_case "header roundtrip" `Quick test_header_roundtrip;
180
+
Alcotest.test_case "header reply" `Quick test_header_reply;
181
+
Alcotest.test_case "header all SGs" `Quick test_header_all_service_groups;
182
+
Alcotest.test_case "header truncated" `Quick test_header_truncated;
183
+
Alcotest.test_case "mc_status roundtrip" `Quick test_mc_status_roundtrip;
184
+
Alcotest.test_case "key procedures" `Quick test_key_procedures;
185
+
Alcotest.test_case "sa procedures" `Quick test_sa_procedures;
186
+
Alcotest.test_case "monitoring procedures" `Quick test_monitoring_procedures;
187
+
]
+197
test/test_mc.ml
+197
test/test_mc.ml
···
1
+
open Sdls
2
+
3
+
(* {1 Log Status Reply Round-trip} *)
4
+
5
+
let test_log_status_roundtrip () =
6
+
let r : Mc.log_status_reply = { num_events = 42; remaining_space = 1234 } in
7
+
let buf = Mc.encode_log_status_reply r in
8
+
match Mc.decode_log_status_reply buf 0 with
9
+
| Error `Truncated -> Alcotest.fail "unexpected truncation"
10
+
| Ok r' ->
11
+
Alcotest.(check int) "num_events" r.num_events r'.num_events;
12
+
Alcotest.(check int)
13
+
"remaining_space" r.remaining_space r'.remaining_space
14
+
15
+
let test_log_status_truncated () =
16
+
let buf = Bytes.create 3 in
17
+
match Mc.decode_log_status_reply buf 0 with
18
+
| Error `Truncated -> ()
19
+
| Ok _ -> Alcotest.fail "expected truncation error"
20
+
21
+
(* {1 Erase Log Reply Round-trip} *)
22
+
23
+
let test_erase_log_roundtrip () =
24
+
let r = Mc.{ num_events = 0; remaining_space = 32000 } in
25
+
let buf = Mc.encode_erase_log_reply r in
26
+
match Mc.decode_erase_log_reply buf 0 with
27
+
| Error `Truncated -> Alcotest.fail "unexpected truncation"
28
+
| Ok r' ->
29
+
Alcotest.(check int) "num_events" 0 r'.num_events;
30
+
Alcotest.(check int) "remaining_space" 32000 r'.remaining_space
31
+
32
+
(* {1 Self-Test Reply Round-trip} *)
33
+
34
+
let test_self_test_ok () =
35
+
let r = Mc.{ result = Self_test_ok } in
36
+
let buf = Mc.encode_self_test_reply r in
37
+
match Mc.decode_self_test_reply buf 0 with
38
+
| Error `Truncated -> Alcotest.fail "unexpected truncation"
39
+
| Ok r' -> (
40
+
match r'.result with
41
+
| Mc.Self_test_ok -> ()
42
+
| Mc.Self_test_failed c -> Alcotest.failf "expected ok, got failed(%d)" c)
43
+
44
+
let test_self_test_failed () =
45
+
let code = 0x2A in
46
+
let r = Mc.{ result = Self_test_failed code } in
47
+
let buf = Mc.encode_self_test_reply r in
48
+
match Mc.decode_self_test_reply buf 0 with
49
+
| Error `Truncated -> Alcotest.fail "unexpected truncation"
50
+
| Ok r' -> (
51
+
match r'.result with
52
+
| Mc.Self_test_ok -> Alcotest.fail "expected failed, got ok"
53
+
| Mc.Self_test_failed c -> Alcotest.(check int) "error code" code c)
54
+
55
+
(* {1 Event Data Round-trip} *)
56
+
57
+
let test_auth_failure_event () =
58
+
let ev = Mc.Auth_failure { spi = 0x0042; reason = Bad_mac; vcid = Some 7 } in
59
+
let buf = Mc.encode_event_data ev in
60
+
match Mc.decode_event_data buf 0 with
61
+
| Error e -> Alcotest.failf "decode error: %a" Mc.pp_event_error e
62
+
| Ok (ev', _consumed) -> (
63
+
match ev' with
64
+
| Mc.Auth_failure { spi; reason; vcid } ->
65
+
Alcotest.(check int) "spi" 0x0042 spi;
66
+
(match reason with
67
+
| Mc.Bad_mac -> ()
68
+
| _ -> Alcotest.fail "expected Bad_mac");
69
+
Alcotest.(check (option int)) "vcid" (Some 7) vcid
70
+
| _ -> Alcotest.fail "expected Auth_failure event")
71
+
72
+
let test_auth_failure_no_vcid () =
73
+
let ev =
74
+
Mc.Auth_failure { spi = 0x0001; reason = Bad_sequence_number; vcid = None }
75
+
in
76
+
let buf = Mc.encode_event_data ev in
77
+
match Mc.decode_event_data buf 0 with
78
+
| Error e -> Alcotest.failf "decode error: %a" Mc.pp_event_error e
79
+
| Ok (ev', _) -> (
80
+
match ev' with
81
+
| Mc.Auth_failure { spi; reason; vcid } ->
82
+
Alcotest.(check int) "spi" 0x0001 spi;
83
+
(match reason with
84
+
| Mc.Bad_sequence_number -> ()
85
+
| _ -> Alcotest.fail "expected Bad_sequence_number");
86
+
Alcotest.(check (option int)) "vcid" None vcid
87
+
| _ -> Alcotest.fail "expected Auth_failure event")
88
+
89
+
let test_frame_protected_event () =
90
+
let ev =
91
+
Mc.Frame_protected { spi = 0x0100; direction = Downlink; vcid = Some 3 }
92
+
in
93
+
let buf = Mc.encode_event_data ev in
94
+
match Mc.decode_event_data buf 0 with
95
+
| Error e -> Alcotest.failf "decode error: %a" Mc.pp_event_error e
96
+
| Ok (ev', _) -> (
97
+
match ev' with
98
+
| Mc.Frame_protected { spi; direction; vcid } ->
99
+
Alcotest.(check int) "spi" 0x0100 spi;
100
+
(match direction with
101
+
| Mc.Downlink -> ()
102
+
| _ -> Alcotest.fail "expected Downlink");
103
+
Alcotest.(check (option int)) "vcid" (Some 3) vcid
104
+
| _ -> Alcotest.fail "expected Frame_protected event")
105
+
106
+
let test_iv_warning_event () =
107
+
let ev = Mc.Iv_warning { spi = 0x0010; remaining = 42L } in
108
+
let buf = Mc.encode_event_data ev in
109
+
match Mc.decode_event_data buf 0 with
110
+
| Error e -> Alcotest.failf "decode error: %a" Mc.pp_event_error e
111
+
| Ok (ev', _) -> (
112
+
match ev' with
113
+
| Mc.Iv_warning { spi; remaining } ->
114
+
Alcotest.(check int) "spi" 0x0010 spi;
115
+
Alcotest.(check int64) "remaining" 42L remaining
116
+
| _ -> Alcotest.fail "expected Iv_warning event")
117
+
118
+
let test_sa_change_event () =
119
+
let ev = Mc.Sa_change { spi = 0x0005; transition = Sa_rekeyed } in
120
+
let buf = Mc.encode_event_data ev in
121
+
match Mc.decode_event_data buf 0 with
122
+
| Error e -> Alcotest.failf "decode error: %a" Mc.pp_event_error e
123
+
| Ok (ev', _) -> (
124
+
match ev' with
125
+
| Mc.Sa_change { spi; transition } -> (
126
+
Alcotest.(check int) "spi" 0x0005 spi;
127
+
match transition with
128
+
| Mc.Sa_rekeyed -> ()
129
+
| _ -> Alcotest.fail "expected Sa_rekeyed")
130
+
| _ -> Alcotest.fail "expected Sa_change event")
131
+
132
+
let test_key_change_event () =
133
+
let ev = Mc.Key_change { kid = 0x00FF; transition = Key_activated } in
134
+
let buf = Mc.encode_event_data ev in
135
+
match Mc.decode_event_data buf 0 with
136
+
| Error e -> Alcotest.failf "decode error: %a" Mc.pp_event_error e
137
+
| Ok (ev', _) -> (
138
+
match ev' with
139
+
| Mc.Key_change { kid; transition } -> (
140
+
Alcotest.(check int) "kid" 0x00FF kid;
141
+
match transition with
142
+
| Mc.Key_activated -> ()
143
+
| _ -> Alcotest.fail "expected Key_activated")
144
+
| _ -> Alcotest.fail "expected Key_change event")
145
+
146
+
let test_simple_events () =
147
+
(* Alarm_reset, Self_test, Log_erased have no fields *)
148
+
let test ev name =
149
+
let buf = Mc.encode_event_data ev in
150
+
match Mc.decode_event_data buf 0 with
151
+
| Error e -> Alcotest.failf "%s: decode error: %a" name Mc.pp_event_error e
152
+
| Ok (_, _consumed) -> ()
153
+
in
154
+
test Mc.Alarm_reset "Alarm_reset";
155
+
test (Mc.Self_test { success = true }) "Self_test ok";
156
+
test (Mc.Self_test { success = false }) "Self_test failed";
157
+
test Mc.Log_erased "Log_erased"
158
+
159
+
(* {1 Dump Log Reply Round-trip} *)
160
+
161
+
let test_dump_log_roundtrip () =
162
+
let events =
163
+
Mc.
164
+
[
165
+
Auth_failure { spi = 1; reason = Bad_mac; vcid = None };
166
+
Sa_change { spi = 2; transition = Sa_started };
167
+
Frame_protected { spi = 3; direction = Uplink; vcid = Some 0 };
168
+
Alarm_reset;
169
+
Self_test { success = true };
170
+
Log_erased;
171
+
]
172
+
in
173
+
let reply = Mc.{ events } in
174
+
let buf = Mc.encode_dump_log_reply reply in
175
+
match Mc.decode_dump_log_reply buf 0 with
176
+
| Error e -> Alcotest.failf "decode error: %a" Mc.pp_event_error e
177
+
| Ok reply' ->
178
+
Alcotest.(check int)
179
+
"event count" (List.length events)
180
+
(List.length reply'.events)
181
+
182
+
let tests =
183
+
[
184
+
Alcotest.test_case "log_status roundtrip" `Quick test_log_status_roundtrip;
185
+
Alcotest.test_case "log_status truncated" `Quick test_log_status_truncated;
186
+
Alcotest.test_case "erase_log roundtrip" `Quick test_erase_log_roundtrip;
187
+
Alcotest.test_case "self_test ok" `Quick test_self_test_ok;
188
+
Alcotest.test_case "self_test failed" `Quick test_self_test_failed;
189
+
Alcotest.test_case "auth_failure event" `Quick test_auth_failure_event;
190
+
Alcotest.test_case "auth_failure no vcid" `Quick test_auth_failure_no_vcid;
191
+
Alcotest.test_case "frame_protected event" `Quick test_frame_protected_event;
192
+
Alcotest.test_case "iv_warning event" `Quick test_iv_warning_event;
193
+
Alcotest.test_case "sa_change event" `Quick test_sa_change_event;
194
+
Alcotest.test_case "key_change event" `Quick test_key_change_event;
195
+
Alcotest.test_case "simple events" `Quick test_simple_events;
196
+
Alcotest.test_case "dump_log roundtrip" `Quick test_dump_log_roundtrip;
197
+
]
+1
test/test_sdls.ml
+1
test/test_sdls.ml
···
1
+
let () = Alcotest.run "sdls" [ ("ep", Test_ep.tests); ("mc", Test_mc.tests) ]