Source file `Header.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
open Utils

type t = {
  alg : Jwa.alg;
  jwk : Jwk.public Jwk.t option;
  kid : string option;
  x5t : string option;
  x5t256 : string option;
  typ : string option;
  cty : string option;
  enc : Jwa.enc option;
  extra : (string * Yojson.Safe.t) list;
}

(* TODO: This is probably very slow *)
let remove_supported (l : (string * Yojson.Safe.t) list) =
  l |> List.remove_assoc "alg" |> List.remove_assoc "jwk"
  |> List.remove_assoc "kid" |> List.remove_assoc "x5t"
  |> List.remove_assoc "x5t#256"
  |> List.remove_assoc "typ" |> List.remove_assoc "cty"
  |> List.remove_assoc "enc"

let make_header ?typ ?alg ?enc ?(extra = []) ?(jwk_header = false)
    (jwk : Jwk.priv Jwk.t) =
  let alg =
    match alg with
    | Some alg -> alg
    | None -> (
        match jwk with
        | Jwk.Rsa_priv _ -> `RS256
        | Jwk.Oct _ -> `HS256
        | Jwk.Es256_priv _ -> `ES256
        | Jwk.Es384_priv _ -> `ES384
        | Jwk.Es512_priv _ -> `ES512
        | Jwk.Ed25519_priv _ -> `EdDSA)
  in
  let kid =
    match List.assoc_opt "kid" extra with
    | Some kid -> Some (Yojson.Safe.Util.to_string kid)
    | None -> Jwk.get_kid jwk
  in
  let extra = remove_supported extra in
  {
    alg;
    jwk = (if jwk_header then Some (Jwk.pub_of_priv jwk) else None);
    kid;
    x5t = None;
    x5t256 = None;
    typ;
    cty = None;
    enc;
    extra;
  }

module Json = Yojson.Safe.Util

let get_extra_headers (json : Yojson.Safe.t) =
  match json with
  | `Assoc vals -> (
      let extra = remove_supported vals in
      match extra with [] -> [] | extra -> extra)
  | _ -> [] (* TODO: raise here? *)

let of_json json =
  try
    Ok
      {
        alg = json |> Json.member "alg" |> Jwa.alg_of_json;
        jwk =
          json |> Json.member "jwk"
          |> Json.to_option (fun jwk_json ->
                 Jwk.of_pub_json jwk_json |> Result.to_option)
          |> Option.join;
        kid = json |> Json.member "kid" |> Json.to_string_option;
        x5t = json |> Json.member "x5t" |> Json.to_string_option;
        x5t256 = json |> Json.member "x5t#256" |> Json.to_string_option;
        typ = json |> Json.member "typ" |> Json.to_string_option;
        cty = json |> Json.member "cty" |> Json.to_string_option;
        enc =
          json |> Json.member "enc" |> Json.to_string_option
          |> Option.map Jwa.enc_of_string;
        extra = get_extra_headers json;
      }
  with Json.Type_error (s, _) -> Error (`Msg s)

let to_json t =
  let values =
    [
      RJson.to_json_string_opt "typ" t.typ;
      Some ("alg", Jwa.alg_to_json t.alg);
      RJson.to_json_string_opt "kid" t.kid;
      Option.map Jwk.to_pub_json t.jwk |> Option.map (fun jwk -> ("jwk", jwk));
      RJson.to_json_string_opt "x5t" t.x5t;
      RJson.to_json_string_opt "x5t#256" t.x5t256;
      RJson.to_json_string_opt "cty" t.cty;
      t.enc
      |> Option.map Jwa.enc_to_string
      |> Option.map (fun enc -> ("enc", `String enc));
    ]
  in
  `Assoc (List.filter_map Fun.id values @ t.extra)

let of_string header_str =
  let s = U_Base64.url_decode header_str in
  Result.bind s (fun decoded_header ->
      Yojson.Safe.from_string decoded_header |> of_json)

let to_string header =
  to_json header |> Yojson.Safe.to_string |> U_Base64.url_encode_string