Use Wire codec for all binary encoding/decoding · gazagnaire.org/ocaml-tm@f2868c7

+335 -217

lib/tm.ml

··· 48 48 49 49 (* CLCW types — delegated to Clcw library *) 50 50 type clcw_status = Clcw.status = Ready | Active | Reserved of int 51 - type clcw_flags = Clcw.flags 52 51 type clcw = Clcw.t 53 - 54 - let clcw_no_flags = Clcw.no_flags 55 52 56 53 (* TM Frame *) 57 54 type t = { ··· 79 76 | Fecf_mismatch { expected; actual } -> 80 77 Fmt.pf ppf "FECF mismatch: expected 0x%04X, got 0x%04X" expected actual 81 78 82 - (* Binary helpers *) 79 + (* Binary helpers (for OCF/FECF only -- header uses Wire codec) *) 83 80 let get_u8 s i = Char.code (String.get s i) 84 81 85 82 let get_u16_be s i = ··· 108 105 109 106 let compute_fecf = Crc.crc16_ccitt 110 107 111 - (* Header decoding *) 112 - let decode_header buf = 113 - let len = String.length buf in 114 - if len < 6 then Error (Truncated { need = 6; have = len }) 115 - else 116 - let w0 = get_u16_be buf 0 in 117 - let w1 = get_u16_be buf 2 in 118 - let w2 = get_u16_be buf 4 in 119 - let version = (w0 lsr 14) land 0x3 in 120 - if version <> 0 then Error (Invalid_version version) 121 - else 122 - let scid_val = (w0 lsr 4) land 0x3FF in 123 - let vcid_val = (w0 lsr 1) land 0x7 in 124 - let ocf_flag = w0 land 0x1 = 1 in 125 - let mcfc = (w1 lsr 8) land 0xFF in 126 - let vcfc = w1 land 0xFF in 127 - let sec_hdr = (w2 lsr 15) land 0x1 = 1 in 128 - let sync_flag = (w2 lsr 14) land 0x1 = 1 in 129 - let pkt_order = (w2 lsr 13) land 0x1 = 1 in 130 - let seg_len_id = (w2 lsr 11) land 0x3 in 131 - let first_hdr_ptr = w2 land 0x7FF in 132 - Ok 133 - { 134 - version; 135 - scid = scid_val; 136 - vcid = vcid_val; 137 - ocf_flag; 138 - mcfc; 139 - vcfc; 140 - sec_hdr; 141 - sync_flag; 142 - pkt_order; 143 - seg_len_id; 144 - first_hdr_ptr; 145 - } 146 - 147 - (* Header encoding *) 148 - let encode_header (hdr : header) = 149 - let buf = Bytes.create 6 in 150 - let w0 = 151 - hdr.version land (0x3 lsl 14) 152 - lor ((hdr.scid land 0x3FF) lsl 4) 153 - lor ((hdr.vcid land 0x7) lsl 1) 154 - lor if hdr.ocf_flag then 1 else 0 155 - in 156 - let w1 = ((hdr.mcfc land 0xFF) lsl 8) lor (hdr.vcfc land 0xFF) in 157 - let w2 = 158 - ((if hdr.sec_hdr then 1 else 0) lsl 15) 159 - lor ((if hdr.sync_flag then 1 else 0) lsl 14) 160 - lor ((if hdr.pkt_order then 1 else 0) lsl 13) 161 - lor ((hdr.seg_len_id land 0x3) lsl 11) 162 - lor (hdr.first_hdr_ptr land 0x7FF) 163 - in 164 - set_u16_be buf 0 w0; 165 - set_u16_be buf 2 w1; 166 - set_u16_be buf 4 w2; 167 - Bytes.to_string buf 168 - 169 - (* Frame decoding *) 170 - let decode ?(frame_len = 1115) ?(expect_ocf = true) ?(expect_fecf = true) 171 - ?(check_fecf = true) buf = 172 - let len = String.length buf in 173 - (* Security check: reject unreasonably large frames *) 174 - if frame_len > max_frame_len then Error (Truncated { need = 6; have = len }) 175 - else if len < 6 then Error (Truncated { need = 6; have = len }) 176 - else if len < frame_len then 177 - Error (Truncated { need = frame_len; have = len }) 178 - else 179 - match decode_header buf with 180 - | Error e -> Error e 181 - | Ok header -> 182 - let ocf_present = expect_ocf || header.ocf_flag in 183 - let trailer_len = 184 - (if ocf_present then 4 else 0) + if expect_fecf then 2 else 0 185 - in 186 - let data_len = frame_len - 6 - trailer_len in 187 - if data_len < 0 then Error (Truncated { need = frame_len; have = len }) 188 - else 189 - let data = String.sub buf 6 data_len in 190 - let ocf = 191 - if ocf_present then Some (get_u32_be buf (6 + data_len)) else None 192 - in 193 - let fecf_offset = frame_len - 2 in 194 - let fecf = 195 - if expect_fecf then Some (get_u16_be buf fecf_offset) else None 196 - in 197 - (* Validate FECF if requested *) 198 - if expect_fecf && check_fecf then 199 - let frame_data = String.sub buf 0 (frame_len - 2) in 200 - let computed = compute_fecf frame_data in 201 - let actual = Option.get fecf in 202 - if computed <> actual then 203 - Error (Fecf_mismatch { expected = computed; actual }) 204 - else Ok { header; sec_hdr_data = None; data; ocf; fecf } 205 - else Ok { header; sec_hdr_data = None; data; ocf; fecf } 206 - 207 - (* Frame encoding *) 208 - let encoded_len ?(with_ocf = true) ?(with_fecf = true) frame = 209 - 6 210 - + Option.fold ~none:0 ~some:String.length frame.sec_hdr_data 211 - + String.length frame.data 212 - + (if with_ocf then 4 else 0) 213 - + if with_fecf then 2 else 0 214 - 215 - let encode ?(with_fecf = true) frame = 216 - let with_ocf = Option.is_some frame.ocf in 217 - let total_len = encoded_len ~with_ocf ~with_fecf frame in 218 - let buf = Bytes.create total_len in 219 - let hdr_bytes = encode_header frame.header in 220 - Bytes.blit_string hdr_bytes 0 buf 0 6; 221 - let offset = ref 6 in 222 - Option.iter 223 - (fun sh -> 224 - Bytes.blit_string sh 0 buf !offset (String.length sh); 225 - offset := !offset + String.length sh) 226 - frame.sec_hdr_data; 227 - Bytes.blit_string frame.data 0 buf !offset (String.length frame.data); 228 - offset := !offset + String.length frame.data; 229 - Option.iter 230 - (fun ocf -> 231 - set_u32_be buf !offset ocf; 232 - offset := !offset + 4) 233 - frame.ocf; 234 - if with_fecf then begin 235 - let frame_data = Bytes.sub_string buf 0 !offset in 236 - let crc = compute_fecf frame_data in 237 - set_u16_be buf !offset crc 238 - end; 239 - Bytes.to_string buf 240 - 241 - (* CLCW decoding/encoding — delegated to Clcw library *) 242 - let decode_clcw word = Clcw.decode word 243 - let encode_clcw clcw = Clcw.encode clcw 108 + (* {1 Wire Field Descriptions} *) 244 109 245 - let find_clcw frame = 246 - match frame.ocf with None -> None | Some word -> Some (Clcw.decode word) 110 + let bits n = Wire.bits ~width:n Wire.U16be 111 + let bool_bit = Wire.bool (bits 1) 247 112 248 - (* Constructors *) 249 - let header ?(version = 0) ?(ocf_flag = true) ?(sec_hdr = false) 250 - ?(sync_flag = false) ?(pkt_order = false) ?(seg_len_id = 3) 251 - ?(first_hdr_ptr = 0) ~scid ~vcid ~mcfc ~vcfc () = 252 - { 253 - version; 254 - scid; 255 - vcid; 256 - ocf_flag; 257 - mcfc; 258 - vcfc; 259 - sec_hdr; 260 - sync_flag; 261 - pkt_order; 262 - seg_len_id; 263 - first_hdr_ptr; 264 - } 113 + (* Raw wire field type descriptions for the TM primary header bitfields *) 114 + let version_typ = bits 2 115 + let scid_typ = bits 10 116 + let vcid_typ = bits 3 117 + let ocf_flag_typ = bool_bit 118 + let mcfc_typ = bits 8 119 + let vcfc_typ = bits 8 120 + let sec_hdr_typ = bool_bit 121 + let sync_flag_typ = bool_bit 122 + let pkt_order_typ = bool_bit 123 + let seg_len_id_typ = bits 2 124 + let first_hdr_ptr_typ = bits 11 265 125 266 - let v ?(version = 0) ?(ocf_flag = true) ?(sec_hdr = false) ?(sync_flag = false) 267 - ?(pkt_order = false) ?(seg_len_id = 3) ?(first_hdr_ptr = 0) ?sec_hdr_data 268 - ?ocf ?fecf ~scid ~vcid ~mcfc ~vcfc data = 269 - let header = 270 - header ~version ~ocf_flag ~sec_hdr ~sync_flag ~pkt_order ~seg_len_id 271 - ~first_hdr_ptr ~scid ~vcid ~mcfc ~vcfc () 272 - in 273 - { header; sec_hdr_data; data; ocf; fecf } 274 - 275 - let clcw ?(control_word_type = 0) ?(version = 0) ?(status = Ready) 276 - ?(cop_in_effect = 1) ?(no_rf_available = false) ?(no_bit_lock = false) 277 - ?(lockout = false) ?(wait = false) ?(retransmit = false) 278 - ?(farm_b_counter = 0) ~vcid ~report_value () = 279 - Clcw.v ~control_word_type ~version ~status ~cop_in_effect 280 - ~vcid:(Clcw.vcid_exn (vcid_to_int vcid)) 281 - ~no_rf_available ~no_bit_lock ~lockout ~wait ~retransmit ~farm_b_counter 282 - ~report_value () 126 + (* {1 Packed Frame Wire Representation} 283 127 284 - (* Pretty-printing *) 285 - let pp_header ppf (hdr : header) = 286 - Fmt.pf ppf 287 - "@[<v>TM Header:@,\ 288 - \ version=%d scid=%d vcid=%d@,\ 289 - \ ocf=%b mcfc=%d vcfc=%d@,\ 290 - \ sec_hdr=%b sync=%b pkt_order=%b@,\ 291 - \ seg_len_id=%d first_hdr_ptr=0x%03X@]" 292 - hdr.version hdr.scid hdr.vcid hdr.ocf_flag hdr.mcfc hdr.vcfc hdr.sec_hdr 293 - hdr.sync_flag hdr.pkt_order hdr.seg_len_id hdr.first_hdr_ptr 128 + Defined before packed_header so that OCaml field resolution prefers 129 + packed_header (which is defined after and therefore shadows the shared 130 + field names). *) 294 131 295 - let pp_clcw_status = Clcw.pp_status 296 - let pp_clcw = Clcw.pp 132 + type packed_frame = { 133 + pf_version : int; 134 + pf_scid : int; 135 + pf_vcid : int; 136 + pf_ocf_flag : bool; 137 + pf_mcfc : int; 138 + pf_vcfc : int; 139 + pf_sec_hdr : bool; 140 + pf_sync_flag : bool; 141 + pf_pkt_order : bool; 142 + pf_seg_len_id : int; 143 + pf_first_hdr_ptr : int; 144 + data_zone : string; 145 + } 297 146 298 - let pp ppf frame = 299 - Fmt.pf ppf "@[<v>%a@,data=%d bytes@,ocf=%a@,fecf=%a@]" pp_header frame.header 300 - (String.length frame.data) 301 - (Fmt.option (fun ppf v -> Fmt.pf ppf "0x%08X" v)) 302 - frame.ocf 303 - (Fmt.option (fun ppf v -> Fmt.pf ppf "0x%04X" v)) 304 - frame.fecf 147 + let equal_packed_frame a b = 148 + a.pf_version = b.pf_version 149 + && a.pf_scid = b.pf_scid && a.pf_vcid = b.pf_vcid 150 + && a.pf_ocf_flag = b.pf_ocf_flag 151 + && a.pf_mcfc = b.pf_mcfc && a.pf_vcfc = b.pf_vcfc 152 + && a.pf_sec_hdr = b.pf_sec_hdr 153 + && a.pf_sync_flag = b.pf_sync_flag 154 + && a.pf_pkt_order = b.pf_pkt_order 155 + && a.pf_seg_len_id = b.pf_seg_len_id 156 + && a.pf_first_hdr_ptr = b.pf_first_hdr_ptr 157 + && a.data_zone = b.data_zone 305 158 306 159 (* {1 Packed Header Wire Representation} *) 307 160 ··· 327 180 && a.seg_len_id = b.seg_len_id 328 181 && a.first_hdr_ptr = b.first_hdr_ptr 329 182 330 - (* Wire Codec *) 183 + let packed_frame_of_packed_header (h : packed_header) ~data_zone : packed_frame 184 + = 185 + { 186 + pf_version = h.version; 187 + pf_scid = h.scid; 188 + pf_vcid = h.vcid; 189 + pf_ocf_flag = h.ocf_flag; 190 + pf_mcfc = h.mcfc; 191 + pf_vcfc = h.vcfc; 192 + pf_sec_hdr = h.sec_hdr; 193 + pf_sync_flag = h.sync_flag; 194 + pf_pkt_order = h.pkt_order; 195 + pf_seg_len_id = h.seg_len_id; 196 + pf_first_hdr_ptr = h.first_hdr_ptr; 197 + data_zone; 198 + } 199 + 200 + let packed_header_of_packed_frame (f : packed_frame) : packed_header = 201 + { 202 + version = f.pf_version; 203 + scid = f.pf_scid; 204 + vcid = f.pf_vcid; 205 + ocf_flag = f.pf_ocf_flag; 206 + mcfc = f.pf_mcfc; 207 + vcfc = f.pf_vcfc; 208 + sec_hdr = f.pf_sec_hdr; 209 + sync_flag = f.pf_sync_flag; 210 + pkt_order = f.pf_pkt_order; 211 + seg_len_id = f.pf_seg_len_id; 212 + first_hdr_ptr = f.pf_first_hdr_ptr; 213 + } 214 + 215 + (* {1 Header Wire Codec} *) 216 + 217 + let f_version = 218 + Wire.Codec.(Wire.Field.v "version" version_typ $ fun t -> t.version) 219 + 220 + let f_scid = Wire.Codec.(Wire.Field.v "scid" scid_typ $ fun t -> t.scid) 221 + let f_vcid = Wire.Codec.(Wire.Field.v "vcid" vcid_typ $ fun t -> t.vcid) 222 + 223 + let f_ocf_flag = 224 + Wire.Codec.(Wire.Field.v "ocf_flag" ocf_flag_typ $ fun t -> t.ocf_flag) 225 + 226 + let f_mcfc = Wire.Codec.(Wire.Field.v "mcfc" mcfc_typ $ fun t -> t.mcfc) 227 + let f_vcfc = Wire.Codec.(Wire.Field.v "vcfc" vcfc_typ $ fun t -> t.vcfc) 228 + 229 + let f_sec_hdr = 230 + Wire.Codec.(Wire.Field.v "sec_hdr" sec_hdr_typ $ fun t -> t.sec_hdr) 231 + 232 + let f_sync_flag = 233 + Wire.Codec.(Wire.Field.v "sync_flag" sync_flag_typ $ fun t -> t.sync_flag) 234 + 235 + let f_pkt_order = 236 + Wire.Codec.(Wire.Field.v "pkt_order" pkt_order_typ $ fun t -> t.pkt_order) 237 + 238 + let f_seg_len_id = 239 + Wire.Codec.(Wire.Field.v "seg_len_id" seg_len_id_typ $ fun t -> t.seg_len_id) 240 + 241 + let f_first_hdr_ptr = 242 + Wire.Codec.( 243 + Wire.Field.v "first_hdr_ptr" first_hdr_ptr_typ $ fun t -> t.first_hdr_ptr) 244 + 331 245 let codec = 332 - let bits n = Wire.bits ~width:n Wire.U16be in 333 - let bool = Wire.bool (bits 1) in 334 - let f_version = Wire.Field.v "version" (bits 2) in 335 - let f_scid = Wire.Field.v "scid" (bits 10) in 336 - let f_vcid = Wire.Field.v "vcid" (bits 3) in 337 - let f_ocf_flag = Wire.Field.v "ocf_flag" bool in 338 - let f_mcfc = Wire.Field.v "mcfc" (bits 8) in 339 - let f_vcfc = Wire.Field.v "vcfc" (bits 8) in 340 - let f_sec_hdr = Wire.Field.v "sec_hdr" bool in 341 - let f_sync_flag = Wire.Field.v "sync_flag" bool in 342 - let f_pkt_order = Wire.Field.v "pkt_order" bool in 343 - let f_seg_len_id = Wire.Field.v "seg_len_id" (bits 2) in 344 - let f_first_hdr_ptr = Wire.Field.v "first_hdr_ptr" (bits 11) in 345 246 Wire.Codec.v "TmHeader" 346 247 (fun version scid vcid ocf_flag mcfc vcfc sec_hdr sync_flag pkt_order 347 248 seg_len_id first_hdr_ptr -> ··· 360 261 }) 361 262 Wire.Codec. 362 263 [ 363 - (f_version $ fun t -> t.version); 364 - (f_scid $ fun t -> t.scid); 365 - (f_vcid $ fun t -> t.vcid); 366 - (f_ocf_flag $ fun t -> t.ocf_flag); 367 - (f_mcfc $ fun t -> t.mcfc); 368 - (f_vcfc $ fun t -> t.vcfc); 369 - (f_sec_hdr $ fun t -> t.sec_hdr); 370 - (f_sync_flag $ fun t -> t.sync_flag); 371 - (f_pkt_order $ fun t -> t.pkt_order); 372 - (f_seg_len_id $ fun t -> t.seg_len_id); 373 - (f_first_hdr_ptr $ fun t -> t.first_hdr_ptr); 264 + f_version; 265 + f_scid; 266 + f_vcid; 267 + f_ocf_flag; 268 + f_mcfc; 269 + f_vcfc; 270 + f_sec_hdr; 271 + f_sync_flag; 272 + f_pkt_order; 273 + f_seg_len_id; 274 + f_first_hdr_ptr; 374 275 ] 375 276 376 277 let struct_ = Wire.Everparse.struct_of_codec codec ··· 448 349 (* FFI Code Generation *) 449 350 let c_stubs () = Wire_stubs.to_c_stubs [ struct_ ] 450 351 let ml_stubs () = Wire_stubs.to_ml_stubs [ struct_ ] 352 + 353 + (* {1 Frame Wire Decode/Encode} 354 + 355 + The frame is decoded by composing the header Wire.Codec with direct byte 356 + reading for the data zone (all remaining bytes after the 6-byte header). 357 + This avoids the Wire.Codec limitation that does not support all_bytes 358 + in the Codec backend, while still using Wire for the header bitfields. *) 359 + 360 + let decode_packed_frame (buf : bytes) (off : int) : 361 + (packed_frame, Wire.parse_error) result = 362 + let len = Bytes.length buf - off in 363 + if len < 6 then Error (Wire.Unexpected_eof { expected = 6; got = len }) 364 + else 365 + match Wire.Codec.decode codec buf off with 366 + | Error _ as e -> e 367 + | Ok hdr -> 368 + let dz_len = len - 6 in 369 + let data_zone = Bytes.sub_string buf (off + 6) dz_len in 370 + Ok (packed_frame_of_packed_header hdr ~data_zone) 371 + 372 + let encode_packed_frame (f : packed_frame) (buf : bytes) (off : int) : unit = 373 + let hdr = packed_header_of_packed_frame f in 374 + Wire.Codec.encode codec hdr buf off; 375 + let dz = f.data_zone in 376 + Bytes.blit_string dz 0 buf (off + 6) (String.length dz) 377 + 378 + (* {1 Packed frame / header validation helpers} *) 379 + 380 + let validate_packed_header_fields (packed : packed_header) = 381 + if packed.version <> 0 then Error (Invalid_version packed.version) 382 + else 383 + match of_packed_header packed with 384 + | Error `Invalid_scid -> Error (Invalid_scid packed.scid) 385 + | Error `Invalid_vcid -> Error (Invalid_vcid packed.vcid) 386 + | Ok header -> Ok header 387 + 388 + (* Header decoding via Wire codec *) 389 + let decode_header buf = 390 + let len = String.length buf in 391 + if len < 6 then Error (Truncated { need = 6; have = len }) 392 + else 393 + let bytes_buf = Bytes.unsafe_of_string buf in 394 + match Wire.Codec.decode codec bytes_buf 0 with 395 + | Error _ -> Error (Truncated { need = 6; have = len }) 396 + | Ok packed -> validate_packed_header_fields packed 397 + 398 + (* Header encoding via Wire codec *) 399 + let encode_header (hdr : header) = 400 + let packed = to_packed_header hdr in 401 + let buf = Bytes.create wire_size in 402 + Wire.Codec.encode codec packed buf 0; 403 + Bytes.to_string buf 404 + 405 + (* {1 Data zone post-processing} 406 + 407 + The frame codec decodes header + data_zone (everything after the header). 408 + OCF and FECF are extracted from the end of the data_zone based on 409 + configuration flags. *) 410 + 411 + let split_data_zone ~data_zone ~ocf_present ~expect_fecf = 412 + let dz_len = String.length data_zone in 413 + let trailer_len = 414 + (if ocf_present then 4 else 0) + if expect_fecf then 2 else 0 415 + in 416 + let data_len = dz_len - trailer_len in 417 + if data_len < 0 then None 418 + else 419 + let data = String.sub data_zone 0 data_len in 420 + let ocf = 421 + if ocf_present then Some (get_u32_be data_zone data_len) else None 422 + in 423 + let fecf = 424 + if expect_fecf then Some (get_u16_be data_zone (dz_len - 2)) else None 425 + in 426 + Some (data, ocf, fecf) 427 + 428 + (* Frame decoding via packed frame *) 429 + let decode ?(frame_len = 1115) ?(expect_ocf = true) ?(expect_fecf = true) 430 + ?(check_fecf = true) buf = 431 + let len = String.length buf in 432 + (* Security check: reject unreasonably large frames *) 433 + if frame_len > max_frame_len then Error (Truncated { need = 6; have = len }) 434 + else if len < 6 then Error (Truncated { need = 6; have = len }) 435 + else if len < frame_len then 436 + Error (Truncated { need = frame_len; have = len }) 437 + else 438 + (* Trim the input to exactly frame_len so decode_packed_frame consumes 439 + exactly the data zone *) 440 + let frame_buf = Bytes.of_string (String.sub buf 0 frame_len) in 441 + match decode_packed_frame frame_buf 0 with 442 + | Error _ -> Error (Truncated { need = 6; have = len }) 443 + | Ok packed_f -> ( 444 + let packed_h = packed_header_of_packed_frame packed_f in 445 + match validate_packed_header_fields packed_h with 446 + | Error e -> Error e 447 + | Ok header -> ( 448 + let ocf_present = expect_ocf || header.ocf_flag in 449 + match 450 + split_data_zone ~data_zone:packed_f.data_zone ~ocf_present 451 + ~expect_fecf 452 + with 453 + | None -> Error (Truncated { need = frame_len; have = len }) 454 + | Some (data, ocf, fecf) -> 455 + (* Validate FECF if requested *) 456 + if expect_fecf && check_fecf then 457 + let frame_data = String.sub buf 0 (frame_len - 2) in 458 + let computed = compute_fecf frame_data in 459 + let actual = Option.get fecf in 460 + if computed <> actual then 461 + Error (Fecf_mismatch { expected = computed; actual }) 462 + else Ok { header; sec_hdr_data = None; data; ocf; fecf } 463 + else Ok { header; sec_hdr_data = None; data; ocf; fecf })) 464 + 465 + (* Frame encoding via packed frame *) 466 + let encoded_len ?(with_ocf = true) ?(with_fecf = true) frame = 467 + 6 468 + + Option.fold ~none:0 ~some:String.length frame.sec_hdr_data 469 + + String.length frame.data 470 + + (if with_ocf then 4 else 0) 471 + + if with_fecf then 2 else 0 472 + 473 + let encode ?(with_fecf = true) frame = 474 + let with_ocf = Option.is_some frame.ocf in 475 + let total_len = encoded_len ~with_ocf ~with_fecf frame in 476 + (* Build the data_zone: sec_hdr_data + data + ocf *) 477 + let dz_len = total_len - 6 - if with_fecf then 2 else 0 in 478 + let dz_buf = Bytes.create dz_len in 479 + let offset = ref 0 in 480 + Option.iter 481 + (fun sh -> 482 + Bytes.blit_string sh 0 dz_buf !offset (String.length sh); 483 + offset := !offset + String.length sh) 484 + frame.sec_hdr_data; 485 + Bytes.blit_string frame.data 0 dz_buf !offset (String.length frame.data); 486 + offset := !offset + String.length frame.data; 487 + Option.iter 488 + (fun ocf -> 489 + set_u32_be dz_buf !offset ocf; 490 + offset := !offset + 4) 491 + frame.ocf; 492 + let data_zone = Bytes.unsafe_to_string dz_buf in 493 + (* Encode header + data_zone via packed frame *) 494 + let packed_h = to_packed_header frame.header in 495 + let packed_f = packed_frame_of_packed_header packed_h ~data_zone in 496 + let frame_wire_len = 6 + String.length data_zone in 497 + let buf = Bytes.create total_len in 498 + encode_packed_frame packed_f buf 0; 499 + if with_fecf then begin 500 + let frame_data = Bytes.sub_string buf 0 frame_wire_len in 501 + let crc = compute_fecf frame_data in 502 + set_u16_be buf frame_wire_len crc 503 + end; 504 + Bytes.unsafe_to_string buf 505 + 506 + (* CLCW decoding/encoding — delegated to Clcw library *) 507 + let decode_clcw word = Clcw.decode word 508 + let encode_clcw clcw = Clcw.encode clcw 509 + 510 + let find_clcw frame = 511 + match frame.ocf with None -> None | Some word -> Some (Clcw.decode word) 512 + 513 + (* Constructors *) 514 + let header ?(version = 0) ?(ocf_flag = true) ?(sec_hdr = false) 515 + ?(sync_flag = false) ?(pkt_order = false) ?(seg_len_id = 3) 516 + ?(first_hdr_ptr = 0) ~scid ~vcid ~mcfc ~vcfc () : header = 517 + { 518 + version; 519 + scid; 520 + vcid; 521 + ocf_flag; 522 + mcfc; 523 + vcfc; 524 + sec_hdr; 525 + sync_flag; 526 + pkt_order; 527 + seg_len_id; 528 + first_hdr_ptr; 529 + } 530 + 531 + let v ?(version = 0) ?(ocf_flag = true) ?(sec_hdr = false) ?(sync_flag = false) 532 + ?(pkt_order = false) ?(seg_len_id = 3) ?(first_hdr_ptr = 0) ?sec_hdr_data 533 + ?ocf ?fecf ~scid ~vcid ~mcfc ~vcfc data = 534 + let header = 535 + header ~version ~ocf_flag ~sec_hdr ~sync_flag ~pkt_order ~seg_len_id 536 + ~first_hdr_ptr ~scid ~vcid ~mcfc ~vcfc () 537 + in 538 + { header; sec_hdr_data; data; ocf; fecf } 539 + 540 + let clcw ?(control_word_type = 0) ?(version = 0) ?(status = Ready) 541 + ?(cop_in_effect = 1) ?(no_rf_available = false) ?(no_bit_lock = false) 542 + ?(lockout = false) ?(wait = false) ?(retransmit = false) 543 + ?(farm_b_counter = 0) ~vcid ~report_value () = 544 + Clcw.v ~control_word_type ~version ~status ~cop_in_effect 545 + ~vcid:(vcid_to_int vcid) ~no_rf_available ~no_bit_lock ~lockout ~wait 546 + ~retransmit ~farm_b_counter ~report_value () 547 + 548 + (* Pretty-printing *) 549 + let pp_header ppf (hdr : header) = 550 + Fmt.pf ppf 551 + "@[<v>TM Header:@,\ 552 + \ version=%d scid=%d vcid=%d@,\ 553 + \ ocf=%b mcfc=%d vcfc=%d@,\ 554 + \ sec_hdr=%b sync=%b pkt_order=%b@,\ 555 + \ seg_len_id=%d first_hdr_ptr=0x%03X@]" 556 + hdr.version hdr.scid hdr.vcid hdr.ocf_flag hdr.mcfc hdr.vcfc hdr.sec_hdr 557 + hdr.sync_flag hdr.pkt_order hdr.seg_len_id hdr.first_hdr_ptr 558 + 559 + let pp_clcw_status = Clcw.pp_status 560 + let pp_clcw = Clcw.pp 561 + 562 + let pp ppf frame = 563 + Fmt.pf ppf "@[<v>%a@,data=%d bytes@,ocf=%a@,fecf=%a@]" pp_header frame.header 564 + (String.length frame.data) 565 + (Fmt.option (fun ppf v -> Fmt.pf ppf "0x%08X" v)) 566 + frame.ocf 567 + (Fmt.option (fun ppf v -> Fmt.pf ppf "0x%04X" v)) 568 + frame.fecf

