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

(** SHA-2 (SHA-256, SHA-512) — pure OCaml, WASM-safe.

    No C stubs, no external deps. Used by the fed-sx host primitives
    [crypto-sha256] / [crypto-sha512]. Reference: FIPS 180-4. *)

(* ---- SHA-256 (FIPS 180-4 §6.2). 32-bit words via Int32, NOT native int.
   On the web targets the kernel is compiled by js_of_ocaml (32-bit int) and
   wasm_of_ocaml (31-bit int), where native [int] silently truncates the 32-bit
   round words — producing WRONG digests (and, downstream, bad CIDs and a
   Char.chr crash at kernel init). Int32 has well-defined wrap-around mod 2^32 on
   every target, so this matches the 63-bit native build exactly. ---- *)

let k256 = [|
  0x428a2f98l; 0x71374491l; 0xb5c0fbcfl; 0xe9b5dba5l;
  0x3956c25bl; 0x59f111f1l; 0x923f82a4l; 0xab1c5ed5l;
  0xd807aa98l; 0x12835b01l; 0x243185bel; 0x550c7dc3l;
  0x72be5d74l; 0x80deb1fel; 0x9bdc06a7l; 0xc19bf174l;
  0xe49b69c1l; 0xefbe4786l; 0x0fc19dc6l; 0x240ca1ccl;
  0x2de92c6fl; 0x4a7484aal; 0x5cb0a9dcl; 0x76f988dal;
  0x983e5152l; 0xa831c66dl; 0xb00327c8l; 0xbf597fc7l;
  0xc6e00bf3l; 0xd5a79147l; 0x06ca6351l; 0x14292967l;
  0x27b70a85l; 0x2e1b2138l; 0x4d2c6dfcl; 0x53380d13l;
  0x650a7354l; 0x766a0abbl; 0x81c2c92el; 0x92722c85l;
  0xa2bfe8a1l; 0xa81a664bl; 0xc24b8b70l; 0xc76c51a3l;
  0xd192e819l; 0xd6990624l; 0xf40e3585l; 0x106aa070l;
  0x19a4c116l; 0x1e376c08l; 0x2748774cl; 0x34b0bcb5l;
  0x391c0cb3l; 0x4ed8aa4al; 0x5b9cca4fl; 0x682e6ff3l;
  0x748f82eel; 0x78a5636fl; 0x84c87814l; 0x8cc70208l;
  0x90befffal; 0xa4506cebl; 0xbef9a3f7l; 0xc67178f2l |]

let rotr32 (x : int32) (n : int) : int32 =
  Int32.logor (Int32.shift_right_logical x n) (Int32.shift_left x (32 - n))

let sha256_hex (msg : string) : string =
  let h = [| 0x6a09e667l; 0xbb67ae85l; 0x3c6ef372l; 0xa54ff53al;
             0x510e527fl; 0x9b05688cl; 0x1f83d9abl; 0x5be0cd19l |] in
  let len = String.length msg in
  (* Padded length: multiple of 64 bytes. *)
  let bitlen = Int64.mul (Int64.of_int len) 8L in
  let padlen =
    let r = (len + 1) mod 64 in
    if r <= 56 then 56 - r else 120 - r
  in
  let total = len + 1 + padlen + 8 in
  let buf = Bytes.make total '\000' in
  Bytes.blit_string msg 0 buf 0 len;
  Bytes.set buf len '\x80';
  (* 64-bit big-endian bit length. Int64 shifts so the high bytes (shift >= 32)
     are correct on the 32-bit web targets — native int `lsr 32` is shift-mod-32
     on js_of_ocaml and would leak the low length byte into a higher word. *)
  for i = 0 to 7 do
    Bytes.set buf (total - 1 - i)
      (Char.chr (Int64.to_int
         (Int64.logand (Int64.shift_right_logical bitlen (8 * i)) 0xFFL)))
  done;
  let byte i = Int32.of_int (Char.code (Bytes.get buf i)) in
  let w = Array.make 64 0l in
  let nblocks = total / 64 in
  for b = 0 to nblocks - 1 do
    let base = b * 64 in
    for t = 0 to 15 do
      let o = base + t * 4 in
      w.(t) <-
        Int32.logor
          (Int32.logor
             (Int32.shift_left (byte o) 24)
             (Int32.shift_left (byte (o + 1)) 16))
          (Int32.logor
             (Int32.shift_left (byte (o + 2)) 8)
             (byte (o + 3)))
    done;
    for t = 16 to 63 do
      let s0 =
        Int32.logxor
          (Int32.logxor (rotr32 w.(t - 15) 7) (rotr32 w.(t - 15) 18))
          (Int32.shift_right_logical w.(t - 15) 3) in
      let s1 =
        Int32.logxor
          (Int32.logxor (rotr32 w.(t - 2) 17) (rotr32 w.(t - 2) 19))
          (Int32.shift_right_logical w.(t - 2) 10) in
      w.(t) <-
        Int32.add (Int32.add w.(t - 16) s0) (Int32.add w.(t - 7) s1)
    done;
    let a = ref h.(0) and bb = ref h.(1) and c = ref h.(2)
    and d = ref h.(3) and e = ref h.(4) and f = ref h.(5)
    and g = ref h.(6) and hh = ref h.(7) in
    for t = 0 to 63 do
      let s1 =
        Int32.logxor
          (Int32.logxor (rotr32 !e 6) (rotr32 !e 11)) (rotr32 !e 25) in
      let ch =
        Int32.logxor (Int32.logand !e !f)
          (Int32.logand (Int32.lognot !e) !g) in
      let t1 =
        Int32.add
          (Int32.add (Int32.add !hh s1) (Int32.add ch k256.(t))) w.(t) in
      let s0 =
        Int32.logxor
          (Int32.logxor (rotr32 !a 2) (rotr32 !a 13)) (rotr32 !a 22) in
      let maj =
        Int32.logxor
          (Int32.logxor (Int32.logand !a !bb) (Int32.logand !a !c))
          (Int32.logand !bb !c) in
      let t2 = Int32.add s0 maj in
      hh := !g; g := !f; f := !e;
      e := Int32.add !d t1;
      d := !c; c := !bb; bb := !a;
      a := Int32.add t1 t2
    done;
    h.(0) <- Int32.add h.(0) !a;
    h.(1) <- Int32.add h.(1) !bb;
    h.(2) <- Int32.add h.(2) !c;
    h.(3) <- Int32.add h.(3) !d;
    h.(4) <- Int32.add h.(4) !e;
    h.(5) <- Int32.add h.(5) !f;
    h.(6) <- Int32.add h.(6) !g;
    h.(7) <- Int32.add h.(7) !hh
  done;
  let out = Buffer.create 64 in
  Array.iter (fun x -> Buffer.add_string out (Printf.sprintf "%08lx" x)) h;
  Buffer.contents out

