Eliminate manual byte-picking across 8 packages · gazagnaire.org/ocaml-sdls@6019d41

+26 -21

lib/ep.ml

··· 206 206 Byte 0: Type (1b) | UF (1b) | SG (2b) | PID (4b) 207 207 Bytes 1-2: PDU_LEN (16b) *) 208 208 209 - let _header_len = 3 210 209 211 210 type header = { 212 211 is_reply : bool; ··· 227 226 let w_sg = Wire.Field.v "SG" (bits8 2) 228 227 let w_pid = Wire.Field.v "PID" (bits8 4) 229 228 let w_pdu_len = Wire.Field.v "PDU_LEN" Wire.uint16be 229 + 230 + let bf_sg = Wire.Codec.(w_sg $ fun t -> int_of_service_group t.service_group) 230 231 231 232 let codec = 232 233 Wire.Codec.v "EP_Header" ··· 241 242 [ 242 243 (w_type $ fun t -> t.is_reply); 243 244 (w_uf $ fun t -> t.user_flag); 244 - (w_sg $ fun t -> int_of_service_group t.service_group); 245 + bf_sg; 245 246 (w_pid $ fun t -> t.procedure_id); 246 247 (w_pdu_len $ fun t -> t.pdu_len); 247 248 ] ··· 253 254 Wire.Codec.encode codec hdr buf 0; 254 255 buf 255 256 257 + let get_sg = Wire.Staged.unstage (Wire.Codec.get codec bf_sg) 258 + 256 259 let decode_header buf off = 257 260 if Bytes.length buf - off < wire_size then Error `Truncated 258 261 else 259 - let raw_b0 = Char.code (Bytes.get buf off) in 260 - let sg_bits = (raw_b0 lsr 4) land 0x3 in 262 + let sg_bits = get_sg buf off in 261 263 match service_group_of_int sg_bits with 262 264 | None -> Error `Invalid_sg 263 265 | Some _ -> ( ··· 283 285 Fmt.pf ppf "MC_STATUS_REPLY { op=%b; keys=%d; sas=%d }" r.operational 284 286 r.key_count r.sa_count 285 287 286 - let mc_status_reply_size = 5 288 + let w_operational = Wire.Field.v "Operational" (Wire.bit Wire.uint8) 289 + let w_key_count = Wire.Field.v "KeyCount" Wire.uint16be 290 + let w_sa_count = Wire.Field.v "SACount" Wire.uint16be 291 + 292 + let mc_status_reply_codec = 293 + Wire.Codec.v "MC_Status_Reply" 294 + (fun operational key_count sa_count -> 295 + { operational; key_count; sa_count }) 296 + Wire.Codec. 297 + [ 298 + (w_operational $ fun r -> r.operational); 299 + (w_key_count $ fun r -> r.key_count); 300 + (w_sa_count $ fun r -> r.sa_count); 301 + ] 302 + 303 + let mc_status_reply_size = Wire.Codec.wire_size mc_status_reply_codec 287 304 288 305 let encode_mc_status_reply r = 289 306 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)); 307 + Wire.Codec.encode mc_status_reply_codec r buf 0; 295 308 buf 296 309 297 310 let decode_mc_status_reply buf off = 298 311 if Bytes.length buf - off < mc_status_reply_size then Error `Truncated 299 312 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 } 313 + match Wire.Codec.decode mc_status_reply_codec buf off with 314 + | Ok r -> Ok r 315 + | Error _ -> Error `Truncated 311 316 312 317 (* {1 Error Type} *) 313 318

+3

lib/ep.mli

··· 124 124 } 125 125 (** Status reply - SDLS engine status. *) 126 126 127 + val mc_status_reply_codec : mc_status_reply Wire.Codec.t 128 + (** Wire codec for the 5-byte MC status reply. *) 129 + 127 130 val mc_status_reply_size : int 128 131 (** Size of the MC status reply data in bytes (5). *) 129 132

+246 -163

lib/mc.ml

