mte/src/util.ml

exception Bin_error of string

(* TODO bin
   - no [Bin.of_string] ? *)
let bin_of_string bin s =
  let v = Bin.decode bin s (ref 0) in
  Ok v

module Bin_rsa = struct
  (* TODO
     - need to strip leading zeros?
     - endianess ok?
     - tests *)
  (* RSA public key binary format
       https://www.gnupg.org/documentation/manuals/gcrypt/MPI-formats.html
       := { uint16_be: n size; uint16_be: e size; n; e}

    integer in big-endian format (MSB first)
    leading zeroes are stripped unless they are required to keep a value positive
    no 0-termination *)
  (* RSA private key custom format is inspired by the public rsa key format
     used by secmod to save private key to file *)
  open Syntax

  module Internal = struct
    let rev_string len s = String.init len (fun i -> s.[len - 1 - i])

    (* we need reverse bytes because Z.of_bits reads bytes in little endian *)
    let z_of_bits_be src pos len =
      String.sub src pos len |> rev_string len |> Z.of_bits

    let z_to_bits_be z =
      let bits = Z.to_bits z in
      rev_string (String.length bits) bits

    let z_array_to_octets (arr : Z.t array) =
      let nb = Array.length arr in
      let bits_arr = Array.map z_to_bits_be arr in
      let len_arr = Array.map String.length bits_arr in
      let len = (2 * nb) + Array.fold_left ( + ) 0 len_arr in
      let b = Bytes.make len '\x00' in
      let pos = ref 0 in
      Array.iter
        (fun len ->
          Bytes.set_uint16_be b !pos len;
          pos := !pos + 2)
        len_arr;
      Array.iteri
        (fun i bits ->
          let len = len_arr.(i) in
          Bytes.blit_string bits 0 b !pos len;
          pos := !pos + len)
        bits_arr;
      Bytes.unsafe_to_string b

    let check = function
      | false -> Error "rsa of_octets error, invalid data"
      | true -> Ok ()

    let z_array_of_octets ~nb s =
      let s_len = String.length s in
      let* () = check (s_len > 2 * nb) in
      let pos = ref 0 in
      let len_arr =
        Array.init nb (fun _i ->
            let len = String.get_uint16_be s !pos in
            pos := !pos + 2;
            len)
      in
      let* () =
        let len = (2 * nb) + Array.fold_left ( + ) 0 len_arr in
        check (s_len = len)
      in
      let z_arr =
        Array.init nb (fun i ->
            let len = len_arr.(i) in
            let z = z_of_bits_be s !pos len in
            pos := !pos + len;
            z)
      in
      Ok z_arr
  end

  open Internal

  let pub_to_octets ({ n; e } : Mirage_crypto_pk.Rsa.pub) =
    z_array_to_octets [| n; e |]

  let pub_of_octets s =
    let* arr = z_array_of_octets ~nb:2 s in
    match arr with
    | [| n; e |] ->
        let+ pub = Mirage_crypto_pk.Rsa.pub ~n ~e |> unwrap_err_msg in
        pub
    | _ -> assert false

  let priv_to_octets ({ e; d; n; p; q; dp; dq; q' } : Mirage_crypto_pk.Rsa.priv)
      =
    z_array_to_octets [| e; d; n; p; q; dp; dq; q' |]

  let priv_of_octets s =
    let* arr = z_array_of_octets ~nb:8 s in
    match arr with
    | [| e; d; n; p; q; dp; dq; q' |] ->
        let+ priv =
          Mirage_crypto_pk.Rsa.priv ~e ~d ~n ~p ~q ~dp ~dq ~q' |> unwrap_err_msg
        in
        priv
    | _ -> assert false
end

module Log_reporter = struct
  let detail_tag : string Logs.Tag.def =
    Logs.Tag.def "Detail tag" ~doc:"" Fmt.string

  let detail s = Logs.Tag.(empty |> add detail_tag s)
  let time_anchor = Ptime_clock.now () |> Ptime.to_span

  let color_of_log_level = function
    | Logs.App -> `White
    | Error -> `Red
    | Warning -> `Yellow
    | Info -> `Blue
    | Debug -> `Magenta

  let reporter : Logs.reporter =
    let open Fmt in
    let pp_timestamp = styled `Faint (styled (`Fg `White) (fmt "%04.02f")) in
    let pp_header ppf v =
      let color = color_of_log_level (fst v) in
      let pp = styled (`Fg color) Logs.pp_header in
      pf ppf "%a" pp v
    in
    let pp_src_name =
      let pp = using Logs.Src.name (styled `Cyan (fmt "%s: ")) in
      fun ppf v -> if not @@ Logs.Src.equal Logs.default v then pp ppf v
    in
    let pp_detail = option (styled `Green (fmt " (%s)")) in
    let report src lvl ~over k msgf =
      let ppf =
        match lvl with
        | Logs.App -> stdout
        | Error | Warning | Info | Debug -> stderr
      in
      let k _ppf = over (); k () in
      let with_detail h tags k user_fmt =
        let detail = Option.bind tags (Logs.Tag.find detail_tag) in
        let timestamp =
          Ptime.sub_span (Ptime_clock.now ()) time_anchor
          |> Option.map Ptime.to_float_s
          |> Option.value ~default:0.
        in
        let k ppf = kpf k ppf "%a@." pp_detail detail in
        let k ppf = kpf k ppf user_fmt in
        kpf k ppf "%a %a %a" pp_timestamp timestamp pp_header (lvl, h)
          pp_src_name src
      in
      msgf @@ fun ?header ?tags fmt -> with_detail header tags k fmt
    in
    { report }

  (* TODO logs
     - vif shouldn't use/set the default reporter
     - Log.err all `Internal_server_error response *)
  let setup () =
    let level = Some Logs.Info in
    Logs.set_level ~all:false level;
    Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ();
    Logs.Src.set_level Logs.default level;
    Logs_threaded.enable ();
    Logs.set_reporter reporter;
    ()
end