(* ---- SHA-512 (FIPS 180-4 §6.4). 64-bit words via Int64.
   128-bit length append; we only support messages whose bit length
   fits in 64 bits (high word is always zero). ---- *)

let k512 = [|
  0x428a2f98d728ae22L; 0x7137449123ef65cdL; 0xb5c0fbcfec4d3b2fL;
  0xe9b5dba58189dbbcL; 0x3956c25bf348b538L; 0x59f111f1b605d019L;
  0x923f82a4af194f9bL; 0xab1c5ed5da6d8118L; 0xd807aa98a3030242L;
  0x12835b0145706fbeL; 0x243185be4ee4b28cL; 0x550c7dc3d5ffb4e2L;
  0x72be5d74f27b896fL; 0x80deb1fe3b1696b1L; 0x9bdc06a725c71235L;
  0xc19bf174cf692694L; 0xe49b69c19ef14ad2L; 0xefbe4786384f25e3L;
  0x0fc19dc68b8cd5b5L; 0x240ca1cc77ac9c65L; 0x2de92c6f592b0275L;
  0x4a7484aa6ea6e483L; 0x5cb0a9dcbd41fbd4L; 0x76f988da831153b5L;
  0x983e5152ee66dfabL; 0xa831c66d2db43210L; 0xb00327c898fb213fL;
  0xbf597fc7beef0ee4L; 0xc6e00bf33da88fc2L; 0xd5a79147930aa725L;
  0x06ca6351e003826fL; 0x142929670a0e6e70L; 0x27b70a8546d22ffcL;
  0x2e1b21385c26c926L; 0x4d2c6dfc5ac42aedL; 0x53380d139d95b3dfL;
  0x650a73548baf63deL; 0x766a0abb3c77b2a8L; 0x81c2c92e47edaee6L;
  0x92722c851482353bL; 0xa2bfe8a14cf10364L; 0xa81a664bbc423001L;
  0xc24b8b70d0f89791L; 0xc76c51a30654be30L; 0xd192e819d6ef5218L;
  0xd69906245565a910L; 0xf40e35855771202aL; 0x106aa07032bbd1b8L;
  0x19a4c116b8d2d0c8L; 0x1e376c085141ab53L; 0x2748774cdf8eeb99L;
  0x34b0bcb5e19b48a8L; 0x391c0cb3c5c95a63L; 0x4ed8aa4ae3418acbL;
  0x5b9cca4f7763e373L; 0x682e6ff3d6b2b8a3L; 0x748f82ee5defb2fcL;
  0x78a5636f43172f60L; 0x84c87814a1f0ab72L; 0x8cc702081a6439ecL;
  0x90befffa23631e28L; 0xa4506cebde82bde9L; 0xbef9a3f7b2c67915L;
  0xc67178f2e372532bL; 0xca273eceea26619cL; 0xd186b8c721c0c207L;
  0xeada7dd6cde0eb1eL; 0xf57d4f7fee6ed178L; 0x06f067aa72176fbaL;
  0x0a637dc5a2c898a6L; 0x113f9804bef90daeL; 0x1b710b35131c471bL;
  0x28db77f523047d84L; 0x32caab7b40c72493L; 0x3c9ebe0a15c9bebcL;
  0x431d67c49c100d4cL; 0x4cc5d4becb3e42b6L; 0x597f299cfc657e2aL;
  0x5fcb6fab3ad6faecL; 0x6c44198c4a475817L |]