+92 -11

lib/tm.mli

··· 103 103 | Active 104 104 | Reserved of int (** COP-1 status (3 bits). *) 105 105 106 - type clcw_flags = Clcw.flags 107 - (** CLCW flags. *) 108 - 109 106 type clcw = Clcw.t 110 107 (** Command Link Control Word (32 bits). *) 111 - 112 - val clcw_no_flags : clcw_flags 113 - (** All flags set to false. *) 114 108 115 109 (** {1 TM Frame} *) 116 110 ··· 277 271 278 272 val equal_packed_header : packed_header -> packed_header -> bool 279 273 280 - (** {1 Wire Codec} *) 274 + (** {1 Header Wire Codec} *) 281 275 282 276 val codec : packed_header Wire.Codec.t 283 - (** [codec] is the wire codec for [packed_header]. *) 277 + (** [codec] is the wire codec for [packed_header] (header only, 6 bytes). *) 284 278 285 279 val struct_ : Wire.Everparse.struct_ 286 - (** Wire struct descriptor. *) 280 + (** Wire struct descriptor for the header. *) 287 281 288 282 val module_ : Wire.Everparse.module_ 289 - (** Wire module descriptor. *) 283 + (** Wire module descriptor for the header. *) 284 + 285 + (** {1 Header Wire Fields} 286 + 287 + Bound field handles for zero-copy access via {!Wire.Codec.get} / 288 + {!Wire.Codec.set} and batch bitfield reads via {!Wire.Codec.bitfield}. *) 289 + 290 + val f_version : (int, packed_header) Wire.Codec.field 291 + val f_scid : (int, packed_header) Wire.Codec.field 292 + val f_vcid : (int, packed_header) Wire.Codec.field 293 + val f_ocf_flag : (bool, packed_header) Wire.Codec.field 294 + val f_mcfc : (int, packed_header) Wire.Codec.field 295 + val f_vcfc : (int, packed_header) Wire.Codec.field 296 + val f_sec_hdr : (bool, packed_header) Wire.Codec.field 297 + val f_sync_flag : (bool, packed_header) Wire.Codec.field 298 + val f_pkt_order : (bool, packed_header) Wire.Codec.field 299 + val f_seg_len_id : (int, packed_header) Wire.Codec.field 300 + val f_first_hdr_ptr : (int, packed_header) Wire.Codec.field 290 301 291 - (** {1 Wire Parse/Encode} *) 302 + (** {1 Header Wire Parse/Encode} *) 292 303 293 304 val wire_size : int 294 305 (** Wire size of a packed header in bytes. *) ··· 312 323 313 324 val encode_bytes : packed_header -> bytes 314 325 (** [encode_bytes h] encodes [h] as bytes. *) 326 + 327 + (** {1 Packed Frame Wire Representation} *) 328 + 329 + type packed_frame = { 330 + pf_version : int; (** Transfer frame version (2 bits). *) 331 + pf_scid : int; (** Spacecraft ID (10 bits). *) 332 + pf_vcid : int; (** Virtual channel ID (3 bits). *) 333 + pf_ocf_flag : bool; (** OCF present flag. *) 334 + pf_mcfc : int; (** Master channel frame count (8 bits). *) 335 + pf_vcfc : int; (** Virtual channel frame count (8 bits). *) 336 + pf_sec_hdr : bool; (** Secondary header present flag. *) 337 + pf_sync_flag : bool; (** Synchronization flag. *) 338 + pf_pkt_order : bool; (** Packet order flag. *) 339 + pf_seg_len_id : int; (** Segment length identifier (2 bits). *) 340 + pf_first_hdr_ptr : int; (** First header pointer (11 bits). *) 341 + data_zone : string; 342 + (** Data zone: everything after the 6-byte header. Contains the data 343 + field, optional OCF (4 bytes), and optional FECF (2 bytes). Use 344 + {!split_data_zone} or the high-level {!decode} to extract individual 345 + components. *) 346 + } 347 + (** Full TM transfer frame: primary header (6 bytes) + data zone (variable). 348 + 349 + The data zone is everything after the primary header up to the end of the 350 + frame. OCF and FECF, if present, are at the end of the data zone and can be 351 + extracted as post-processing based on mission configuration. *) 352 + 353 + val equal_packed_frame : packed_frame -> packed_frame -> bool 354 + 355 + val packed_frame_of_packed_header : 356 + packed_header -> data_zone:string -> packed_frame 357 + (** [packed_frame_of_packed_header h ~data_zone] combines a packed header with a 358 + data zone to form a packed frame. *) 359 + 360 + val packed_header_of_packed_frame : packed_frame -> packed_header 361 + (** [packed_header_of_packed_frame f] extracts the header fields from a packed 362 + frame. *) 363 + 364 + (** {1 Frame Wire Decode/Encode} 365 + 366 + The frame is decoded by composing the header {!Wire.Codec} with direct byte 367 + reading for the data zone (all remaining bytes after the 6-byte header). The 368 + header bitfield parsing goes through the Wire codec; the data zone is the 369 + remaining bytes in the buffer. 370 + 371 + Note: EverParse 3D generation is only supported for the header-only codec 372 + ({!struct_}, {!module_}). The full frame includes variable-size data that 373 + cannot be expressed in the Wire.Codec backend. *) 374 + 375 + val decode_packed_frame : 376 + bytes -> int -> (packed_frame, Wire.parse_error) result 377 + (** [decode_packed_frame buf off] decodes a full frame from [buf] at offset 378 + [off]. The data zone consumes all bytes from offset [off + 6] to the end of 379 + [buf]. *) 380 + 381 + val encode_packed_frame : packed_frame -> bytes -> int -> unit 382 + (** [encode_packed_frame f buf off] encodes [f] into [buf] at offset [off]. The 383 + buffer must be large enough to hold the header (6 bytes) plus the data zone. 384 + *) 385 + 386 + (** {1 Data Zone Post-processing} *) 387 + 388 + val split_data_zone : 389 + data_zone:string -> 390 + ocf_present:bool -> 391 + expect_fecf:bool -> 392 + (string * int option * int option) option 393 + (** [split_data_zone ~data_zone ~ocf_present ~expect_fecf] splits the data zone 394 + into [(data, ocf, fecf)]. Returns [None] if the data zone is too short for 395 + the expected trailer fields. *) 315 396 316 397 (** {1 FFI Code Generation} *) 317 398