··· 15 15 @see <https://public.ccsds.org/Pubs/355x1b1.pdf> 16 16 CCSDS 355.1-B-1 Section 3.4.3 *) 17 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 18 + (* {1 Wire Codec helpers} *) 47 19 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) 20 + let w_u8 name = Wire.Field.v name Wire.uint8 21 + let w_u16 name = Wire.Field.v name Wire.uint16be 22 + let w_u64 name = Wire.Field.v name Wire.uint64be 57 23 58 24 (* {1 Log Status PDU (PID=2)} 59 25 ··· 70 36 Fmt.pf ppf "LOG_STATUS_REPLY { events=%d; space=%d }" r.num_events 71 37 r.remaining_space 72 38 73 - let log_status_reply_size = 4 39 + let f_num_events = w_u16 "NumEvents" 40 + let f_remaining_space = w_u16 "RemainingSpace" 41 + 42 + let log_status_reply_codec = 43 + Wire.Codec.v "Log_Status_Reply" 44 + (fun num_events remaining_space -> { num_events; remaining_space }) 45 + Wire.Codec. 46 + [ 47 + (f_num_events $ fun r -> r.num_events); 48 + (f_remaining_space $ fun r -> r.remaining_space); 49 + ] 50 + 51 + let log_status_reply_size = Wire.Codec.wire_size log_status_reply_codec 74 52 75 53 let encode_log_status_reply r = 76 54 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; 55 + Wire.Codec.encode log_status_reply_codec r buf 0; 79 56 buf 80 57 81 58 let decode_log_status_reply buf off = 82 59 if Bytes.length buf - off < log_status_reply_size then Error `Truncated 83 60 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 } 61 + match Wire.Codec.decode log_status_reply_codec buf off with 62 + | Ok r -> Ok r 63 + | Error _ -> Error `Truncated 87 64 88 65 (* {1 Erase Log PDU (PID=4)} 89 66 ··· 100 77 Fmt.pf ppf "ERASE_LOG_REPLY { events=%d; space=%d }" r.num_events 101 78 r.remaining_space 102 79 103 - let erase_log_reply_size = 4 80 + let erase_log_reply_codec = 81 + Wire.Codec.v "Erase_Log_Reply" 82 + (fun num_events remaining_space -> { num_events; remaining_space }) 83 + Wire.Codec. 84 + [ 85 + (f_num_events $ fun r -> r.num_events); 86 + (f_remaining_space $ fun r -> r.remaining_space); 87 + ] 88 + 89 + let erase_log_reply_size = Wire.Codec.wire_size erase_log_reply_codec 104 90 105 91 let encode_erase_log_reply r = 106 92 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; 93 + Wire.Codec.encode erase_log_reply_codec r buf 0; 109 94 buf 110 95 111 96 let decode_erase_log_reply buf off = 112 97 if Bytes.length buf - off < erase_log_reply_size then Error `Truncated 113 98 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 } 99 + match Wire.Codec.decode erase_log_reply_codec buf off with 100 + | Ok r -> Ok r 101 + | Error _ -> Error `Truncated 117 102 118 103 (* {1 Self-Test PDU (PID=5)} 119 104 ··· 136 121 let pp_self_test_reply ppf r = 137 122 Fmt.pf ppf "SELF_TEST_REPLY { result=%a }" pp_self_test_result r.result 138 123 139 - let self_test_reply_size = 1 124 + let self_test_int_of_result = function 125 + | Self_test_ok -> 0x00 126 + | Self_test_failed code -> 0x80 lor (code land 0x7F) 127 + 128 + let self_test_result_of_int v = 129 + if v land 0x80 = 0 then Self_test_ok else Self_test_failed (v land 0x7F) 130 + 131 + let f_self_test = 132 + Wire.Field.v "Result" 133 + (Wire.map ~decode:self_test_result_of_int ~encode:self_test_int_of_result 134 + Wire.uint8) 135 + 136 + let self_test_reply_codec = 137 + Wire.Codec.v "Self_Test_Reply" 138 + (fun result -> { result }) 139 + Wire.Codec.[ (f_self_test $ fun r -> r.result) ] 140 + 141 + let self_test_reply_size = Wire.Codec.wire_size self_test_reply_codec 140 142 141 143 let encode_self_test_reply r = 142 144 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; 145 + Wire.Codec.encode self_test_reply_codec r buf 0; 149 146 buf 150 147 151 148 let decode_self_test_reply buf off = 152 149 if Bytes.length buf - off < self_test_reply_size then Error `Truncated 153 150 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 } 151 + match Wire.Codec.decode self_test_reply_codec buf off with 152 + | Ok r -> Ok r 153 + | Error _ -> Error `Truncated 159 154 160 155 (* {1 Security Event Types} 161 156 ··· 347 342 | 3 -> Key_destroyed 348 343 | n -> Unknown_key_transition n 349 344 350 - (* {2 Event Data Encoding} 345 + (* {2 Event Wire Codecs} 346 + 347 + Each event is TLV-encoded into a byte buffer. The TLV header is 348 + tag (1 byte) + length (2 bytes). Event-specific payloads use Wire codecs. 349 + 350 + The encoder returns a fresh bytes buffer; the decoder reads from a buffer 351 + at a given offset and returns the event plus the number of bytes consumed. *) 352 + 353 + (* TLV header codec: tag(1) + data_len(2) = 3 bytes *) 354 + 355 + type tlv_header = { tag : int; data_len : int } 356 + 357 + let f_tag = w_u8 "Tag" 358 + let f_data_len = w_u16 "DataLen" 359 + 360 + let tlv_header_codec = 361 + Wire.Codec.v "TLV_Header" 362 + (fun tag data_len -> { tag; data_len }) 363 + Wire.Codec. 364 + [ 365 + (f_tag $ fun h -> h.tag); 366 + (f_data_len $ fun h -> h.data_len); 367 + ] 368 + 369 + let tlv_header_size = Wire.Codec.wire_size tlv_header_codec 370 + 371 + (* SPI + u8-flags/subtype + optional VCID event codec (auth_failure, 372 + frame_protected, frame_unprotected) *) 373 + 374 + type spi_code_vcid = { spi : int; code : int; vcid : int option } 375 + 376 + let f_ev_spi = w_u16 "SPI" 377 + let f_ev_code = w_u8 "Code" 378 + 379 + let spi_code_codec = 380 + Wire.Codec.v "SPI_Code" 381 + (fun spi code -> { spi; code; vcid = None }) 382 + Wire.Codec. 383 + [ 384 + (f_ev_spi $ fun r -> r.spi); 385 + (f_ev_code $ fun r -> 386 + let base = r.code land 0x7F in 387 + base lor if Option.is_some r.vcid then 0x80 else 0); 388 + ] 389 + 390 + let spi_code_size = Wire.Codec.wire_size spi_code_codec 391 + 392 + (** Encode the SPI + code byte + optional VCID. *) 393 + let encode_spi_code_vcid ~spi ~code ~vcid = 394 + let has_vcid = Option.is_some vcid in 395 + let total = spi_code_size + if has_vcid then 1 else 0 in 396 + let buf = Bytes.create total in 397 + let rec_val = { spi; code; vcid } in 398 + Wire.Codec.encode spi_code_codec rec_val buf 0; 399 + (match vcid with 400 + | Some v -> Bytes.set_uint8 buf spi_code_size v 401 + | None -> ()); 402 + buf 403 + 404 + (** Decode the SPI + code byte + optional VCID from [buf] at [off] with 405 + [data_len] bytes available. *) 406 + let decode_spi_code_vcid buf off data_len = 407 + if data_len < spi_code_size then Error `Truncated 408 + else 409 + match Wire.Codec.decode spi_code_codec buf off with 410 + | Error _ -> Error `Truncated 411 + | Ok r -> 412 + let has_vcid = r.code land 0x80 <> 0 in 413 + let code = r.code land 0x7F in 414 + if has_vcid && data_len >= spi_code_size + 1 then 415 + let v = Bytes.get_uint8 buf (off + spi_code_size) in 416 + if v > 63 then Error (`Invalid_vcid v) 417 + else Ok (r.spi, code, Some v) 418 + else Ok (r.spi, code, None) 419 + 420 + (* SPI + u64 remaining codec (iv_warning) *) 421 + 422 + type spi_remaining = { spi : int; remaining : int64 } 423 + 424 + let f_iv_spi = w_u16 "SPI" 425 + let f_remaining = w_u64 "Remaining" 426 + 427 + let iv_warning_codec = 428 + Wire.Codec.v "IV_Warning" 429 + (fun spi remaining -> { spi; remaining }) 430 + Wire.Codec. 431 + [ 432 + (f_iv_spi $ fun r -> r.spi); 433 + (f_remaining $ fun r -> r.remaining); 434 + ] 435 + 436 + let iv_warning_data_size = Wire.Codec.wire_size iv_warning_codec 437 + 438 + (* SPI + u8 transition codec (sa_change, key_change) *) 439 + 440 + type spi_trans = { spi : int; trans : int } 441 + 442 + let f_tr_spi = w_u16 "SPI" 443 + let f_trans = w_u8 "Transition" 444 + 445 + let spi_trans_codec = 446 + Wire.Codec.v "SPI_Trans" 447 + (fun spi trans -> { spi; trans }) 448 + Wire.Codec. 449 + [ 450 + (f_tr_spi $ fun r -> r.spi); 451 + (f_trans $ fun r -> r.trans); 452 + ] 453 + 454 + let spi_trans_data_size = Wire.Codec.wire_size spi_trans_codec 455 + 456 + (* Self-test event: success(1) = 1 byte *) 457 + 458 + let f_success = Wire.Field.v "Success" Wire.uint8 459 + 460 + let success_codec = 461 + Wire.Codec.v "Success" 462 + (fun v -> v = 0) 463 + Wire.Codec.[ (f_success $ fun s -> if s then 0 else 1) ] 351 464 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. *) 465 + (** Encode a TLV header and return a buffer with header + data_len spare room. *) 466 + let encode_tlv tag data_len = 467 + let buf = Bytes.create (tlv_header_size + data_len) in 468 + Wire.Codec.encode tlv_header_codec { tag; data_len } buf 0; 469 + buf 355 470 356 471 (** Encode a frame-direction event (shared logic for protected/unprotected). *) 357 472 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 -> ()); 473 + let code = int_of_direction direction in 474 + let payload = encode_spi_code_vcid ~spi ~code ~vcid in 475 + let data_len = Bytes.length payload in 476 + let buf = encode_tlv tag data_len in 477 + Bytes.blit payload 0 buf tlv_header_size data_len; 369 478 buf 370 479 371 480 let encode_event_data = function 372 481 | 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 -> ()); 482 + let code = int_of_auth_reason reason in 483 + let payload = encode_spi_code_vcid ~spi ~code ~vcid in 484 + let data_len = Bytes.length payload in 485 + let buf = encode_tlv tag_auth_failure data_len in 486 + Bytes.blit payload 0 buf tlv_header_size data_len; 384 487 buf 385 488 | Frame_protected { spi; direction; vcid } -> 386 489 encode_frame_dir_event tag_frame_protected ~spi ~direction ~vcid 387 490 | Frame_unprotected { spi; direction; vcid } -> 388 491 encode_frame_dir_event tag_frame_unprotected ~spi ~direction ~vcid 389 492 | 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; 493 + let buf = encode_tlv tag_iv_warning iv_warning_data_size in 494 + Wire.Codec.encode iv_warning_codec { spi; remaining } buf tlv_header_size; 395 495 buf 396 496 | 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); 497 + let buf = encode_tlv tag_sa_change spi_trans_data_size in 498 + Wire.Codec.encode spi_trans_codec 499 + { spi; trans = int_of_sa_trans transition } buf tlv_header_size; 402 500 buf 403 501 | 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; 502 + let buf = encode_tlv tag_key_change spi_trans_data_size in 503 + Wire.Codec.encode spi_trans_codec 504 + { spi = kid; trans = int_of_key_trans transition } buf tlv_header_size; 414 505 buf 506 + | Alarm_reset -> encode_tlv tag_alarm_reset 0 415 507 | 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); 508 + let buf = encode_tlv tag_self_test 1 in 509 + Wire.Codec.encode success_codec success buf tlv_header_size; 420 510 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 511 + | Log_erased -> encode_tlv tag_log_erased 0 426 512 427 513 type event_error = [ `Truncated | `Invalid_tag of int | `Invalid_vcid of int ] 428 514 ··· 435 521 number of bytes consumed. *) 436 522 let decode_event_data buf off = 437 523 let remaining = Bytes.length buf - off in 438 - if remaining < 3 then Error `Truncated 524 + if remaining < tlv_header_size then Error `Truncated 439 525 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 526 + match Wire.Codec.decode tlv_header_codec buf off with 527 + | Error _ -> Error `Truncated 528 + | Ok { tag; data_len } -> 529 + if remaining < tlv_header_size + data_len then Error `Truncated 443 530 else 444 - let data_off = off + 3 in 445 - let consumed = 3 + data_len in 531 + let data_off = off + tlv_header_size in 532 + let consumed = tlv_header_size + data_len in 446 533 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) 534 + match decode_spi_code_vcid buf data_off data_len with 535 + | Error _ as e -> e 536 + | Ok (spi, code, vcid) -> 537 + let direction = direction_of_int code in 538 + Ok (mk ~spi ~direction ~vcid, consumed) 458 539 in 459 540 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) 541 + | t when t = tag_auth_failure -> ( 542 + match decode_spi_code_vcid buf data_off data_len with 543 + | Error _ as e -> e 544 + | Ok (spi, code, vcid) -> 545 + let reason = auth_reason_of_int code in 546 + Ok (Auth_failure { spi; reason; vcid }, consumed)) 472 547 | t when t = tag_frame_protected -> 473 548 decode_frame_dir_event (fun ~spi ~direction ~vcid -> 474 549 Frame_protected { spi; direction; vcid }) ··· 476 551 decode_frame_dir_event (fun ~spi ~direction ~vcid -> 477 552 Frame_unprotected { spi; direction; vcid }) 478 553 | 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) 554 + if data_len < iv_warning_data_size then Error `Truncated 555 + else ( 556 + match Wire.Codec.decode iv_warning_codec buf data_off with 557 + | Error _ -> Error `Truncated 558 + | Ok r -> Ok (Iv_warning { spi = r.spi; remaining = r.remaining }, 559 + consumed)) 484 560 | 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) 561 + if data_len < spi_trans_data_size then Error `Truncated 562 + else ( 563 + match Wire.Codec.decode spi_trans_codec buf data_off with 564 + | Error _ -> Error `Truncated 565 + | Ok r -> 566 + let transition = sa_trans_of_int r.trans in 567 + Ok (Sa_change { spi = r.spi; transition }, consumed)) 490 568 | 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) 569 + if data_len < spi_trans_data_size then Error `Truncated 570 + else ( 571 + match Wire.Codec.decode spi_trans_codec buf data_off with 572 + | Error _ -> Error `Truncated 573 + | Ok r -> 574 + let transition = key_trans_of_int r.trans in 575 + Ok (Key_change { kid = r.spi; transition }, consumed)) 496 576 | t when t = tag_alarm_reset -> Ok (Alarm_reset, consumed) 497 577 | 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) 578 + if data_len >= 1 then 579 + match Wire.Codec.decode success_codec buf data_off with 580 + | Error _ -> Ok (Self_test { success = true }, consumed) 581 + | Ok success -> Ok (Self_test { success }, consumed) 582 + else Ok (Self_test { success = true }, consumed) 500 583 | t when t = tag_log_erased -> Ok (Log_erased, consumed) 501 584 | t -> Error (`Invalid_tag t) 502 585

