anil.recoil.org
JSON web tokens in OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(** CBOR Web Token (CWT) - RFC 8392 *)
7
8(* Error handling *)
9
10type error =
11 | Invalid_cbor of string
12 | Invalid_cose of string
13 | Invalid_claims of string
14 | Unsupported_algorithm of string
15 | Algorithm_not_allowed of string
16 | Signature_mismatch
17 | Token_expired
18 | Token_not_yet_valid
19 | Invalid_issuer
20 | Invalid_audience
21 | Key_type_mismatch of string
22
23let pp_error ppf = function
24 | Invalid_cbor s -> Format.fprintf ppf "Invalid CBOR: %s" s
25 | Invalid_cose s -> Format.fprintf ppf "Invalid COSE: %s" s
26 | Invalid_claims s -> Format.fprintf ppf "Invalid claims: %s" s
27 | Unsupported_algorithm s -> Format.fprintf ppf "Unsupported algorithm: %s" s
28 | Algorithm_not_allowed s -> Format.fprintf ppf "Algorithm not allowed: %s" s
29 | Signature_mismatch -> Format.fprintf ppf "Signature mismatch"
30 | Token_expired -> Format.fprintf ppf "Token expired"
31 | Token_not_yet_valid -> Format.fprintf ppf "Token not yet valid"
32 | Invalid_issuer -> Format.fprintf ppf "Invalid issuer"
33 | Invalid_audience -> Format.fprintf ppf "Invalid audience"
34 | Key_type_mismatch s -> Format.fprintf ppf "Key type mismatch: %s" s
35
36let error_to_string e = Format.asprintf "%a" pp_error e
37
38(* Cbort codec helpers *)
39
40let cbort_error_to_error e = Invalid_cbor (Cbort.Error.to_string e)
41
42(* COSE Algorithms - RFC 9053 *)
43
44module Algorithm = struct
45 type t =
46 | ES256
47 | ES384
48 | ES512
49 | EdDSA
50 | HMAC_256_64
51 | HMAC_256
52 | HMAC_384
53 | HMAC_512
54
55 let to_cose_int = function
56 | ES256 -> -7
57 | ES384 -> -35
58 | ES512 -> -36
59 | EdDSA -> -8
60 | HMAC_256_64 -> 4
61 | HMAC_256 -> 5
62 | HMAC_384 -> 6
63 | HMAC_512 -> 7
64
65 let of_cose_int = function
66 | -7 -> Ok ES256
67 | -35 -> Ok ES384
68 | -36 -> Ok ES512
69 | -8 -> Ok EdDSA
70 | 4 -> Ok HMAC_256_64
71 | 5 -> Ok HMAC_256
72 | 6 -> Ok HMAC_384
73 | 7 -> Ok HMAC_512
74 | n -> Error (Unsupported_algorithm (Printf.sprintf "COSE algorithm %d" n))
75
76 let to_string = function
77 | ES256 -> "ES256"
78 | ES384 -> "ES384"
79 | ES512 -> "ES512"
80 | EdDSA -> "EdDSA"
81 | HMAC_256_64 -> "HMAC 256/64"
82 | HMAC_256 -> "HMAC 256/256"
83 | HMAC_384 -> "HMAC 384/384"
84 | HMAC_512 -> "HMAC 512/512"
85
86 let all =
87 [ ES256; ES384; ES512; EdDSA; HMAC_256_64; HMAC_256; HMAC_384; HMAC_512 ]
88end
89
90(* COSE Key - RFC 9052 Section 7 *)
91
92module Cose_key = struct
93 type kty = Okp | Ec2 | Symmetric
94
95 (* COSE key labels *)
96 let label_kty = 1
97 let label_kid = 2
98 let label_alg = 3
99 let label_crv = -1
100 let label_x = -2
101 let label_y = -3
102 let label_d = -4
103 let label_k = -1 (* for symmetric *)
104
105 (* COSE key type values *)
106 let kty_okp = 1
107 let kty_ec2 = 2
108 let kty_symmetric = 4
109
110 (* COSE curve values *)
111 let crv_p256 = 1
112 let crv_p384 = 2
113 let crv_p521 = 3
114 let crv_ed25519 = 6
115
116 type key_data =
117 | Symmetric_key of { k : string }
118 | Ed25519_pub of { x : string }
119 | Ed25519_priv of { x : string; d : string }
120 | P256_pub of { x : string; y : string }
121 | P256_priv of { x : string; y : string; d : string }
122 | P384_pub of { x : string; y : string }
123 | P384_priv of { x : string; y : string; d : string }
124 | P521_pub of { x : string; y : string }
125 | P521_priv of { x : string; y : string; d : string }
126
127 type t = {
128 key_data : key_data;
129 kid : string option;
130 alg : Algorithm.t option;
131 }
132
133 let symmetric k = { key_data = Symmetric_key { k }; kid = None; alg = None }
134
135 let ed25519_pub x =
136 { key_data = Ed25519_pub { x }; kid = None; alg = Some Algorithm.EdDSA }
137
138 let ed25519_priv ~pub ~priv =
139 {
140 key_data = Ed25519_priv { x = pub; d = priv };
141 kid = None;
142 alg = Some Algorithm.EdDSA;
143 }
144
145 let p256_pub ~x ~y =
146 { key_data = P256_pub { x; y }; kid = None; alg = Some Algorithm.ES256 }
147
148 let p256_priv ~x ~y ~d =
149 { key_data = P256_priv { x; y; d }; kid = None; alg = Some Algorithm.ES256 }
150
151 let p384_pub ~x ~y =
152 { key_data = P384_pub { x; y }; kid = None; alg = Some Algorithm.ES384 }
153
154 let p384_priv ~x ~y ~d =
155 { key_data = P384_priv { x; y; d }; kid = None; alg = Some Algorithm.ES384 }
156
157 let p521_pub ~x ~y =
158 { key_data = P521_pub { x; y }; kid = None; alg = Some Algorithm.ES512 }
159
160 let p521_priv ~x ~y ~d =
161 { key_data = P521_priv { x; y; d }; kid = None; alg = Some Algorithm.ES512 }
162
163 let kty t =
164 match t.key_data with
165 | Symmetric_key _ -> Symmetric
166 | Ed25519_pub _ | Ed25519_priv _ -> Okp
167 | P256_pub _ | P256_priv _ | P384_pub _ | P384_priv _ | P521_pub _
168 | P521_priv _ ->
169 Ec2
170
171 let kid t = t.kid
172 let alg t = t.alg
173 let with_kid id t = { t with kid = Some id }
174 let with_alg a t = { t with alg = Some a }
175
176 (* Helper to build CBOR map pairs *)
177 let int_key k = Cbort.Cbor.Int (Z.of_int k)
178
179 (* CBOR encoding/decoding for COSE keys *)
180 let of_cbor bytes =
181 match Cbort.decode_string Cbort.any bytes with
182 | Error e -> Error (cbort_error_to_error e)
183 | Ok cbor ->
184 let find_int key = Cbort.Cbor.find (int_key key) cbor in
185 let find_bytes key =
186 match find_int key with
187 | Some (Cbort.Cbor.Bytes s) -> Some s
188 | _ -> None
189 in
190 (* kid can be Text or Bytes per RFC 9052 *)
191 let find_kid key =
192 match find_int key with
193 | Some (Cbort.Cbor.Bytes s) -> Some s
194 | Some (Cbort.Cbor.Text s) -> Some s
195 | _ -> None
196 in
197 let get_int_value = function
198 | Some (Cbort.Cbor.Int z) -> Some (Z.to_int z)
199 | _ -> None
200 in
201 let kty_val = get_int_value (find_int label_kty) in
202 let crv_val = get_int_value (find_int label_crv) in
203 let kid = find_kid label_kid in
204 let alg =
205 match get_int_value (find_int label_alg) with
206 | None -> None
207 | Some n -> (
208 match Algorithm.of_cose_int n with
209 | Ok a -> Some a
210 | Error _ -> None)
211 in
212 let x = find_bytes label_x in
213 let y = find_bytes label_y in
214 let d = find_bytes label_d in
215 let k = find_bytes label_k in
216 let key_data =
217 match (kty_val, crv_val, x, y, d, k) with
218 | Some 4, _, _, _, _, Some k -> Ok (Symmetric_key { k })
219 | Some 1, Some 6, Some x, _, None, _ -> Ok (Ed25519_pub { x })
220 | Some 1, Some 6, Some x, _, Some d, _ -> Ok (Ed25519_priv { x; d })
221 | Some 2, Some 1, Some x, Some y, None, _ -> Ok (P256_pub { x; y })
222 | Some 2, Some 1, Some x, Some y, Some d, _ ->
223 Ok (P256_priv { x; y; d })
224 | Some 2, Some 2, Some x, Some y, None, _ -> Ok (P384_pub { x; y })
225 | Some 2, Some 2, Some x, Some y, Some d, _ ->
226 Ok (P384_priv { x; y; d })
227 | Some 2, Some 3, Some x, Some y, None, _ -> Ok (P521_pub { x; y })
228 | Some 2, Some 3, Some x, Some y, Some d, _ ->
229 Ok (P521_priv { x; y; d })
230 | _ ->
231 Error (Invalid_cose "unsupported or invalid COSE key structure")
232 in
233 Result.map (fun key_data -> { key_data; kid; alg }) key_data
234
235 let to_cbor t =
236 let pairs = ref [] in
237 let add k v = pairs := (int_key k, v) :: !pairs in
238 let add_bytes k s = add k (Cbort.Cbor.Bytes s) in
239 let add_int k i = add k (Cbort.Cbor.Int (Z.of_int i)) in
240
241 (* kty - always present *)
242 (match t.key_data with
243 | Symmetric_key _ -> add_int label_kty kty_symmetric
244 | Ed25519_pub _ | Ed25519_priv _ -> add_int label_kty kty_okp
245 | _ -> add_int label_kty kty_ec2);
246
247 (* kid (optional) *)
248 Option.iter (fun kid -> add_bytes label_kid kid) t.kid;
249
250 (* alg (optional) *)
251 Option.iter (fun alg -> add_int label_alg (Algorithm.to_cose_int alg)) t.alg;
252
253 (* Key-type specific parameters *)
254 (match t.key_data with
255 | Symmetric_key { k } -> add_bytes label_k k
256 | Ed25519_pub { x } ->
257 add_int label_crv crv_ed25519;
258 add_bytes label_x x
259 | Ed25519_priv { x; d } ->
260 add_int label_crv crv_ed25519;
261 add_bytes label_x x;
262 add_bytes label_d d
263 | P256_pub { x; y } ->
264 add_int label_crv crv_p256;
265 add_bytes label_x x;
266 add_bytes label_y y
267 | P256_priv { x; y; d } ->
268 add_int label_crv crv_p256;
269 add_bytes label_x x;
270 add_bytes label_y y;
271 add_bytes label_d d
272 | P384_pub { x; y } ->
273 add_int label_crv crv_p384;
274 add_bytes label_x x;
275 add_bytes label_y y
276 | P384_priv { x; y; d } ->
277 add_int label_crv crv_p384;
278 add_bytes label_x x;
279 add_bytes label_y y;
280 add_bytes label_d d
281 | P521_pub { x; y } ->
282 add_int label_crv crv_p521;
283 add_bytes label_x x;
284 add_bytes label_y y
285 | P521_priv { x; y; d } ->
286 add_int label_crv crv_p521;
287 add_bytes label_x x;
288 add_bytes label_y y;
289 add_bytes label_d d);
290
291 Cbort.encode_string Cbort.any (Cbort.Cbor.Map (List.rev !pairs))
292end
293
294(* CWT Claims - RFC 8392 Section 3 *)
295
296module Claims = struct
297 (* Claim keys (integers per RFC 8392) *)
298 let key_iss = 1
299 let key_sub = 2
300 let key_aud = 3
301 let key_exp = 4
302 let key_nbf = 5
303 let key_iat = 6
304 let key_cti = 7
305
306 type claim_key = Int_key of int | String_key of string
307
308 type t = {
309 iss : string option;
310 sub : string option;
311 aud : string list;
312 exp : Ptime.t option;
313 nbf : Ptime.t option;
314 iat : Ptime.t option;
315 cti : string option;
316 custom : (claim_key * Cbort.Cbor.t) list;
317 }
318
319 let iss t = t.iss
320 let sub t = t.sub
321 let aud t = t.aud
322 let exp t = t.exp
323 let nbf t = t.nbf
324 let iat t = t.iat
325 let cti t = t.cti
326
327 let get_int_key key t =
328 List.find_map
329 (function Int_key k, v when k = key -> Some v | _ -> None)
330 t.custom
331
332 let get_string_key key t =
333 List.find_map
334 (function String_key k, v when k = key -> Some v | _ -> None)
335 t.custom
336
337 type builder = t
338
339 let empty =
340 {
341 iss = None;
342 sub = None;
343 aud = [];
344 exp = None;
345 nbf = None;
346 iat = None;
347 cti = None;
348 custom = [];
349 }
350
351 let set_iss v t = { t with iss = Some v }
352 let set_sub v t = { t with sub = Some v }
353 let set_aud v t = { t with aud = v }
354 let set_exp v t = { t with exp = Some v }
355 let set_nbf v t = { t with nbf = Some v }
356 let set_iat v t = { t with iat = Some v }
357 let set_cti v t = { t with cti = Some v }
358
359 let set_int_key key value t =
360 { t with custom = (Int_key key, value) :: t.custom }
361
362 let set_string_key key value t =
363 { t with custom = (String_key key, value) :: t.custom }
364
365 let build t = t
366
367 (* Standard claim keys *)
368 let standard_keys =
369 [ key_iss; key_sub; key_aud; key_exp; key_nbf; key_iat; key_cti ]
370
371 (* Helper to convert claim_key to CBOR *)
372 let claim_key_to_cbor = function
373 | Int_key i -> Cbort.Cbor.Int (Z.of_int i)
374 | String_key s -> Cbort.Cbor.Text s
375
376 (* Helper to find value by integer key in CBOR map *)
377 let find_int_key key pairs =
378 let target = Cbort.Cbor.Int (Z.of_int key) in
379 List.find_map
380 (fun (k, v) -> if Cbort.Cbor.equal k target then Some v else None)
381 pairs
382
383 (* Helper to extract string from CBOR *)
384 let cbor_to_string = function Cbort.Cbor.Text s -> Some s | _ -> None
385
386 (* Helper to extract bytes from CBOR *)
387 let cbor_to_bytes = function Cbort.Cbor.Bytes s -> Some s | _ -> None
388
389 (* Helper to extract ptime from CBOR integer *)
390 let cbor_to_ptime = function
391 | Cbort.Cbor.Int z -> Ptime.of_float_s (Z.to_float z)
392 | _ -> None
393
394 (* Helper to extract audience (string or array of strings) *)
395 let cbor_to_aud = function
396 | Cbort.Cbor.Text s -> Some [ s ]
397 | Cbort.Cbor.Array items ->
398 let strings = List.filter_map cbor_to_string items in
399 if List.length strings = List.length items then Some strings else None
400 | _ -> None
401
402 (* Decode claims from CBOR map pairs *)
403 let decode_from_pairs pairs =
404 let iss = Option.bind (find_int_key key_iss pairs) cbor_to_string in
405 let sub = Option.bind (find_int_key key_sub pairs) cbor_to_string in
406 let aud =
407 Option.value ~default:[]
408 (Option.bind (find_int_key key_aud pairs) cbor_to_aud)
409 in
410 let exp = Option.bind (find_int_key key_exp pairs) cbor_to_ptime in
411 let nbf = Option.bind (find_int_key key_nbf pairs) cbor_to_ptime in
412 let iat = Option.bind (find_int_key key_iat pairs) cbor_to_ptime in
413 let cti = Option.bind (find_int_key key_cti pairs) cbor_to_bytes in
414 (* Collect custom claims (non-standard keys) *)
415 let custom =
416 List.filter_map
417 (fun (k, v) ->
418 match k with
419 | Cbort.Cbor.Int z ->
420 let i = Z.to_int z in
421 if List.mem i standard_keys then None else Some (Int_key i, v)
422 | Cbort.Cbor.Text s -> Some (String_key s, v)
423 | _ -> None)
424 pairs
425 in
426 { iss; sub; aud; exp; nbf; iat; cti; custom }
427
428 (* Encode claims to CBOR map pairs *)
429 let encode_to_pairs t =
430 let open Cbort.Cbor in
431 let pairs = ref [] in
432 let add_int k v = pairs := (Int (Z.of_int k), v) :: !pairs in
433 (* Standard claims *)
434 Option.iter (fun v -> add_int key_iss (Text v)) t.iss;
435 Option.iter (fun v -> add_int key_sub (Text v)) t.sub;
436 (match t.aud with
437 | [] -> ()
438 | [ s ] -> add_int key_aud (Text s)
439 | lst -> add_int key_aud (Array (List.map (fun s -> Text s) lst)));
440 Option.iter
441 (fun v -> add_int key_exp (Int (Z.of_float (Ptime.to_float_s v))))
442 t.exp;
443 Option.iter
444 (fun v -> add_int key_nbf (Int (Z.of_float (Ptime.to_float_s v))))
445 t.nbf;
446 Option.iter
447 (fun v -> add_int key_iat (Int (Z.of_float (Ptime.to_float_s v))))
448 t.iat;
449 Option.iter (fun v -> add_int key_cti (Bytes v)) t.cti;
450 (* Custom claims *)
451 List.iter
452 (fun (k, v) -> pairs := (claim_key_to_cbor k, v) :: !pairs)
453 t.custom;
454 List.rev !pairs
455
456 let claims_not_map_error = "claims must be a CBOR map"
457
458 (** Full codec for claims including custom claims *)
459 let codec : t Cbort.t =
460 Cbort.conv
461 (fun cbor ->
462 match cbor with
463 | Cbort.Cbor.Map pairs -> Ok (decode_from_pairs pairs)
464 | _ -> Error claims_not_map_error)
465 (fun t -> Cbort.Cbor.Map (encode_to_pairs t))
466 Cbort.any
467
468 let of_cbor bytes =
469 match Cbort.decode_string codec bytes with
470 | Ok t -> Ok t
471 | Error e ->
472 (* Distinguish CBOR parse errors from claims structure errors *)
473 let msg = Cbort.Error.to_string e in
474 if msg = claims_not_map_error then Error (Invalid_claims msg)
475 else Error (Invalid_cbor msg)
476
477 let to_cbor t = Cbort.encode_string codec t
478end
479
480(* CWT Token *)
481
482(* COSE tags *)
483let cose_sign1_tag = 18
484let cose_mac0_tag = 17
485
486(* COSE header labels *)
487let header_alg = 1
488let header_kid = 4
489
490type t = {
491 claims : Claims.t;
492 algorithm : Algorithm.t option;
493 kid : string option;
494 protected_header : string; (* CBOR-encoded protected header *)
495 signature : string; (* Signature or MAC tag *)
496 raw : string; (* Original CBOR bytes *)
497}
498
499let claims t = t.claims
500let algorithm t = t.algorithm
501let kid t = t.kid
502let raw t = t.raw
503
504(** Extract kid from header - can be Text or Bytes per RFC 9052 *)
505let extract_kid_from_header pairs =
506 let kid_key = Cbort.Cbor.Int (Z.of_int header_kid) in
507 List.find_map
508 (fun (k, v) ->
509 if Cbort.Cbor.equal k kid_key then
510 match v with
511 | Cbort.Cbor.Bytes s -> Some s
512 | Cbort.Cbor.Text s -> Some s
513 | _ -> None
514 else None)
515 pairs
516
517(** Decode protected header to extract algorithm and kid *)
518let decode_protected_header bytes =
519 match Cbort.decode_string Cbort.any bytes with
520 | Error _ -> (None, None)
521 | Ok (Cbort.Cbor.Map pairs) ->
522 let alg_key = Cbort.Cbor.Int (Z.of_int header_alg) in
523 let alg_int =
524 List.find_map
525 (fun (k, v) ->
526 if Cbort.Cbor.equal k alg_key then
527 match v with Cbort.Cbor.Int z -> Some (Z.to_int z) | _ -> None
528 else None)
529 pairs
530 in
531 let algorithm =
532 Option.bind alg_int (fun n ->
533 match Algorithm.of_cose_int n with
534 | Ok alg -> Some alg
535 | Error _ -> None)
536 in
537 let kid = extract_kid_from_header pairs in
538 (algorithm, kid)
539 | Ok _ -> (None, None)
540
541(** Extract kid from unprotected header if present *)
542let decode_unprotected_header cbor =
543 match cbor with
544 | Cbort.Cbor.Map pairs -> extract_kid_from_header pairs
545 | _ -> None
546
547let parse bytes =
548 match Cbort.decode_string Cbort.any bytes with
549 | Error e -> Error (cbort_error_to_error e)
550 | Ok cbor -> (
551 (* Handle optional COSE tag and extract the array *)
552 let cose_array =
553 match cbor with
554 | Cbort.Cbor.Tag (18, arr) -> Some arr (* COSE_Sign1 *)
555 | Cbort.Cbor.Tag (17, arr) -> Some arr (* COSE_Mac0 *)
556 | Cbort.Cbor.Array _ as arr -> Some arr (* Untagged *)
557 | _ -> None
558 in
559 match cose_array with
560 | None ->
561 Error (Invalid_cose "expected COSE_Sign1 or COSE_Mac0 structure")
562 | Some
563 (Cbort.Cbor.Array
564 [ protected_bstr; unprotected; payload_bstr; sig_bstr ]) -> (
565 (* Extract byte strings *)
566 let protected_header =
567 match protected_bstr with Cbort.Cbor.Bytes s -> Some s | _ -> None
568 in
569 let signature =
570 match sig_bstr with Cbort.Cbor.Bytes s -> Some s | _ -> None
571 in
572 match (protected_header, signature) with
573 | Some protected_header, Some signature -> (
574 (* Decode protected header for algorithm and kid *)
575 let algorithm, protected_kid =
576 decode_protected_header protected_header
577 in
578 (* Decode unprotected header for kid - prefer unprotected over protected *)
579 let unprotected_kid = decode_unprotected_header unprotected in
580 let kid =
581 match unprotected_kid with
582 | Some _ -> unprotected_kid
583 | None -> protected_kid
584 in
585 (* Decode claims from payload - handle detached payloads *)
586 match payload_bstr with
587 | Cbort.Cbor.Null ->
588 (* Detached payload: not currently supported *)
589 Error (Invalid_cose "detached payloads are not supported")
590 | Cbort.Cbor.Bytes payload -> (
591 match Claims.of_cbor payload with
592 | Error e -> Error e
593 | Ok claims ->
594 Ok
595 {
596 claims;
597 algorithm;
598 kid;
599 protected_header;
600 signature;
601 raw = bytes;
602 })
603 | _ ->
604 Error (Invalid_cose "payload must be a byte string or null"))
605 | _ -> Error (Invalid_cose "invalid COSE structure fields"))
606 | Some (Cbort.Cbor.Array _) ->
607 Error (Invalid_cose "COSE structure must have exactly 4 elements")
608 | Some _ -> Error (Invalid_cose "expected COSE array structure"))
609
610(* Cryptographic operations *)
611
612let hmac_sign alg key payload =
613 let module Hash = Digestif in
614 match alg with
615 | Algorithm.HMAC_256_64 ->
616 let mac = Hash.SHA256.hmac_string ~key payload in
617 Ok (String.sub (Hash.SHA256.to_raw_string mac) 0 8)
618 | Algorithm.HMAC_256 ->
619 let mac = Hash.SHA256.hmac_string ~key payload in
620 Ok (Hash.SHA256.to_raw_string mac)
621 | Algorithm.HMAC_384 ->
622 let mac = Hash.SHA384.hmac_string ~key payload in
623 Ok (Hash.SHA384.to_raw_string mac)
624 | Algorithm.HMAC_512 ->
625 let mac = Hash.SHA512.hmac_string ~key payload in
626 Ok (Hash.SHA512.to_raw_string mac)
627 | _ -> Error (Key_type_mismatch "Not an HMAC algorithm")
628
629let hmac_verify alg key payload expected_mac =
630 match hmac_sign alg key payload with
631 | Error _ -> false
632 | Ok computed -> Eqaf.equal computed expected_mac
633
634let p256_sign ~priv payload =
635 match Mirage_crypto_ec.P256.Dsa.priv_of_octets priv with
636 | Error _ -> Error (Key_type_mismatch "Invalid P-256 private key")
637 | Ok priv ->
638 let hash = Digestif.SHA256.(digest_string payload |> to_raw_string) in
639 let r, s = Mirage_crypto_ec.P256.Dsa.sign ~key:priv hash in
640 let pad32 s =
641 let len = String.length s in
642 if len >= 32 then String.sub s (len - 32) 32
643 else String.make (32 - len) '\x00' ^ s
644 in
645 Ok (pad32 r ^ pad32 s)
646
647let p384_sign ~priv payload =
648 match Mirage_crypto_ec.P384.Dsa.priv_of_octets priv with
649 | Error _ -> Error (Key_type_mismatch "Invalid P-384 private key")
650 | Ok priv ->
651 let hash = Digestif.SHA384.(digest_string payload |> to_raw_string) in
652 let r, s = Mirage_crypto_ec.P384.Dsa.sign ~key:priv hash in
653 let pad48 s =
654 let len = String.length s in
655 if len >= 48 then String.sub s (len - 48) 48
656 else String.make (48 - len) '\x00' ^ s
657 in
658 Ok (pad48 r ^ pad48 s)
659
660let p521_sign ~priv payload =
661 match Mirage_crypto_ec.P521.Dsa.priv_of_octets priv with
662 | Error _ -> Error (Key_type_mismatch "Invalid P-521 private key")
663 | Ok priv ->
664 let hash = Digestif.SHA512.(digest_string payload |> to_raw_string) in
665 let r, s = Mirage_crypto_ec.P521.Dsa.sign ~key:priv hash in
666 let pad66 s =
667 let len = String.length s in
668 if len >= 66 then String.sub s (len - 66) 66
669 else String.make (66 - len) '\x00' ^ s
670 in
671 Ok (pad66 r ^ pad66 s)
672
673let ed25519_sign ~priv payload =
674 match Mirage_crypto_ec.Ed25519.priv_of_octets priv with
675 | Error _ -> Error (Key_type_mismatch "Invalid Ed25519 private key")
676 | Ok priv -> Ok (Mirage_crypto_ec.Ed25519.sign ~key:priv payload)
677
678(** Build Sig_structure or MAC_structure for COSE operations *)
679let build_sig_structure ~context_string ~protected_header ~payload =
680 let open Cbort.Cbor in
681 Array
682 [
683 Text context_string;
684 Bytes protected_header;
685 Bytes "";
686 (* external_aad = empty *)
687 Bytes payload;
688 ]
689 |> Cbort.encode_string Cbort.any
690
691(** Expected signature/MAC length for each algorithm *)
692let expected_sig_length = function
693 | Algorithm.ES256 -> 64 (* 32 + 32 *)
694 | Algorithm.ES384 -> 96 (* 48 + 48 *)
695 | Algorithm.ES512 -> 132 (* 66 + 66 *)
696 | Algorithm.EdDSA -> 64
697 | Algorithm.HMAC_256_64 -> 8
698 | Algorithm.HMAC_256 -> 32
699 | Algorithm.HMAC_384 -> 48
700 | Algorithm.HMAC_512 -> 64
701
702let verify ~key ?allowed_algs t =
703 (* Check algorithm is allowed *)
704 let alg =
705 match t.algorithm with
706 | None -> Error (Invalid_cose "No algorithm in protected header")
707 | Some a -> Ok a
708 in
709 match alg with
710 | Error e -> Error e
711 | Ok alg ->
712 let allowed =
713 match allowed_algs with None -> Algorithm.all | Some l -> l
714 in
715 if not (List.mem alg allowed) then
716 Error (Algorithm_not_allowed (Algorithm.to_string alg))
717 else
718 (* Validate signature length before attempting to parse it *)
719 let expected_len = expected_sig_length alg in
720 let actual_len = String.length t.signature in
721 if actual_len <> expected_len then
722 Error
723 (Invalid_cose
724 (Printf.sprintf "signature length mismatch: expected %d, got %d"
725 expected_len actual_len))
726 else
727 (* Build Sig_structure or MAC_structure for verification *)
728 let context_string =
729 match alg with
730 | Algorithm.HMAC_256_64 | Algorithm.HMAC_256 | Algorithm.HMAC_384
731 | Algorithm.HMAC_512 ->
732 "MAC0"
733 | _ -> "Signature1"
734 in
735 let payload = Claims.to_cbor t.claims in
736 let sig_structure =
737 build_sig_structure ~context_string
738 ~protected_header:t.protected_header ~payload
739 in
740 (* Verify based on algorithm - returns Result to distinguish key mismatch from sig failure *)
741 let verify_result =
742 match (alg, key.Cose_key.key_data) with
743 | ( ( Algorithm.HMAC_256_64 | Algorithm.HMAC_256
744 | Algorithm.HMAC_384 | Algorithm.HMAC_512 ),
745 Cose_key.Symmetric_key { k } ) ->
746 if hmac_verify alg k sig_structure t.signature then Ok ()
747 else Error Signature_mismatch
748 | ( Algorithm.EdDSA,
749 (Cose_key.Ed25519_pub { x } | Cose_key.Ed25519_priv { x; _ }) )
750 -> (
751 match Mirage_crypto_ec.Ed25519.pub_of_octets x with
752 | Ok pub ->
753 if
754 Mirage_crypto_ec.Ed25519.verify ~key:pub t.signature
755 ~msg:sig_structure
756 then Ok ()
757 else Error Signature_mismatch
758 | Error _ ->
759 Error (Key_type_mismatch "Invalid Ed25519 public key"))
760 | ( Algorithm.ES256,
761 (Cose_key.P256_pub { x; y } | Cose_key.P256_priv { x; y; _ }) )
762 -> (
763 match
764 Mirage_crypto_ec.P256.Dsa.pub_of_octets ("\x04" ^ x ^ y)
765 with
766 | Ok pub ->
767 let hash =
768 Digestif.SHA256.(
769 digest_string sig_structure |> to_raw_string)
770 in
771 let r = String.sub t.signature 0 32 in
772 let s = String.sub t.signature 32 32 in
773 if Mirage_crypto_ec.P256.Dsa.verify ~key:pub (r, s) hash
774 then Ok ()
775 else Error Signature_mismatch
776 | Error _ ->
777 Error (Key_type_mismatch "Invalid P-256 public key"))
778 | ( Algorithm.ES384,
779 (Cose_key.P384_pub { x; y } | Cose_key.P384_priv { x; y; _ }) )
780 -> (
781 match
782 Mirage_crypto_ec.P384.Dsa.pub_of_octets ("\x04" ^ x ^ y)
783 with
784 | Ok pub ->
785 let hash =
786 Digestif.SHA384.(
787 digest_string sig_structure |> to_raw_string)
788 in
789 let r = String.sub t.signature 0 48 in
790 let s = String.sub t.signature 48 48 in
791 if Mirage_crypto_ec.P384.Dsa.verify ~key:pub (r, s) hash
792 then Ok ()
793 else Error Signature_mismatch
794 | Error _ ->
795 Error (Key_type_mismatch "Invalid P-384 public key"))
796 | ( Algorithm.ES512,
797 (Cose_key.P521_pub { x; y } | Cose_key.P521_priv { x; y; _ }) )
798 -> (
799 match
800 Mirage_crypto_ec.P521.Dsa.pub_of_octets ("\x04" ^ x ^ y)
801 with
802 | Ok pub ->
803 let hash =
804 Digestif.SHA512.(
805 digest_string sig_structure |> to_raw_string)
806 in
807 let r = String.sub t.signature 0 66 in
808 let s = String.sub t.signature 66 66 in
809 if Mirage_crypto_ec.P521.Dsa.verify ~key:pub (r, s) hash
810 then Ok ()
811 else Error Signature_mismatch
812 | Error _ ->
813 Error (Key_type_mismatch "Invalid P-521 public key"))
814 | _ ->
815 Error
816 (Key_type_mismatch
817 (Printf.sprintf "Key type doesn't match algorithm %s"
818 (Algorithm.to_string alg)))
819 in
820 verify_result
821
822let validate ~now ?iss ?aud ?leeway t =
823 let leeway = Option.value leeway ~default:Ptime.Span.zero in
824 (* Check exp *)
825 let check_exp () =
826 match t.claims.exp with
827 | Some exp -> (
828 match Ptime.add_span exp leeway with
829 | Some exp' when Ptime.is_later now ~than:exp' -> Error Token_expired
830 | _ -> Ok ())
831 | None -> Ok ()
832 in
833 (* Check nbf *)
834 let check_nbf () =
835 match t.claims.nbf with
836 | Some nbf -> (
837 match Ptime.sub_span nbf leeway with
838 | Some nbf' when Ptime.is_earlier now ~than:nbf' ->
839 Error Token_not_yet_valid
840 | _ -> Ok ())
841 | None -> Ok ()
842 in
843 (* Check iss *)
844 let check_iss () =
845 match iss with
846 | Some expected_iss -> (
847 match t.claims.iss with
848 | Some actual_iss when actual_iss = expected_iss -> Ok ()
849 | _ -> Error Invalid_issuer)
850 | None -> Ok ()
851 in
852 (* Check aud *)
853 let check_aud () =
854 match aud with
855 | Some expected_aud ->
856 if List.mem expected_aud t.claims.aud then Ok ()
857 else Error Invalid_audience
858 | None -> Ok ()
859 in
860 match check_exp () with
861 | Error _ as e -> e
862 | Ok () -> (
863 match check_nbf () with
864 | Error _ as e -> e
865 | Ok () -> (
866 match check_iss () with Error _ as e -> e | Ok () -> check_aud ()))
867
868let verify_and_validate ~key ~now ?allowed_algs ?iss ?aud ?leeway t =
869 match verify ~key ?allowed_algs t with
870 | Error _ as e -> e
871 | Ok () -> validate ~now ?iss ?aud ?leeway t
872
873(** Encode protected header as CBOR map *)
874let encode_protected_header algorithm =
875 let open Cbort.Cbor in
876 Map
877 [
878 ( Int (Z.of_int header_alg),
879 Int (Z.of_int (Algorithm.to_cose_int algorithm)) );
880 ]
881 |> Cbort.encode_string Cbort.any
882
883(** Encode COSE_Sign1 or COSE_Mac0 structure *)
884let encode_cose_message ~cose_tag ~protected_header ~payload ~signature =
885 Cbort.Cbor.Tag
886 ( cose_tag,
887 Cbort.Cbor.Array
888 [
889 Cbort.Cbor.Bytes protected_header;
890 Cbort.Cbor.Map [];
891 (* unprotected header - empty *)
892 Cbort.Cbor.Bytes payload;
893 Cbort.Cbor.Bytes signature;
894 ] )
895 |> Cbort.encode_string Cbort.any
896
897let create ~algorithm ~claims ~key =
898 (* Encode protected header *)
899 let protected_header = encode_protected_header algorithm in
900
901 (* Build Sig_structure or MAC_structure *)
902 let context_string =
903 match algorithm with
904 | Algorithm.HMAC_256_64 | Algorithm.HMAC_256 | Algorithm.HMAC_384
905 | Algorithm.HMAC_512 ->
906 "MAC0"
907 | _ -> "Signature1"
908 in
909 let payload = Claims.to_cbor claims in
910 let to_be_signed =
911 build_sig_structure ~context_string ~protected_header ~payload
912 in
913
914 (* Sign or MAC *)
915 let signature_result =
916 match (algorithm, key.Cose_key.key_data) with
917 | ( ( Algorithm.HMAC_256_64 | Algorithm.HMAC_256 | Algorithm.HMAC_384
918 | Algorithm.HMAC_512 ),
919 Cose_key.Symmetric_key { k } ) ->
920 hmac_sign algorithm k to_be_signed
921 | Algorithm.EdDSA, Cose_key.Ed25519_priv { d; _ } ->
922 ed25519_sign ~priv:d to_be_signed
923 | Algorithm.ES256, Cose_key.P256_priv { d; _ } ->
924 p256_sign ~priv:d to_be_signed
925 | Algorithm.ES384, Cose_key.P384_priv { d; _ } ->
926 p384_sign ~priv:d to_be_signed
927 | Algorithm.ES512, Cose_key.P521_priv { d; _ } ->
928 p521_sign ~priv:d to_be_signed
929 | _ -> Error (Key_type_mismatch "Key type doesn't match algorithm")
930 in
931
932 match signature_result with
933 | Error e -> Error e
934 | Ok signature ->
935 (* Encode COSE_Sign1 or COSE_Mac0 structure *)
936 let cose_tag =
937 match algorithm with
938 | Algorithm.HMAC_256_64 | Algorithm.HMAC_256 | Algorithm.HMAC_384
939 | Algorithm.HMAC_512 ->
940 cose_mac0_tag
941 | _ -> cose_sign1_tag
942 in
943 let raw =
944 encode_cose_message ~cose_tag ~protected_header ~payload ~signature
945 in
946 Ok
947 {
948 claims;
949 algorithm = Some algorithm;
950 kid = key.Cose_key.kid;
951 protected_header;
952 signature;
953 raw;
954 }
955
956let encode t = t.raw
957
958let is_expired ~now ?leeway t =
959 match t.claims.exp with
960 | None -> false
961 | Some exp -> (
962 let leeway = Option.value leeway ~default:Ptime.Span.zero in
963 match Ptime.add_span exp leeway with
964 | Some exp' -> Ptime.is_later now ~than:exp'
965 | None -> true)
966
967let time_to_expiry ~now t =
968 match t.claims.exp with
969 | None -> None
970 | Some exp ->
971 let diff = Ptime.diff exp now in
972 if Ptime.Span.compare diff Ptime.Span.zero <= 0 then None else Some diff