JSON web tokens in OCaml
1(** JSON Web Token (JWT) - RFC 7519 *)
2
3(* Error types *)
4type error =
5 | Invalid_json of string
6 | Invalid_base64url of string
7 | Invalid_structure of string
8 | Invalid_header of string
9 | Invalid_claims of string
10 | Invalid_uri of string
11 | Duplicate_claim of string
12 | Unsupported_algorithm of string
13 | Algorithm_not_allowed of string
14 | Signature_mismatch
15 | Token_expired
16 | Token_not_yet_valid
17 | Invalid_issuer
18 | Invalid_audience
19 | Key_type_mismatch of string
20 | Unsecured_not_allowed
21 | Nesting_too_deep
22
23let pp_error fmt = function
24 | Invalid_json s -> Format.fprintf fmt "Invalid JSON: %s" s
25 | Invalid_base64url s -> Format.fprintf fmt "Invalid base64url: %s" s
26 | Invalid_structure s -> Format.fprintf fmt "Invalid structure: %s" s
27 | Invalid_header s -> Format.fprintf fmt "Invalid header: %s" s
28 | Invalid_claims s -> Format.fprintf fmt "Invalid claims: %s" s
29 | Invalid_uri s -> Format.fprintf fmt "Invalid URI: %s" s
30 | Duplicate_claim s -> Format.fprintf fmt "Duplicate claim: %s" s
31 | Unsupported_algorithm s -> Format.fprintf fmt "Unsupported algorithm: %s" s
32 | Algorithm_not_allowed s -> Format.fprintf fmt "Algorithm not allowed: %s" s
33 | Signature_mismatch -> Format.fprintf fmt "Signature mismatch"
34 | Token_expired -> Format.fprintf fmt "Token expired"
35 | Token_not_yet_valid -> Format.fprintf fmt "Token not yet valid"
36 | Invalid_issuer -> Format.fprintf fmt "Invalid issuer"
37 | Invalid_audience -> Format.fprintf fmt "Invalid audience"
38 | Key_type_mismatch s -> Format.fprintf fmt "Key type mismatch: %s" s
39 | Unsecured_not_allowed -> Format.fprintf fmt "Unsecured JWT not allowed"
40 | Nesting_too_deep -> Format.fprintf fmt "Nested JWT too deep"
41
42let error_to_string e = Format.asprintf "%a" pp_error e
43
44(* Base64url encoding/decoding per RFC 7515 Appendix C *)
45let base64url_encode s =
46 Base64.encode_string ~pad:false ~alphabet:Base64.uri_safe_alphabet s
47
48let base64url_decode s =
49 (* Add padding if needed *)
50 let len = String.length s in
51 let pad_len = (4 - (len mod 4)) mod 4 in
52 let padded = s ^ String.make pad_len '=' in
53 match Base64.decode ~alphabet:Base64.uri_safe_alphabet padded with
54 | Ok v -> Ok v
55 | Error (`Msg m) -> Error (Invalid_base64url m)
56
57(* StringOrURI validation per RFC 7519 Section 2 *)
58let validate_string_or_uri s =
59 if String.contains s ':' then
60 (* Must be a valid URI - basic check for scheme *)
61 match String.index_opt s ':' with
62 | Some i when i > 0 ->
63 let scheme = String.sub s 0 i in
64 (* Check scheme is alphanumeric with +.- allowed after first char *)
65 let valid_scheme =
66 String.length scheme > 0
67 && (match scheme.[0] with
68 | 'a' .. 'z' | 'A' .. 'Z' -> true
69 | _ -> false)
70 && String.for_all
71 (fun c ->
72 match c with
73 | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '+' | '-' | '.' ->
74 true
75 | _ -> false)
76 scheme
77 in
78 if valid_scheme then Ok s
79 else Error (Invalid_uri (Printf.sprintf "Invalid URI scheme in: %s" s))
80 | _ -> Error (Invalid_uri (Printf.sprintf "Invalid URI: %s" s))
81 else Ok s
82
83(* Algorithm module *)
84module Algorithm = struct
85 type t =
86 | None
87 | HS256
88 | HS384
89 | HS512
90 | RS256
91 | RS384
92 | RS512
93 | ES256
94 | ES384
95 | ES512
96 | EdDSA
97
98 let to_string = function
99 | None -> "none"
100 | HS256 -> "HS256"
101 | HS384 -> "HS384"
102 | HS512 -> "HS512"
103 | RS256 -> "RS256"
104 | RS384 -> "RS384"
105 | RS512 -> "RS512"
106 | ES256 -> "ES256"
107 | ES384 -> "ES384"
108 | ES512 -> "ES512"
109 | EdDSA -> "EdDSA"
110
111 let of_string = function
112 | "none" -> Ok None
113 | "HS256" -> Ok HS256
114 | "HS384" -> Ok HS384
115 | "HS512" -> Ok HS512
116 | "RS256" -> Ok RS256
117 | "RS384" -> Ok RS384
118 | "RS512" -> Ok RS512
119 | "ES256" -> Ok ES256
120 | "ES384" -> Ok ES384
121 | "ES512" -> Ok ES512
122 | "EdDSA" -> Ok EdDSA
123 | s -> Error (Unsupported_algorithm s)
124
125 let all =
126 [ HS256; HS384; HS512; RS256; RS384; RS512; ES256; ES384; ES512; EdDSA ]
127
128 let all_with_none = None :: all
129end
130
131(* JWK module *)
132module Jwk = struct
133 type kty = Oct | Rsa | Ec | Okp
134 type crv = P256 | P384 | P521 | Ed25519
135
136 type key_data =
137 | Symmetric of { k : string }
138 | Ed25519_pub of { x : string }
139 | Ed25519_priv of { x : string; d : string }
140 | P256_pub of { x : string; y : string }
141 | P256_priv of { x : string; y : string; d : string }
142 | P384_pub of { x : string; y : string }
143 | P384_priv of { x : string; y : string; d : string }
144 | P521_pub of { x : string; y : string }
145 | P521_priv of { x : string; y : string; d : string }
146 | Rsa_pub of { n : string; e : string }
147 | Rsa_priv of {
148 n : string;
149 e : string;
150 d : string;
151 p : string;
152 q : string;
153 dp : string;
154 dq : string;
155 qi : string;
156 }
157
158 type t = {
159 key_data : key_data;
160 kid : string option;
161 alg : Algorithm.t option;
162 }
163
164 let symmetric k = { key_data = Symmetric { k }; kid = None; alg = None }
165
166 let ed25519_pub x =
167 { key_data = Ed25519_pub { x }; kid = None; alg = Some Algorithm.EdDSA }
168
169 let ed25519_priv ~pub ~priv =
170 {
171 key_data = Ed25519_priv { x = pub; d = priv };
172 kid = None;
173 alg = Some Algorithm.EdDSA;
174 }
175
176 let p256_pub ~x ~y =
177 { key_data = P256_pub { x; y }; kid = None; alg = Some Algorithm.ES256 }
178
179 let p256_priv ~x ~y ~d =
180 { key_data = P256_priv { x; y; d }; kid = None; alg = Some Algorithm.ES256 }
181
182 let p384_pub ~x ~y =
183 { key_data = P384_pub { x; y }; kid = None; alg = Some Algorithm.ES384 }
184
185 let p384_priv ~x ~y ~d =
186 { key_data = P384_priv { x; y; d }; kid = None; alg = Some Algorithm.ES384 }
187
188 let p521_pub ~x ~y =
189 { key_data = P521_pub { x; y }; kid = None; alg = Some Algorithm.ES512 }
190
191 let p521_priv ~x ~y ~d =
192 { key_data = P521_priv { x; y; d }; kid = None; alg = Some Algorithm.ES512 }
193
194 let rsa_pub ~n ~e =
195 { key_data = Rsa_pub { n; e }; kid = None; alg = Some Algorithm.RS256 }
196
197 let rsa_priv ~n ~e ~d ~p ~q ~dp ~dq ~qi =
198 {
199 key_data = Rsa_priv { n; e; d; p; q; dp; dq; qi };
200 kid = None;
201 alg = Some Algorithm.RS256;
202 }
203
204 let kty t =
205 match t.key_data with
206 | Symmetric _ -> Oct
207 | Ed25519_pub _ | Ed25519_priv _ -> Okp
208 | P256_pub _ | P256_priv _ | P384_pub _ | P384_priv _ | P521_pub _
209 | P521_priv _ ->
210 Ec
211 | Rsa_pub _ | Rsa_priv _ -> Rsa
212
213 let kid t = t.kid
214 let alg t = t.alg
215 let with_kid id t = { t with kid = Some id }
216 let with_alg a t = { t with alg = Some a }
217
218 (* Helper to extract string from Jsont.json object members *)
219 let get_json_string members name =
220 List.find_map
221 (fun ((n, _), v) ->
222 if n = name then
223 match v with Jsont.String (s, _) -> Some s | _ -> None
224 else None)
225 members
226
227 let get_json_string_req members name =
228 match get_json_string members name with
229 | Some s -> Ok s
230 | None ->
231 Error (Invalid_json (Printf.sprintf "missing required field: %s" name))
232
233 let of_json s =
234 (* Parse the JSON to determine key type first *)
235 match Jsont_bytesrw.decode_string Jsont.json s with
236 | Error e -> Error (Invalid_json e)
237 | Ok (Jsont.Null _) -> Error (Invalid_json "null is not a valid JWK")
238 | Ok (Jsont.Object (members, _)) -> (
239 let ( let* ) = Result.bind in
240 let* kty_s = get_json_string_req members "kty" in
241 let kid = get_json_string members "kid" in
242 let alg_opt =
243 match get_json_string members "alg" with
244 | None -> Ok None
245 | Some s -> (
246 match Algorithm.of_string s with
247 | Ok a -> Ok (Some a)
248 | Error _ -> Ok None (* ignore unknown alg in JWK *))
249 in
250 let* alg = alg_opt in
251 match kty_s with
252 | "oct" ->
253 let* k_b64 = get_json_string_req members "k" in
254 let* k = base64url_decode k_b64 in
255 Ok { key_data = Symmetric { k }; kid; alg }
256 | "OKP" -> (
257 let* crv = get_json_string_req members "crv" in
258 if crv <> "Ed25519" then
259 Error (Invalid_json (Printf.sprintf "unsupported curve: %s" crv))
260 else
261 let* x_b64 = get_json_string_req members "x" in
262 let* x = base64url_decode x_b64 in
263 match get_json_string members "d" with
264 | None -> Ok { key_data = Ed25519_pub { x }; kid; alg }
265 | Some d_b64 ->
266 let* d = base64url_decode d_b64 in
267 Ok { key_data = Ed25519_priv { x; d }; kid; alg })
268 | "EC" -> (
269 let* crv = get_json_string_req members "crv" in
270 let* x_b64 = get_json_string_req members "x" in
271 let* y_b64 = get_json_string_req members "y" in
272 let* x = base64url_decode x_b64 in
273 let* y = base64url_decode y_b64 in
274 let has_d = Option.is_some (get_json_string members "d") in
275 let get_d () =
276 let* d_b64 = get_json_string_req members "d" in
277 base64url_decode d_b64
278 in
279 match crv with
280 | "P-256" ->
281 if has_d then
282 let* d = get_d () in
283 Ok { key_data = P256_priv { x; y; d }; kid; alg }
284 else Ok { key_data = P256_pub { x; y }; kid; alg }
285 | "P-384" ->
286 if has_d then
287 let* d = get_d () in
288 Ok { key_data = P384_priv { x; y; d }; kid; alg }
289 else Ok { key_data = P384_pub { x; y }; kid; alg }
290 | "P-521" ->
291 if has_d then
292 let* d = get_d () in
293 Ok { key_data = P521_priv { x; y; d }; kid; alg }
294 else Ok { key_data = P521_pub { x; y }; kid; alg }
295 | _ ->
296 Error
297 (Invalid_json (Printf.sprintf "unsupported curve: %s" crv)))
298 | "RSA" -> (
299 let* n_b64 = get_json_string_req members "n" in
300 let* e_b64 = get_json_string_req members "e" in
301 let* n = base64url_decode n_b64 in
302 let* e = base64url_decode e_b64 in
303 match get_json_string members "d" with
304 | None -> Ok { key_data = Rsa_pub { n; e }; kid; alg }
305 | Some d_b64 ->
306 let* d = base64url_decode d_b64 in
307 let* p_b64 = get_json_string_req members "p" in
308 let* q_b64 = get_json_string_req members "q" in
309 let* dp_b64 = get_json_string_req members "dp" in
310 let* dq_b64 = get_json_string_req members "dq" in
311 let* qi_b64 = get_json_string_req members "qi" in
312 let* p = base64url_decode p_b64 in
313 let* q = base64url_decode q_b64 in
314 let* dp = base64url_decode dp_b64 in
315 let* dq = base64url_decode dq_b64 in
316 let* qi = base64url_decode qi_b64 in
317 Ok
318 {
319 key_data = Rsa_priv { n; e; d; p; q; dp; dq; qi };
320 kid;
321 alg;
322 })
323 | _ -> Error (Invalid_json (Printf.sprintf "unsupported kty: %s" kty_s))
324 )
325 | Ok _ -> Error (Invalid_json "JWK must be a JSON object")
326
327 (* Helper to create JSON members *)
328 let meta = Jsont.Meta.none
329 let json_string s = Jsont.String (s, meta)
330 let json_mem name value = ((name, meta), value)
331
332 let to_json t =
333 let add_opt name v_opt acc =
334 match v_opt with
335 | None -> acc
336 | Some v -> json_mem name (json_string v) :: acc
337 in
338 let members = [] in
339 let members = add_opt "kid" t.kid members in
340 let members =
341 add_opt "alg" (Option.map Algorithm.to_string t.alg) members
342 in
343 let members =
344 match t.key_data with
345 | Symmetric { k } ->
346 json_mem "kty" (json_string "oct")
347 :: json_mem "k" (json_string (base64url_encode k))
348 :: members
349 | Ed25519_pub { x } ->
350 json_mem "kty" (json_string "OKP")
351 :: json_mem "crv" (json_string "Ed25519")
352 :: json_mem "x" (json_string (base64url_encode x))
353 :: members
354 | Ed25519_priv { x; d } ->
355 json_mem "kty" (json_string "OKP")
356 :: json_mem "crv" (json_string "Ed25519")
357 :: json_mem "x" (json_string (base64url_encode x))
358 :: json_mem "d" (json_string (base64url_encode d))
359 :: members
360 | P256_pub { x; y } ->
361 json_mem "kty" (json_string "EC")
362 :: json_mem "crv" (json_string "P-256")
363 :: json_mem "x" (json_string (base64url_encode x))
364 :: json_mem "y" (json_string (base64url_encode y))
365 :: members
366 | P256_priv { x; y; d } ->
367 json_mem "kty" (json_string "EC")
368 :: json_mem "crv" (json_string "P-256")
369 :: json_mem "x" (json_string (base64url_encode x))
370 :: json_mem "y" (json_string (base64url_encode y))
371 :: json_mem "d" (json_string (base64url_encode d))
372 :: members
373 | P384_pub { x; y } ->
374 json_mem "kty" (json_string "EC")
375 :: json_mem "crv" (json_string "P-384")
376 :: json_mem "x" (json_string (base64url_encode x))
377 :: json_mem "y" (json_string (base64url_encode y))
378 :: members
379 | P384_priv { x; y; d } ->
380 json_mem "kty" (json_string "EC")
381 :: json_mem "crv" (json_string "P-384")
382 :: json_mem "x" (json_string (base64url_encode x))
383 :: json_mem "y" (json_string (base64url_encode y))
384 :: json_mem "d" (json_string (base64url_encode d))
385 :: members
386 | P521_pub { x; y } ->
387 json_mem "kty" (json_string "EC")
388 :: json_mem "crv" (json_string "P-521")
389 :: json_mem "x" (json_string (base64url_encode x))
390 :: json_mem "y" (json_string (base64url_encode y))
391 :: members
392 | P521_priv { x; y; d } ->
393 json_mem "kty" (json_string "EC")
394 :: json_mem "crv" (json_string "P-521")
395 :: json_mem "x" (json_string (base64url_encode x))
396 :: json_mem "y" (json_string (base64url_encode y))
397 :: json_mem "d" (json_string (base64url_encode d))
398 :: members
399 | Rsa_pub { n; e } ->
400 json_mem "kty" (json_string "RSA")
401 :: json_mem "n" (json_string (base64url_encode n))
402 :: json_mem "e" (json_string (base64url_encode e))
403 :: members
404 | Rsa_priv { n; e; d; p; q; dp; dq; qi } ->
405 json_mem "kty" (json_string "RSA")
406 :: json_mem "n" (json_string (base64url_encode n))
407 :: json_mem "e" (json_string (base64url_encode e))
408 :: json_mem "d" (json_string (base64url_encode d))
409 :: json_mem "p" (json_string (base64url_encode p))
410 :: json_mem "q" (json_string (base64url_encode q))
411 :: json_mem "dp" (json_string (base64url_encode dp))
412 :: json_mem "dq" (json_string (base64url_encode dq))
413 :: json_mem "qi" (json_string (base64url_encode qi))
414 :: members
415 in
416 match
417 Jsont_bytesrw.encode_string Jsont.json (Jsont.Object (members, meta))
418 with
419 | Ok s -> s
420 | Error _ -> "{}" (* Should not happen *)
421end
422
423(* Header module *)
424module Header = struct
425 type t = {
426 alg : Algorithm.t;
427 typ : string option;
428 kid : string option;
429 cty : string option;
430 }
431
432 let make ?typ ?kid ?cty alg = { alg; typ; kid; cty }
433
434 let is_nested t =
435 match t.cty with
436 | Some s -> String.uppercase_ascii s = "JWT"
437 | None -> false
438
439 (* Helper to extract string from Jsont.json object members *)
440 let get_json_string members name =
441 List.find_map
442 (fun ((n, _), v) ->
443 if n = name then
444 match v with Jsont.String (s, _) -> Some s | _ -> None
445 else None)
446 members
447
448 let of_json s =
449 match Jsont_bytesrw.decode_string Jsont.json s with
450 | Error e -> Error (Invalid_json e)
451 | Ok (Jsont.Null _) -> Error (Invalid_header "null is not a valid header")
452 | Ok (Jsont.Object (members, _)) -> (
453 let ( let* ) = Result.bind in
454 let alg_s = get_json_string members "alg" in
455 match alg_s with
456 | None -> Error (Invalid_header "missing required 'alg' field")
457 | Some alg_str ->
458 let* alg = Algorithm.of_string alg_str in
459 let typ = get_json_string members "typ" in
460 let kid = get_json_string members "kid" in
461 let cty = get_json_string members "cty" in
462 Ok { alg; typ; kid; cty })
463 | Ok _ -> Error (Invalid_header "header must be a JSON object")
464
465 let meta = Jsont.Meta.none
466 let json_string s = Jsont.String (s, meta)
467 let json_mem name value = ((name, meta), value)
468
469 let to_json h =
470 let members =
471 [ json_mem "alg" (json_string (Algorithm.to_string h.alg)) ]
472 in
473 let add_opt name v_opt acc =
474 match v_opt with
475 | None -> acc
476 | Some v -> json_mem name (json_string v) :: acc
477 in
478 let members = add_opt "typ" h.typ members in
479 let members = add_opt "kid" h.kid members in
480 let members = add_opt "cty" h.cty members in
481 match
482 Jsont_bytesrw.encode_string Jsont.json
483 (Jsont.Object (List.rev members, meta))
484 with
485 | Ok s -> s
486 | Error _ -> "{}"
487end
488
489(* Claims module *)
490module Claims = struct
491 type t = {
492 iss : string option;
493 sub : string option;
494 aud : string list;
495 exp : Ptime.t option;
496 nbf : Ptime.t option;
497 iat : Ptime.t option;
498 jti : string option;
499 custom : (string * Jsont.json) list;
500 }
501
502 let iss t = t.iss
503 let sub t = t.sub
504 let aud t = t.aud
505 let exp t = t.exp
506 let nbf t = t.nbf
507 let iat t = t.iat
508 let jti t = t.jti
509 let get name t = List.assoc_opt name t.custom
510
511 let get_string name t =
512 match get name t with Some (Jsont.String (s, _)) -> Some s | _ -> None
513
514 let get_int name t =
515 match get name t with
516 | Some (Jsont.Number (n, _)) -> (
517 try Some (int_of_float n) with _ -> None)
518 | _ -> None
519
520 let get_bool name t =
521 match get name t with Some (Jsont.Bool (b, _)) -> Some b | _ -> None
522
523 let meta = Jsont.Meta.none
524 let json_string s = Jsont.String (s, meta)
525 let json_number n = Jsont.Number (n, meta)
526 let json_bool b = Jsont.Bool (b, meta)
527 let json_mem name value = ((name, meta), value)
528
529 type builder = t
530
531 let empty =
532 {
533 iss = None;
534 sub = None;
535 aud = [];
536 exp = None;
537 nbf = None;
538 iat = None;
539 jti = None;
540 custom = [];
541 }
542
543 let set_iss v t = { t with iss = Some v }
544 let set_sub v t = { t with sub = Some v }
545 let set_aud v t = { t with aud = v }
546 let set_exp v t = { t with exp = Some v }
547 let set_nbf v t = { t with nbf = Some v }
548 let set_iat v t = { t with iat = Some v }
549 let set_jti v t = { t with jti = Some v }
550 let set name value t = { t with custom = (name, value) :: t.custom }
551 let set_string name value t = set name (json_string value) t
552 let set_int name value t = set name (json_number (float_of_int value)) t
553 let set_bool name value t = set name (json_bool value) t
554 let build t = t
555
556 let ptime_of_numeric_date n =
557 let span = Ptime.Span.of_float_s n in
558 Option.bind span (fun s -> Ptime.of_span s)
559
560 let numeric_date_of_ptime t = Ptime.to_span t |> Ptime.Span.to_float_s
561
562 (* Helper to extract values from Jsont.json object members *)
563 let get_json_string members name =
564 List.find_map
565 (fun ((n, _), v) ->
566 if n = name then
567 match v with Jsont.String (s, _) -> Some s | _ -> None
568 else None)
569 members
570
571 let get_json_number members name =
572 List.find_map
573 (fun ((n, _), v) ->
574 if n = name then
575 match v with Jsont.Number (n, _) -> Some n | _ -> None
576 else None)
577 members
578
579 let get_json_aud members =
580 List.find_map
581 (fun ((n, _), v) ->
582 if n = "aud" then
583 match v with
584 | Jsont.String (s, _) -> Some [ s ]
585 | Jsont.Array (arr, _) ->
586 Some
587 (List.filter_map
588 (function Jsont.String (s, _) -> Some s | _ -> None)
589 arr)
590 | _ -> None
591 else None)
592 members
593 |> Option.value ~default:[]
594
595 let of_json ?(strict = true) s =
596 match Jsont_bytesrw.decode_string Jsont.json s with
597 | Error e -> Error (Invalid_json e)
598 | Ok (Jsont.Null _) ->
599 Error (Invalid_claims "null is not a valid claims set")
600 | Ok (Jsont.Object (members, _)) ->
601 let ( let* ) = Result.bind in
602 (* Check for duplicates in strict mode *)
603 let* () =
604 if strict then
605 let names = List.map (fun ((n, _), _) -> n) members in
606 let rec check_dups = function
607 | [] -> Ok ()
608 | n :: rest ->
609 if List.mem n rest then Error (Duplicate_claim n)
610 else check_dups rest
611 in
612 check_dups names
613 else Ok ()
614 in
615 (* Validate StringOrURI for iss and sub *)
616 let* iss =
617 match get_json_string members "iss" with
618 | None -> Ok None
619 | Some s ->
620 let* _ = validate_string_or_uri s in
621 Ok (Some s)
622 in
623 let* sub =
624 match get_json_string members "sub" with
625 | None -> Ok None
626 | Some s ->
627 let* _ = validate_string_or_uri s in
628 Ok (Some s)
629 in
630 let exp =
631 Option.bind (get_json_number members "exp") ptime_of_numeric_date
632 in
633 let nbf =
634 Option.bind (get_json_number members "nbf") ptime_of_numeric_date
635 in
636 let iat =
637 Option.bind (get_json_number members "iat") ptime_of_numeric_date
638 in
639 let jti = get_json_string members "jti" in
640 let aud = get_json_aud members in
641 (* Collect custom claims (everything not registered) *)
642 let registered = [ "iss"; "sub"; "aud"; "exp"; "nbf"; "iat"; "jti" ] in
643 let custom =
644 List.filter_map
645 (fun ((n, _), v) ->
646 if List.mem n registered then None else Some (n, v))
647 members
648 in
649 Ok { iss; sub; aud; exp; nbf; iat; jti; custom }
650 | Ok _ -> Error (Invalid_claims "claims must be a JSON object")
651
652 let to_json t =
653 let members = [] in
654 let add_string name v_opt acc =
655 match v_opt with
656 | None -> acc
657 | Some v -> json_mem name (json_string v) :: acc
658 in
659 let add_time name v_opt acc =
660 match v_opt with
661 | None -> acc
662 | Some v -> json_mem name (json_number (numeric_date_of_ptime v)) :: acc
663 in
664 let members = add_string "iss" t.iss members in
665 let members = add_string "sub" t.sub members in
666 let members =
667 match t.aud with
668 | [] -> members
669 | [ single ] -> json_mem "aud" (json_string single) :: members
670 | many ->
671 let arr = List.map json_string many in
672 json_mem "aud" (Jsont.Array (arr, meta)) :: members
673 in
674 let members = add_time "exp" t.exp members in
675 let members = add_time "nbf" t.nbf members in
676 let members = add_time "iat" t.iat members in
677 let members = add_string "jti" t.jti members in
678 let members =
679 List.fold_left
680 (fun acc (name, value) -> json_mem name value :: acc)
681 members t.custom
682 in
683 match
684 Jsont_bytesrw.encode_string Jsont.json
685 (Jsont.Object (List.rev members, meta))
686 with
687 | Ok s -> s
688 | Error _ -> "{}"
689end
690
691(* JWT type *)
692type t = {
693 header : Header.t;
694 claims : Claims.t;
695 signature : string;
696 raw : string;
697}
698
699let header t = t.header
700let claims t = t.claims
701let signature t = t.signature
702let raw t = t.raw
703let is_nested t = Header.is_nested t.header
704
705(* Parsing *)
706let parse ?(strict = true) token =
707 let ( let* ) = Result.bind in
708 (* RFC 7519 Section 7.2 step 1: verify at least one period *)
709 if not (String.contains token '.') then
710 Error (Invalid_structure "JWT must contain at least one period character")
711 else
712 match String.split_on_char '.' token with
713 | [ header_b64; payload_b64; sig_b64 ] ->
714 (* JWS compact serialization: 3 parts *)
715 let* header_json = base64url_decode header_b64 in
716 let* payload_json = base64url_decode payload_b64 in
717 let* signature = base64url_decode sig_b64 in
718 let* header = Header.of_json header_json in
719 let* claims = Claims.of_json ~strict payload_json in
720 Ok { header; claims; signature; raw = token }
721 | parts when List.length parts = 5 ->
722 (* JWE compact serialization - not yet supported *)
723 Error (Invalid_structure "JWE (encrypted JWT) not yet supported")
724 | _ ->
725 Error (Invalid_structure "JWT must have 3 parts (JWS) or 5 parts (JWE)")
726
727let parse_unsafe = parse ~strict:false
728
729let parse_nested ?(strict = true) ?(max_depth = 5) token =
730 let ( let* ) = Result.bind in
731 let rec loop depth acc tok =
732 if depth > max_depth then Error Nesting_too_deep
733 else
734 let* jwt = parse ~strict tok in
735 let acc = jwt :: acc in
736 if is_nested jwt then
737 (* The payload is another JWT - decode and parse it *)
738 match String.split_on_char '.' tok with
739 | [ _; payload_b64; _ ] ->
740 let* inner_token = base64url_decode payload_b64 in
741 loop (depth + 1) acc inner_token
742 | _ -> Ok (List.rev acc)
743 else Ok (List.rev acc)
744 in
745 loop 1 [] token
746
747(* Signature operations *)
748module Sign = struct
749 let hmac_sha256 ~key data =
750 let key = Cstruct.of_string key in
751 let data = Cstruct.of_string data in
752 Digestif.SHA256.hmac_string ~key:(Cstruct.to_string key)
753 (Cstruct.to_string data)
754 |> Digestif.SHA256.to_raw_string
755
756 let hmac_sha384 ~key data =
757 let key = Cstruct.of_string key in
758 let data = Cstruct.of_string data in
759 Digestif.SHA384.hmac_string ~key:(Cstruct.to_string key)
760 (Cstruct.to_string data)
761 |> Digestif.SHA384.to_raw_string
762
763 let hmac_sha512 ~key data =
764 let key = Cstruct.of_string key in
765 let data = Cstruct.of_string data in
766 Digestif.SHA512.hmac_string ~key:(Cstruct.to_string key)
767 (Cstruct.to_string data)
768 |> Digestif.SHA512.to_raw_string
769
770 (* EdDSA signing using mirage-crypto-ec *)
771 let ed25519_sign ~priv data =
772 match Mirage_crypto_ec.Ed25519.priv_of_octets priv with
773 | Error _ -> Error (Key_type_mismatch "Invalid Ed25519 private key")
774 | Ok priv ->
775 let sig_ = Mirage_crypto_ec.Ed25519.sign ~key:priv data in
776 Ok sig_
777
778 let ed25519_verify ~pub ~signature data =
779 match Mirage_crypto_ec.Ed25519.pub_of_octets pub with
780 | Error _ -> Error (Key_type_mismatch "Invalid Ed25519 public key")
781 | Ok pub ->
782 let valid =
783 Mirage_crypto_ec.Ed25519.verify ~key:pub signature ~msg:data
784 in
785 if valid then Ok () else Error Signature_mismatch
786
787 (* P-256 ECDSA *)
788 let p256_sign ~priv data =
789 match Mirage_crypto_ec.P256.Dsa.priv_of_octets priv with
790 | Error _ -> Error (Key_type_mismatch "Invalid P-256 private key")
791 | Ok priv ->
792 let hash =
793 Digestif.SHA256.digest_string data |> Digestif.SHA256.to_raw_string
794 in
795 let r, s = Mirage_crypto_ec.P256.Dsa.sign ~key:priv hash in
796 (* JWS uses raw R||S format, each 32 bytes for P-256 *)
797 (* Pad to 32 bytes each *)
798 let pad32 s =
799 let len = String.length s in
800 if len >= 32 then String.sub s (len - 32) 32
801 else String.make (32 - len) '\x00' ^ s
802 in
803 Ok (pad32 r ^ pad32 s)
804
805 let p256_verify ~pub ~signature data =
806 if String.length signature <> 64 then Error Signature_mismatch
807 else
808 let r = String.sub signature 0 32 in
809 let s = String.sub signature 32 32 in
810 match Mirage_crypto_ec.P256.Dsa.pub_of_octets pub with
811 | Error _ -> Error (Key_type_mismatch "Invalid P-256 public key")
812 | Ok pub ->
813 let hash =
814 Digestif.SHA256.digest_string data |> Digestif.SHA256.to_raw_string
815 in
816 let valid = Mirage_crypto_ec.P256.Dsa.verify ~key:pub (r, s) hash in
817 if valid then Ok () else Error Signature_mismatch
818
819 (* P-384 ECDSA *)
820 let p384_sign ~priv data =
821 match Mirage_crypto_ec.P384.Dsa.priv_of_octets priv with
822 | Error _ -> Error (Key_type_mismatch "Invalid P-384 private key")
823 | Ok priv ->
824 let hash =
825 Digestif.SHA384.digest_string data |> Digestif.SHA384.to_raw_string
826 in
827 let r, s = Mirage_crypto_ec.P384.Dsa.sign ~key:priv hash in
828 let pad48 s =
829 let len = String.length s in
830 if len >= 48 then String.sub s (len - 48) 48
831 else String.make (48 - len) '\x00' ^ s
832 in
833 Ok (pad48 r ^ pad48 s)
834
835 let p384_verify ~pub ~signature data =
836 if String.length signature <> 96 then Error Signature_mismatch
837 else
838 let r = String.sub signature 0 48 in
839 let s = String.sub signature 48 48 in
840 match Mirage_crypto_ec.P384.Dsa.pub_of_octets pub with
841 | Error _ -> Error (Key_type_mismatch "Invalid P-384 public key")
842 | Ok pub ->
843 let hash =
844 Digestif.SHA384.digest_string data |> Digestif.SHA384.to_raw_string
845 in
846 let valid = Mirage_crypto_ec.P384.Dsa.verify ~key:pub (r, s) hash in
847 if valid then Ok () else Error Signature_mismatch
848
849 (* P-521 ECDSA *)
850 let p521_sign ~priv data =
851 match Mirage_crypto_ec.P521.Dsa.priv_of_octets priv with
852 | Error _ -> Error (Key_type_mismatch "Invalid P-521 private key")
853 | Ok priv ->
854 let hash =
855 Digestif.SHA512.digest_string data |> Digestif.SHA512.to_raw_string
856 in
857 let r, s = Mirage_crypto_ec.P521.Dsa.sign ~key:priv hash in
858 let pad66 s =
859 let len = String.length s in
860 if len >= 66 then String.sub s (len - 66) 66
861 else String.make (66 - len) '\x00' ^ s
862 in
863 Ok (pad66 r ^ pad66 s)
864
865 let p521_verify ~pub ~signature data =
866 if String.length signature <> 132 then Error Signature_mismatch
867 else
868 let r = String.sub signature 0 66 in
869 let s = String.sub signature 66 66 in
870 match Mirage_crypto_ec.P521.Dsa.pub_of_octets pub with
871 | Error _ -> Error (Key_type_mismatch "Invalid P-521 public key")
872 | Ok pub ->
873 let hash =
874 Digestif.SHA512.digest_string data |> Digestif.SHA512.to_raw_string
875 in
876 let valid = Mirage_crypto_ec.P521.Dsa.verify ~key:pub (r, s) hash in
877 if valid then Ok () else Error Signature_mismatch
878
879 (* RSA PKCS#1 v1.5 - stub implementations *)
880 (* TODO: Implement proper RSA signing/verification with JWK key parsing *)
881 let _rsa_sign _hash_type ~priv:_ _data =
882 Error (Key_type_mismatch "RSA signing not yet implemented")
883
884 let _rsa_verify _hash_type ~pub:_ ~signature:_ _data =
885 Error (Key_type_mismatch "RSA verification not yet implemented")
886end
887
888(* Get signing input from token *)
889let signing_input token =
890 match String.rindex_opt token '.' with
891 | None -> token
892 | Some i -> String.sub token 0 i
893
894(* Verification *)
895let verify ~key ?(allow_none = false) ?(allowed_algs = Algorithm.all) t =
896 let ( let* ) = Result.bind in
897 let alg = t.header.alg in
898 let alg_str = Algorithm.to_string alg in
899 (* Check if algorithm is allowed *)
900 let* () =
901 if alg = Algorithm.None then
902 (* For alg:none, only allow_none flag matters *)
903 if allow_none then Ok () else Error Unsecured_not_allowed
904 else if List.mem alg allowed_algs then Ok ()
905 else Error (Algorithm_not_allowed alg_str)
906 in
907 let input = signing_input t.raw in
908 match (alg, key.Jwk.key_data) with
909 | Algorithm.None, _ ->
910 (* Unsecured JWT - signature must be empty *)
911 if t.signature = "" then Ok () else Error Signature_mismatch
912 | Algorithm.HS256, Jwk.Symmetric { k } ->
913 let expected = Sign.hmac_sha256 ~key:k input in
914 if Eqaf.equal expected t.signature then Ok ()
915 else Error Signature_mismatch
916 | Algorithm.HS384, Jwk.Symmetric { k } ->
917 let expected = Sign.hmac_sha384 ~key:k input in
918 if Eqaf.equal expected t.signature then Ok ()
919 else Error Signature_mismatch
920 | Algorithm.HS512, Jwk.Symmetric { k } ->
921 let expected = Sign.hmac_sha512 ~key:k input in
922 if Eqaf.equal expected t.signature then Ok ()
923 else Error Signature_mismatch
924 | Algorithm.EdDSA, Jwk.Ed25519_pub { x } ->
925 Sign.ed25519_verify ~pub:x ~signature:t.signature input
926 | Algorithm.EdDSA, Jwk.Ed25519_priv { x; d = _ } ->
927 Sign.ed25519_verify ~pub:x ~signature:t.signature input
928 | Algorithm.ES256, Jwk.P256_pub { x; y } ->
929 let pub = x ^ y in
930 (* Uncompressed point *)
931 Sign.p256_verify ~pub ~signature:t.signature input
932 | Algorithm.ES256, Jwk.P256_priv { x; y; d = _ } ->
933 let pub = x ^ y in
934 Sign.p256_verify ~pub ~signature:t.signature input
935 | Algorithm.ES384, Jwk.P384_pub { x; y } ->
936 let pub = x ^ y in
937 Sign.p384_verify ~pub ~signature:t.signature input
938 | Algorithm.ES384, Jwk.P384_priv { x; y; d = _ } ->
939 let pub = x ^ y in
940 Sign.p384_verify ~pub ~signature:t.signature input
941 | Algorithm.ES512, Jwk.P521_pub { x; y } ->
942 let pub = x ^ y in
943 Sign.p521_verify ~pub ~signature:t.signature input
944 | Algorithm.ES512, Jwk.P521_priv { x; y; d = _ } ->
945 let pub = x ^ y in
946 Sign.p521_verify ~pub ~signature:t.signature input
947 | Algorithm.RS256, Jwk.Rsa_pub _ ->
948 Error (Key_type_mismatch "RSA verification not yet implemented")
949 | Algorithm.RS384, Jwk.Rsa_pub _ ->
950 Error (Key_type_mismatch "RSA verification not yet implemented")
951 | Algorithm.RS512, Jwk.Rsa_pub _ ->
952 Error (Key_type_mismatch "RSA verification not yet implemented")
953 | alg, _ ->
954 Error
955 (Key_type_mismatch
956 (Printf.sprintf "Key type doesn't match algorithm %s"
957 (Algorithm.to_string alg)))
958
959(* Claims validation *)
960let validate ~now ?iss ?aud ?(leeway = Ptime.Span.zero) t =
961 let ( let* ) = Result.bind in
962 let claims = t.claims in
963 (* Check exp claim *)
964 let* () =
965 match Claims.exp claims with
966 | None -> Ok ()
967 | Some exp_time ->
968 let exp_with_leeway =
969 Ptime.add_span exp_time leeway |> Option.value ~default:exp_time
970 in
971 if Ptime.is_later now ~than:exp_with_leeway then Error Token_expired
972 else Ok ()
973 in
974 (* Check nbf claim *)
975 let* () =
976 match Claims.nbf claims with
977 | None -> Ok ()
978 | Some nbf_time ->
979 let nbf_with_leeway =
980 Ptime.sub_span nbf_time leeway |> Option.value ~default:nbf_time
981 in
982 if Ptime.is_earlier now ~than:nbf_with_leeway then
983 Error Token_not_yet_valid
984 else Ok ()
985 in
986 (* Check iss claim *)
987 let* () =
988 match iss with
989 | None -> Ok ()
990 | Some expected_iss -> (
991 match Claims.iss claims with
992 | None -> Error Invalid_issuer
993 | Some actual_iss ->
994 if String.equal expected_iss actual_iss then Ok ()
995 else Error Invalid_issuer)
996 in
997 (* Check aud claim *)
998 let* () =
999 match aud with
1000 | None -> Ok ()
1001 | Some expected_aud ->
1002 let actual_aud = Claims.aud claims in
1003 if List.mem expected_aud actual_aud then Ok ()
1004 else Error Invalid_audience
1005 in
1006 Ok ()
1007
1008let verify_and_validate ~key ~now ?allow_none ?allowed_algs ?iss ?aud ?leeway t
1009 =
1010 let ( let* ) = Result.bind in
1011 let* () = verify ~key ?allow_none ?allowed_algs t in
1012 validate ~now ?iss ?aud ?leeway t
1013
1014(* Creation *)
1015let create ~header ~claims ~key =
1016 let ( let* ) = Result.bind in
1017 let header_json = Header.to_json header in
1018 let claims_json = Claims.to_json claims in
1019 let header_b64 = base64url_encode header_json in
1020 let payload_b64 = base64url_encode claims_json in
1021 let signing_input = header_b64 ^ "." ^ payload_b64 in
1022 let* signature =
1023 match (header.Header.alg, key.Jwk.key_data) with
1024 | Algorithm.None, _ -> Ok ""
1025 | Algorithm.HS256, Jwk.Symmetric { k } ->
1026 Ok (Sign.hmac_sha256 ~key:k signing_input)
1027 | Algorithm.HS384, Jwk.Symmetric { k } ->
1028 Ok (Sign.hmac_sha384 ~key:k signing_input)
1029 | Algorithm.HS512, Jwk.Symmetric { k } ->
1030 Ok (Sign.hmac_sha512 ~key:k signing_input)
1031 | Algorithm.EdDSA, Jwk.Ed25519_priv { x = _; d } ->
1032 Sign.ed25519_sign ~priv:d signing_input
1033 | Algorithm.ES256, Jwk.P256_priv { x = _; y = _; d } ->
1034 Sign.p256_sign ~priv:d signing_input
1035 | Algorithm.ES384, Jwk.P384_priv { x = _; y = _; d } ->
1036 Sign.p384_sign ~priv:d signing_input
1037 | Algorithm.ES512, Jwk.P521_priv { x = _; y = _; d } ->
1038 Sign.p521_sign ~priv:d signing_input
1039 | alg, _ ->
1040 Error
1041 (Key_type_mismatch
1042 (Printf.sprintf "Cannot sign with algorithm %s and given key"
1043 (Algorithm.to_string alg)))
1044 in
1045 let sig_b64 = base64url_encode signature in
1046 let raw = signing_input ^ "." ^ sig_b64 in
1047 Ok { header; claims; signature; raw }
1048
1049let encode t = t.raw
1050
1051(* Utilities *)
1052let is_expired ~now ?(leeway = Ptime.Span.zero) t =
1053 match Claims.exp t.claims with
1054 | None -> false
1055 | Some exp_time ->
1056 let exp_with_leeway =
1057 Ptime.add_span exp_time leeway |> Option.value ~default:exp_time
1058 in
1059 Ptime.is_later now ~than:exp_with_leeway
1060
1061let time_to_expiry ~now t =
1062 match Claims.exp t.claims with
1063 | None -> None
1064 | Some exp_time ->
1065 let diff = Ptime.diff exp_time now in
1066 if Ptime.Span.compare diff Ptime.Span.zero <= 0 then None else Some diff
1067
1068module Cwt = Cwt
1069(** CBOR Web Token (CWT) support *)