rose-ash/hosts/ocaml/lib/sx_cbor.ml

(** dag-cbor encode / decode — pure OCaml, WASM-safe.

    RFC 8949 deterministic subset as constrained by IPLD dag-cbor
    (RFC 8742): unsigned/negative ints, text strings, arrays, maps
    with keys sorted by **length-then-bytewise**, bool, null, and
    tag 42 (CID link, decode-side passthrough). Floats are not
    supported (no fed-sx shape needs them yet) — encoding a [Number]
    or decoding a float head raises. Reference: RFC 8949 §3, §4.2. *)

open Sx_types

exception Cbor_error of string

(* ---- Encoder ---- *)

let write_head buf major v =
  let m = major lsl 5 in
  if v < 24 then
    Buffer.add_char buf (Char.chr (m lor v))
  else if v < 0x100 then begin
    Buffer.add_char buf (Char.chr (m lor 24));
    Buffer.add_char buf (Char.chr v)
  end else if v < 0x10000 then begin
    Buffer.add_char buf (Char.chr (m lor 25));
    Buffer.add_char buf (Char.chr ((v lsr 8) land 0xFF));
    Buffer.add_char buf (Char.chr (v land 0xFF))
  end else if v < 0x100000000 then begin
    Buffer.add_char buf (Char.chr (m lor 26));
    for i = 3 downto 0 do
      Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF))
    done
  end else begin
    Buffer.add_char buf (Char.chr (m lor 27));
    for i = 7 downto 0 do
      Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF))
    done
  end

(* dag-cbor map key order: shorter key first, then bytewise. *)
let key_order a b =
  let la = String.length a and lb = String.length b in
  if la <> lb then compare la lb else compare a b

let rec encode_into buf (v : value) : unit =
  match v with
  | Integer n ->
    if n >= 0 then write_head buf 0 n
    else write_head buf 1 (-1 - n)
  | String s ->
    write_head buf 3 (String.length s);
    Buffer.add_string buf s
  | Symbol s | Keyword s ->
    write_head buf 3 (String.length s);
    Buffer.add_string buf s
  | Bool false -> Buffer.add_char buf '\xf4'
  | Bool true  -> Buffer.add_char buf '\xf5'
  | Nil        -> Buffer.add_char buf '\xf6'
  | List items ->
    write_head buf 4 (List.length items);
    List.iter (encode_into buf) items
  | Dict d ->
    let keys = Hashtbl.fold (fun k _ acc -> k :: acc) d [] in
    let keys = List.sort_uniq key_order keys in
    write_head buf 5 (List.length keys);
    List.iter (fun k ->
      write_head buf 3 (String.length k);
      Buffer.add_string buf k;
      encode_into buf (Hashtbl.find d k)) keys
  | Number _ ->
    raise (Cbor_error "cbor-encode: floats unsupported (dag-cbor subset)")
  | _ ->
    raise (Cbor_error
             ("cbor-encode: unencodable value " ^ type_of v))

let encode (v : value) : string =
  let buf = Buffer.create 64 in
  encode_into buf v;
  Buffer.contents buf

(* ---- Decoder ---- *)

let decode (s : string) : value =
  let pos = ref 0 in
  let len = String.length s in
  let byte () =
    if !pos >= len then raise (Cbor_error "cbor-decode: truncated");
    let c = Char.code s.[!pos] in incr pos; c
  in
  let read_uint ai =
    if ai < 24 then ai
    else if ai = 24 then byte ()
    else if ai = 25 then let a = byte () in let b = byte () in (a lsl 8) lor b
    else if ai = 26 then begin
      let v = ref 0 in
      for _ = 0 to 3 do v := (!v lsl 8) lor byte () done; !v
    end else if ai = 27 then begin
      let v = ref 0 in
      for _ = 0 to 7 do v := (!v lsl 8) lor byte () done; !v
    end else raise (Cbor_error "cbor-decode: bad additional info")
  in
  let read_bytes n =
    if !pos + n > len then raise (Cbor_error "cbor-decode: truncated");
    let r = String.sub s !pos n in pos := !pos + n; r
  in
  let rec item () =
    let b = byte () in
    let major = b lsr 5 and ai = b land 0x1f in
    match major with
    | 0 -> Integer (read_uint ai)
    | 1 -> Integer (-1 - read_uint ai)
    | 2 -> String (read_bytes (read_uint ai))
    | 3 -> String (read_bytes (read_uint ai))
    | 4 ->
      let n = read_uint ai in
      List (List.init n (fun _ -> item ()))
    | 5 ->
      let n = read_uint ai in
      let d = make_dict () in
      for _ = 1 to n do
        let k = match item () with
          | String k -> k
          | _ -> raise (Cbor_error "cbor-decode: non-string map key")
        in
        Hashtbl.replace d k (item ())
      done;
      Dict d
    | 6 ->
      (* Tag: tag-42 CID link → pass the inner item through. *)
      ignore (read_uint ai); item ()
    | 7 ->
      (match ai with
       | 20 -> Bool false
       | 21 -> Bool true
       | 22 -> Nil
       | 23 -> Nil
       | _ ->
         raise (Cbor_error
                  "cbor-decode: floats/simple unsupported (dag-cbor subset)"))
    | _ -> raise (Cbor_error "cbor-decode: bad major type")
  in
  let v = item () in
  v