+54 -5

lib/sdls.ml

··· 78 78 79 79 let sec_hdr_len (sa : Sa.entry) = 2 + sa.config.iv_len + sa.config.sn_len 80 80 81 + (* Wire codec for security header: SPI(2) + IV(iv_len) + SN(sn_len). 82 + 83 + The IV and SN sizes come from SA configuration, so we use 84 + Wire.Param.input to parameterise the codec. *) 85 + 86 + let p_iv_len = Wire.Param.input "iv_len" Wire.uint16be 87 + let p_sn_len = Wire.Param.input "sn_len" Wire.uint16be 88 + 89 + let f_spi = Wire.Field.v "SPI" Wire.uint16be 90 + let f_iv = Wire.Field.v "IV" (Wire.byte_array ~size:(Wire.Param.expr p_iv_len)) 91 + let f_sn = Wire.Field.v "SN" (Wire.byte_array ~size:(Wire.Param.expr p_sn_len)) 92 + 93 + let sec_hdr_codec = 94 + Wire.Codec.v "Security_Header" 95 + (fun spi iv sn -> 96 + Sa.{ spi; iv = Bytes.of_string iv; sn = Bytes.of_string sn }) 97 + Wire.Codec. 98 + [ 99 + (f_spi $ fun (sh : Sa.security_header) -> sh.spi); 100 + (f_iv $ fun (sh : Sa.security_header) -> Bytes.to_string sh.iv); 101 + (f_sn $ fun (sh : Sa.security_header) -> Bytes.to_string sh.sn); 102 + ] 103 + 104 + (* Wire codec for security trailer: MAC(mac_len). *) 105 + 106 + let p_mac_len = Wire.Param.input "mac_len" Wire.uint16be 107 + 108 + let f_mac = 109 + Wire.Field.v "MAC" (Wire.byte_array ~size:(Wire.Param.expr p_mac_len)) 110 + 111 + let sec_trl_codec = 112 + Wire.Codec.v "Security_Trailer" 113 + (fun mac -> Sa.{ mac = Bytes.of_string mac }) 114 + Wire.Codec. 115 + [ (f_mac $ fun (st : Sa.security_trailer) -> Bytes.to_string st.mac) ] 116 + 81 117 let write_security_header w (sh : Sa.security_header) = 82 118 Binary.Writer.uint16_be w sh.spi; 83 119 Binary.Writer.bytes w sh.iv; ··· 88 124 match Binary.Reader.ensure r need with 89 125 | Error (`Truncated _) -> Error Invalid_frame_length 90 126 | 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 } 127 + let buf = Binary.Reader.bytes r need in 128 + let env = 129 + Wire.Codec.env sec_hdr_codec 130 + |> Wire.Param.bind p_iv_len sa.config.iv_len 131 + |> Wire.Param.bind p_sn_len sa.config.sn_len 132 + in 133 + (match Wire.Codec.decode_with sec_hdr_codec env buf 0 with 134 + | Ok sh -> Ok sh 135 + | Error _ -> Error Invalid_frame_length) 95 136 96 137 let write_security_trailer w (st : Sa.security_trailer) = 97 138 Binary.Writer.bytes w st.mac ··· 99 140 let read_security_trailer ~(sa : Sa.entry) r = 100 141 match Binary.Reader.ensure r sa.config.mac_len with 101 142 | Error (`Truncated _) -> Error Invalid_frame_length 102 - | Ok () -> Ok Sa.{ mac = Binary.Reader.bytes r sa.config.mac_len } 143 + | Ok () -> 144 + let buf = Binary.Reader.bytes r sa.config.mac_len in 145 + let env = 146 + Wire.Codec.env sec_trl_codec 147 + |> Wire.Param.bind p_mac_len sa.config.mac_len 148 + in 149 + (match Wire.Codec.decode_with sec_trl_codec env buf 0 with 150 + | Ok st -> Ok st 151 + | Error _ -> Error Invalid_frame_length) 103 152 104 153 let encode_security_header (sh : Sa.security_header) = 105 154 let len = 2 + Bytes.length sh.iv + Bytes.length sh.sn in

+20

lib/sdls.mli

··· 34 34 35 35 (** {1 Security Header/Trailer} *) 36 36 37 + val sec_hdr_codec : Sa.security_header Wire.Codec.t 38 + (** Wire codec for the security header: SPI(2) + IV(iv_len) + SN(sn_len). 39 + 40 + This is a parameterised codec: bind [p_iv_len] and [p_sn_len] before 41 + decoding. *) 42 + 43 + val p_iv_len : (int, Wire.Param.input) Wire.Param.t 44 + (** Input parameter: IV length in bytes. *) 45 + 46 + val p_sn_len : (int, Wire.Param.input) Wire.Param.t 47 + (** Input parameter: sequence number length in bytes. *) 48 + 49 + val sec_trl_codec : Sa.security_trailer Wire.Codec.t 50 + (** Wire codec for the security trailer: MAC(mac_len). 51 + 52 + Bind [p_mac_len] before decoding. *) 53 + 54 + val p_mac_len : (int, Wire.Param.input) Wire.Param.t 55 + (** Input parameter: MAC length in bytes. *) 56 + 37 57 val write_security_header : Binary.Writer.t -> Sa.security_header -> unit 38 58 39 59 val read_security_header :

Configure Feed

Configure Feed