+118

test/test_tm.ml

··· 208 208 | Error e -> Alcotest.failf "decode vcfc=0 failed: %a" Tm.pp_error e 209 209 | Ok decoded -> Alcotest.(check int) "vcfc=0" 0 decoded.header.vcfc 210 210 211 + (* Test: Packed frame roundtrip *) 212 + let packed_frame_testable = 213 + Alcotest.testable 214 + (fun ppf (f : Tm.packed_frame) -> 215 + Format.fprintf ppf 216 + "{ver=%d scid=%d vcid=%d ocf=%b mcfc=%d vcfc=%d sec=%b sync=%b pkt=%b \ 217 + seg=%d fhp=%d dz=%d}" 218 + f.pf_version f.pf_scid f.pf_vcid f.pf_ocf_flag f.pf_mcfc f.pf_vcfc 219 + f.pf_sec_hdr f.pf_sync_flag f.pf_pkt_order f.pf_seg_len_id 220 + f.pf_first_hdr_ptr 221 + (String.length f.data_zone)) 222 + Tm.equal_packed_frame 223 + 224 + let test_packed_frame_roundtrip () = 225 + let packed_hdr : Tm.packed_header = 226 + { 227 + version = 0; 228 + scid = 100; 229 + vcid = 2; 230 + ocf_flag = true; 231 + mcfc = 1; 232 + vcfc = 2; 233 + sec_hdr = false; 234 + sync_flag = false; 235 + pkt_order = false; 236 + seg_len_id = 3; 237 + first_hdr_ptr = 0; 238 + } 239 + in 240 + let data_zone = String.make 20 '\xAB' in 241 + let packed_f = Tm.packed_frame_of_packed_header packed_hdr ~data_zone in 242 + let total_len = 6 + String.length data_zone in 243 + let buf = Bytes.create total_len in 244 + Tm.encode_packed_frame packed_f buf 0; 245 + match Tm.decode_packed_frame buf 0 with 246 + | Error e -> Alcotest.failf "decode failed: %a" Wire.pp_parse_error e 247 + | Ok decoded -> 248 + Alcotest.check packed_frame_testable "packed frame roundtrip" packed_f 249 + decoded 250 + 251 + (* Test: Packed frame header extraction *) 252 + let test_packed_frame_header_extraction () = 253 + let packed_hdr : Tm.packed_header = 254 + { 255 + version = 0; 256 + scid = 42; 257 + vcid = 3; 258 + ocf_flag = false; 259 + mcfc = 99; 260 + vcfc = 200; 261 + sec_hdr = true; 262 + sync_flag = true; 263 + pkt_order = false; 264 + seg_len_id = 1; 265 + first_hdr_ptr = 0x7FF; 266 + } 267 + in 268 + let data_zone = "hello" in 269 + let packed_f = Tm.packed_frame_of_packed_header packed_hdr ~data_zone in 270 + let extracted_hdr = Tm.packed_header_of_packed_frame packed_f in 271 + Alcotest.check packed_header_testable "header extraction" packed_hdr 272 + extracted_hdr 273 + 274 + (* Test: Packed frame data zone *) 275 + let test_packed_frame_data_zone () = 276 + (* Encode a full TM frame and decode it as a packed_frame *) 277 + let scid = Tm.scid_exn 100 in 278 + let vcid = Tm.vcid_exn 2 in 279 + let data = String.make 1103 '\x55' in 280 + let frame = Tm.v ~scid ~vcid ~mcfc:1 ~vcfc:2 ~ocf:0x12345678 data in 281 + let encoded = Tm.encode frame in 282 + (* Decode as packed_frame: the data_zone should contain data + ocf + fecf *) 283 + let buf = Bytes.of_string encoded in 284 + match Tm.decode_packed_frame buf 0 with 285 + | Error e -> Alcotest.failf "decode failed: %a" Wire.pp_parse_error e 286 + | Ok packed_f -> ( 287 + (* data_zone = frame_len - 6 (header) = 1115 - 6 = 1109 bytes *) 288 + Alcotest.(check int) 289 + "data_zone length" 1109 290 + (String.length packed_f.data_zone); 291 + (* Split the data zone and verify *) 292 + match 293 + Tm.split_data_zone ~data_zone:packed_f.data_zone ~ocf_present:true 294 + ~expect_fecf:true 295 + with 296 + | None -> Alcotest.fail "split_data_zone returned None" 297 + | Some (d, ocf, fecf) -> 298 + Alcotest.(check int) "data length" 1103 (String.length d); 299 + Alcotest.(check (option int)) "ocf" (Some 0x12345678) ocf; 300 + Alcotest.(check bool) "fecf present" true (Option.is_some fecf)) 301 + 302 + (* Test: split_data_zone with no OCF/FECF *) 303 + let test_split_data_zone_no_trailer () = 304 + let data_zone = "just data" in 305 + match Tm.split_data_zone ~data_zone ~ocf_present:false ~expect_fecf:false with 306 + | None -> Alcotest.fail "split_data_zone returned None" 307 + | Some (d, ocf, fecf) -> 308 + Alcotest.(check string) "data is full zone" "just data" d; 309 + Alcotest.(check (option int)) "no ocf" None ocf; 310 + Alcotest.(check (option int)) "no fecf" None fecf 311 + 312 + (* Test: split_data_zone too short *) 313 + let test_split_data_zone_too_short () = 314 + let data_zone = "\x00\x01" in 315 + match Tm.split_data_zone ~data_zone ~ocf_present:true ~expect_fecf:true with 316 + | None -> () (* Expected: 2 bytes < 4 (ocf) + 2 (fecf) *) 317 + | Some _ -> Alcotest.fail "should have returned None for short data_zone" 318 + 211 319 let suite = 212 320 ( "tm", 213 321 [ ··· 227 335 Alcotest.test_case "wire_vs_manual" `Quick test_wire_vs_manual; 228 336 Alcotest.test_case "mcfc_wraparound" `Quick test_mcfc_wraparound; 229 337 Alcotest.test_case "vcfc_wraparound" `Quick test_vcfc_wraparound; 338 + Alcotest.test_case "packed_frame_roundtrip" `Quick 339 + test_packed_frame_roundtrip; 340 + Alcotest.test_case "packed_frame_header_extraction" `Quick 341 + test_packed_frame_header_extraction; 342 + Alcotest.test_case "packed_frame_data_zone" `Quick 343 + test_packed_frame_data_zone; 344 + Alcotest.test_case "split_data_zone_no_trailer" `Quick 345 + test_split_data_zone_no_trailer; 346 + Alcotest.test_case "split_data_zone_too_short" `Quick 347 + test_split_data_zone_too_short; 230 348 ] )

Configure Feed

Configure Feed