let ( &: ) = Int64.logand
let ( |: ) = Int64.logor
let ( ^: ) = Int64.logxor
let ( +: ) = Int64.add
let lnot64 = Int64.lognot

let rotr64 x n =
  (Int64.shift_right_logical x n) |: (Int64.shift_left x (64 - n))

let sha512_hex (msg : string) : string =
  let h = [| 0x6a09e667f3bcc908L; 0xbb67ae8584caa73bL;
             0x3c6ef372fe94f82bL; 0xa54ff53a5f1d36f1L;
             0x510e527fade682d1L; 0x9b05688c2b3e6c1fL;
             0x1f83d9abfb41bd6bL; 0x5be0cd19137e2179L |] in
  let len = String.length msg in
  let bitlen = Int64.mul (Int64.of_int len) 8L in
  (* Pad to a multiple of 128 bytes; 16-byte big-endian length. *)
  let padlen =
    let r = (len + 1) mod 128 in
    if r <= 112 then 112 - r else 240 - r
  in
  let total = len + 1 + padlen + 16 in
  let buf = Bytes.make total '\000' in
  Bytes.blit_string msg 0 buf 0 len;
  Bytes.set buf len '\x80';
  (* Low 64 bits of the bit length (high 64 stay 0). Int64 shifts so the bytes
     at shift >= 32 are correct on the 32-bit web targets (js shift-mod-32). *)
  for i = 0 to 7 do
    Bytes.set buf (total - 1 - i)
      (Char.chr (Int64.to_int
         (Int64.logand (Int64.shift_right_logical bitlen (8 * i)) 0xFFL)))
  done;
  let w = Array.make 80 0L in
  let nblocks = total / 128 in
  for b = 0 to nblocks - 1 do
    let base = b * 128 in
    for t = 0 to 15 do
      let o = base + t * 8 in
      let v = ref 0L in
      for j = 0 to 7 do
        v := Int64.logor (Int64.shift_left !v 8)
               (Int64.of_int (Char.code (Bytes.get buf (o + j))))
      done;
      w.(t) <- !v
    done;
    for t = 16 to 79 do
      let s0 =
        (rotr64 w.(t - 15) 1) ^: (rotr64 w.(t - 15) 8)
        ^: (Int64.shift_right_logical w.(t - 15) 7) in
      let s1 =
        (rotr64 w.(t - 2) 19) ^: (rotr64 w.(t - 2) 61)
        ^: (Int64.shift_right_logical w.(t - 2) 6) in
      w.(t) <- w.(t - 16) +: s0 +: w.(t - 7) +: s1
    done;
    let a = ref h.(0) and bb = ref h.(1) and c = ref h.(2)
    and d = ref h.(3) and e = ref h.(4) and f = ref h.(5)
    and g = ref h.(6) and hh = ref h.(7) in
    for t = 0 to 79 do
      let s1 = (rotr64 !e 14) ^: (rotr64 !e 18) ^: (rotr64 !e 41) in
      let ch = (!e &: !f) ^: ((lnot64 !e) &: !g) in
      let t1 = !hh +: s1 +: ch +: k512.(t) +: w.(t) in
      let s0 = (rotr64 !a 28) ^: (rotr64 !a 34) ^: (rotr64 !a 39) in
      let maj = (!a &: !bb) ^: (!a &: !c) ^: (!bb &: !c) in
      let t2 = s0 +: maj in
      hh := !g; g := !f; f := !e;
      e := !d +: t1;
      d := !c; c := !bb; bb := !a;
      a := t1 +: t2
    done;
    h.(0) <- h.(0) +: !a;
    h.(1) <- h.(1) +: !bb;
    h.(2) <- h.(2) +: !c;
    h.(3) <- h.(3) +: !d;
    h.(4) <- h.(4) +: !e;
    h.(5) <- h.(5) +: !f;
    h.(6) <- h.(6) +: !g;
    h.(7) <- h.(7) +: !hh
  done;
  let out = Buffer.create 128 in
  Array.iter
    (fun x -> Buffer.add_string out (Printf.sprintf "%016Lx" x)) h;
  Buffer.contents out