anil.recoil.org
My aggregated monorepo of OCaml code, automaintained
Merge commit 'edce7440de20f8ef44de0df727cf5b9f8853bde0'
+15
ocaml-jsonwt/fuzz/dune
+15
ocaml-jsonwt/fuzz/dune
···
···
1
+
; Crowbar fuzz testing for jsonwt
2
+
;
3
+
; To run: dune exec ocaml-jsonwt/fuzz/fuzz_jsonwt.exe
4
+
; With AFL: afl-fuzz -i fuzz/corpus -o fuzz/findings -- ./_build/default/ocaml-jsonwt/fuzz/fuzz_jsonwt.exe @@
5
+
6
+
(executable
7
+
(name fuzz_jsonwt)
8
+
(modules fuzz_jsonwt)
9
+
(libraries jsonwt crowbar))
10
+
11
+
(rule
12
+
(alias fuzz)
13
+
(deps fuzz_jsonwt.exe)
14
+
(action
15
+
(run %{exe:fuzz_jsonwt.exe})))
+95
ocaml-jsonwt/fuzz/fuzz_jsonwt.ml
+95
ocaml-jsonwt/fuzz/fuzz_jsonwt.ml
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Crowbar-based fuzz testing for JWT parsing *)
7
+
8
+
open Crowbar
9
+
10
+
(* Test that JWT parsing never crashes on arbitrary input *)
11
+
let test_parse_no_crash input =
12
+
let _ = Jsonwt.parse input in
13
+
()
14
+
15
+
(* Test that JWT parsing in unsafe mode never crashes *)
16
+
let test_parse_unsafe_no_crash input =
17
+
let _ = Jsonwt.parse_unsafe input in
18
+
()
19
+
20
+
(* Test that nested JWT parsing never crashes *)
21
+
let test_parse_nested_no_crash input =
22
+
let _ = Jsonwt.parse_nested input in
23
+
()
24
+
25
+
(* Test header parsing never crashes *)
26
+
let test_header_parse_no_crash input =
27
+
let _ = Jsonwt.Header.of_json input in
28
+
()
29
+
30
+
(* Test claims parsing never crashes *)
31
+
let test_claims_parse_no_crash input =
32
+
let _ = Jsonwt.Claims.of_json input in
33
+
()
34
+
35
+
(* Test JWK parsing never crashes *)
36
+
let test_jwk_parse_no_crash input =
37
+
let _ = Jsonwt.Jwk.of_json input in
38
+
()
39
+
40
+
(* Test algorithm parsing never crashes *)
41
+
let test_algorithm_parse_no_crash input =
42
+
let _ = Jsonwt.Algorithm.of_string input in
43
+
()
44
+
45
+
(* Test base64url-like inputs (dots are JWT separators) *)
46
+
let test_jwt_structure input1 input2 input3 =
47
+
let token = input1 ^ "." ^ input2 ^ "." ^ input3 in
48
+
let _ = Jsonwt.parse token in
49
+
()
50
+
51
+
(* Test error printing never crashes *)
52
+
let () =
53
+
let errors =
54
+
[
55
+
Jsonwt.Invalid_json "test";
56
+
Jsonwt.Invalid_base64url "test";
57
+
Jsonwt.Invalid_structure "test";
58
+
Jsonwt.Invalid_header "test";
59
+
Jsonwt.Invalid_claims "test";
60
+
Jsonwt.Invalid_uri "test";
61
+
Jsonwt.Duplicate_claim "test";
62
+
Jsonwt.Unsupported_algorithm "test";
63
+
Jsonwt.Algorithm_not_allowed "test";
64
+
Jsonwt.Signature_mismatch;
65
+
Jsonwt.Token_expired;
66
+
Jsonwt.Token_not_yet_valid;
67
+
Jsonwt.Invalid_issuer;
68
+
Jsonwt.Invalid_audience;
69
+
Jsonwt.Key_type_mismatch "test";
70
+
Jsonwt.Unsecured_not_allowed;
71
+
Jsonwt.Nesting_too_deep;
72
+
]
73
+
in
74
+
List.iter
75
+
(fun e ->
76
+
let _ = Format.asprintf "%a" Jsonwt.pp_error e in
77
+
let _ = Jsonwt.error_to_string e in
78
+
())
79
+
errors
80
+
81
+
let () =
82
+
add_test ~name:"jwt: parse no crash" [ bytes ] test_parse_no_crash;
83
+
add_test ~name:"jwt: parse_unsafe no crash" [ bytes ]
84
+
test_parse_unsafe_no_crash;
85
+
add_test ~name:"jwt: parse_nested no crash" [ bytes ]
86
+
test_parse_nested_no_crash;
87
+
add_test ~name:"jwt: header parse no crash" [ bytes ]
88
+
test_header_parse_no_crash;
89
+
add_test ~name:"jwt: claims parse no crash" [ bytes ]
90
+
test_claims_parse_no_crash;
91
+
add_test ~name:"jwt: jwk parse no crash" [ bytes ] test_jwk_parse_no_crash;
92
+
add_test ~name:"jwt: algorithm parse no crash" [ bytes ]
93
+
test_algorithm_parse_no_crash;
94
+
add_test ~name:"jwt: structured input" [ bytes; bytes; bytes ]
95
+
test_jwt_structure
+383
-308
ocaml-jsonwt/lib/cwt.ml
+383
-308
ocaml-jsonwt/lib/cwt.ml
···
33
| Invalid_audience -> Format.fprintf ppf "Invalid audience"
34
| Key_type_mismatch s -> Format.fprintf ppf "Key type mismatch: %s" s
35
36
-
let error_to_string e =
37
-
Format.asprintf "%a" pp_error e
38
39
(* Cbort codec helpers *)
40
41
-
let cbort_error_to_error e =
42
-
Invalid_cbor (Cbort.Error.to_string e)
43
44
(* COSE Algorithms - RFC 9053 *)
45
···
85
| HMAC_384 -> "HMAC 384/384"
86
| HMAC_512 -> "HMAC 512/512"
87
88
-
let all = [ES256; ES384; ES512; EdDSA; HMAC_256_64; HMAC_256; HMAC_384; HMAC_512]
89
end
90
91
(* COSE Key - RFC 9052 Section 7 *)
92
93
module Cose_key = struct
94
-
type kty =
95
-
| Okp
96
-
| Ec2
97
-
| Symmetric
98
99
(* COSE key labels *)
100
let label_kty = 1
···
104
let label_x = -2
105
let label_y = -3
106
let label_d = -4
107
-
let label_k = -1 (* for symmetric *)
108
109
(* COSE key type values *)
110
let kty_okp = 1
···
134
alg : Algorithm.t option;
135
}
136
137
-
let symmetric k =
138
-
{ key_data = Symmetric_key { k }; kid = None; alg = None }
139
140
let ed25519_pub x =
141
{ key_data = Ed25519_pub { x }; kid = None; alg = Some Algorithm.EdDSA }
142
143
let ed25519_priv ~pub ~priv =
144
-
{ key_data = Ed25519_priv { x = pub; d = priv }; kid = None; alg = Some Algorithm.EdDSA }
145
146
let p256_pub ~x ~y =
147
{ key_data = P256_pub { x; y }; kid = None; alg = Some Algorithm.ES256 }
···
165
match t.key_data with
166
| Symmetric_key _ -> Symmetric
167
| Ed25519_pub _ | Ed25519_priv _ -> Okp
168
-
| P256_pub _ | P256_priv _ | P384_pub _ | P384_priv _ | P521_pub _ | P521_priv _ -> Ec2
169
170
let kid t = t.kid
171
let alg t = t.alg
172
-
173
let with_kid id t = { t with kid = Some id }
174
let with_alg a t = { t with alg = Some a }
175
···
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 = match get_int_value (find_int label_alg) with
205
| None -> None
206
-
| Some n -> (match Algorithm.of_cose_int n with Ok a -> Some a | Error _ -> None)
207
in
208
let x = find_bytes label_x in
209
let y = find_bytes label_y in
210
let d = find_bytes label_d in
211
let k = find_bytes label_k in
212
-
let key_data = match kty_val, crv_val, x, y, d, k with
213
| Some 4, _, _, _, _, Some k -> Ok (Symmetric_key { k })
214
| Some 1, Some 6, Some x, _, None, _ -> Ok (Ed25519_pub { x })
215
| Some 1, Some 6, Some x, _, Some d, _ -> Ok (Ed25519_priv { x; d })
216
| Some 2, Some 1, Some x, Some y, None, _ -> Ok (P256_pub { x; y })
217
-
| Some 2, Some 1, Some x, Some y, Some d, _ -> Ok (P256_priv { x; y; d })
218
| Some 2, Some 2, Some x, Some y, None, _ -> Ok (P384_pub { x; y })
219
-
| Some 2, Some 2, Some x, Some y, Some d, _ -> Ok (P384_priv { x; y; d })
220
| Some 2, Some 3, Some x, Some y, None, _ -> Ok (P521_pub { x; y })
221
-
| Some 2, Some 3, Some x, Some y, Some d, _ -> Ok (P521_priv { x; y; d })
222
-
| _ -> Error (Invalid_cose "unsupported or invalid COSE key structure")
223
in
224
Result.map (fun key_data -> { key_data; kid; alg }) key_data
225
···
231
232
(* kty - always present *)
233
(match t.key_data with
234
-
| Symmetric_key _ -> add_int label_kty kty_symmetric
235
-
| Ed25519_pub _ | Ed25519_priv _ -> add_int label_kty kty_okp
236
-
| _ -> add_int label_kty kty_ec2);
237
238
(* kid (optional) *)
239
Option.iter (fun kid -> add_bytes label_kid kid) t.kid;
···
243
244
(* Key-type specific parameters *)
245
(match t.key_data with
246
-
| Symmetric_key { k } ->
247
-
add_bytes label_k k
248
-
249
-
| Ed25519_pub { x } ->
250
-
add_int label_crv crv_ed25519;
251
-
add_bytes label_x x
252
-
253
-
| Ed25519_priv { x; d } ->
254
-
add_int label_crv crv_ed25519;
255
-
add_bytes label_x x;
256
-
add_bytes label_d d
257
-
258
-
| P256_pub { x; y } ->
259
-
add_int label_crv crv_p256;
260
-
add_bytes label_x x;
261
-
add_bytes label_y y
262
-
263
-
| P256_priv { x; y; d } ->
264
-
add_int label_crv crv_p256;
265
-
add_bytes label_x x;
266
-
add_bytes label_y y;
267
-
add_bytes label_d d
268
-
269
-
| P384_pub { x; y } ->
270
-
add_int label_crv crv_p384;
271
-
add_bytes label_x x;
272
-
add_bytes label_y y
273
-
274
-
| P384_priv { x; y; d } ->
275
-
add_int label_crv crv_p384;
276
-
add_bytes label_x x;
277
-
add_bytes label_y y;
278
-
add_bytes label_d d
279
-
280
-
| P521_pub { x; y } ->
281
-
add_int label_crv crv_p521;
282
-
add_bytes label_x x;
283
-
add_bytes label_y y
284
-
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))
292
end
···
303
let key_iat = 6
304
let key_cti = 7
305
306
-
type claim_key =
307
-
| Int_key of int
308
-
| String_key of string
309
310
type t = {
311
iss : string option;
···
327
let cti t = t.cti
328
329
let get_int_key key t =
330
-
List.find_map (function
331
-
| (Int_key k, v) when k = key -> Some v
332
-
| _ -> None
333
-
) t.custom
334
335
let get_string_key key t =
336
-
List.find_map (function
337
-
| (String_key k, v) when k = key -> Some v
338
-
| _ -> None
339
-
) t.custom
340
341
type builder = t
342
343
-
let empty = {
344
-
iss = None; sub = None; aud = []; exp = None;
345
-
nbf = None; iat = None; cti = None; custom = []
346
-
}
347
348
let set_iss v t = { t with iss = Some v }
349
let set_sub v t = { t with sub = Some v }
···
352
let set_nbf v t = { t with nbf = Some v }
353
let set_iat v t = { t with iat = Some v }
354
let set_cti v t = { t with cti = Some v }
355
-
let set_int_key key value t = { t with custom = (Int_key key, value) :: t.custom }
356
-
let set_string_key key value t = { t with custom = (String_key key, value) :: t.custom }
357
let build t = t
358
359
(* Standard claim keys *)
360
-
let standard_keys = [key_iss; key_sub; key_aud; key_exp; key_nbf; key_iat; key_cti]
361
362
(* Helper to convert claim_key to CBOR *)
363
let claim_key_to_cbor = function
···
367
(* Helper to find value by integer key in CBOR map *)
368
let find_int_key key pairs =
369
let target = Cbort.Cbor.Int (Z.of_int key) in
370
-
List.find_map (fun (k, v) ->
371
-
if Cbort.Cbor.equal k target then Some v else None
372
-
) pairs
373
374
(* Helper to extract string from CBOR *)
375
-
let cbor_to_string = function
376
-
| Cbort.Cbor.Text s -> Some s
377
-
| _ -> None
378
379
(* Helper to extract bytes from CBOR *)
380
-
let cbor_to_bytes = function
381
-
| Cbort.Cbor.Bytes s -> Some s
382
-
| _ -> None
383
384
(* Helper to extract ptime from CBOR integer *)
385
let cbor_to_ptime = function
386
-
| Cbort.Cbor.Int z ->
387
-
Ptime.of_float_s (Z.to_float z)
388
| _ -> None
389
390
(* Helper to extract audience (string or array of strings) *)
391
let cbor_to_aud = function
392
-
| Cbort.Cbor.Text s -> Some [s]
393
| Cbort.Cbor.Array items ->
394
let strings = List.filter_map cbor_to_string items in
395
-
if List.length strings = List.length items then Some strings
396
-
else None
397
| _ -> None
398
399
(* Decode claims from CBOR map pairs *)
400
let decode_from_pairs pairs =
401
let iss = Option.bind (find_int_key key_iss pairs) cbor_to_string in
402
let sub = Option.bind (find_int_key key_sub pairs) cbor_to_string in
403
-
let aud = Option.value ~default:[] (Option.bind (find_int_key key_aud pairs) cbor_to_aud) in
404
let exp = Option.bind (find_int_key key_exp pairs) cbor_to_ptime in
405
let nbf = Option.bind (find_int_key key_nbf pairs) cbor_to_ptime in
406
let iat = Option.bind (find_int_key key_iat pairs) cbor_to_ptime in
407
let cti = Option.bind (find_int_key key_cti pairs) cbor_to_bytes in
408
(* Collect custom claims (non-standard keys) *)
409
-
let custom = List.filter_map (fun (k, v) ->
410
-
match k with
411
-
| Cbort.Cbor.Int z ->
412
-
let i = Z.to_int z in
413
-
if List.mem i standard_keys then None
414
-
else Some (Int_key i, v)
415
-
| Cbort.Cbor.Text s -> Some (String_key s, v)
416
-
| _ -> None
417
-
) pairs in
418
{ iss; sub; aud; exp; nbf; iat; cti; custom }
419
420
(* Encode claims to CBOR map pairs *)
···
426
Option.iter (fun v -> add_int key_iss (Text v)) t.iss;
427
Option.iter (fun v -> add_int key_sub (Text v)) t.sub;
428
(match t.aud with
429
-
| [] -> ()
430
-
| [s] -> add_int key_aud (Text s)
431
-
| lst -> add_int key_aud (Array (List.map (fun s -> Text s) lst)));
432
-
Option.iter (fun v ->
433
-
add_int key_exp (Int (Z.of_float (Ptime.to_float_s v)))
434
-
) t.exp;
435
-
Option.iter (fun v ->
436
-
add_int key_nbf (Int (Z.of_float (Ptime.to_float_s v)))
437
-
) t.nbf;
438
-
Option.iter (fun v ->
439
-
add_int key_iat (Int (Z.of_float (Ptime.to_float_s v)))
440
-
) t.iat;
441
Option.iter (fun v -> add_int key_cti (Bytes v)) t.cti;
442
(* Custom claims *)
443
-
List.iter (fun (k, v) ->
444
-
pairs := (claim_key_to_cbor k, v) :: !pairs
445
-
) t.custom;
446
List.rev !pairs
447
448
let claims_not_map_error = "claims must be a CBOR map"
···
451
let codec : t Cbort.t =
452
Cbort.conv
453
(fun cbor ->
454
-
match cbor with
455
-
| Cbort.Cbor.Map pairs -> Ok (decode_from_pairs pairs)
456
-
| _ -> Error claims_not_map_error)
457
(fun t -> Cbort.Cbor.Map (encode_to_pairs t))
458
Cbort.any
459
···
463
| Error e ->
464
(* Distinguish CBOR parse errors from claims structure errors *)
465
let msg = Cbort.Error.to_string e in
466
-
if msg = claims_not_map_error then
467
-
Error (Invalid_claims msg)
468
-
else
469
-
Error (Invalid_cbor msg)
470
471
let to_cbor t = Cbort.encode_string codec t
472
end
···
485
claims : Claims.t;
486
algorithm : Algorithm.t option;
487
kid : string option;
488
-
protected_header : string; (* CBOR-encoded protected header *)
489
-
signature : string; (* Signature or MAC tag *)
490
-
raw : string; (* Original CBOR bytes *)
491
}
492
493
let claims t = t.claims
···
498
(** Extract kid from header - can be Text or Bytes per RFC 9052 *)
499
let extract_kid_from_header pairs =
500
let kid_key = Cbort.Cbor.Int (Z.of_int header_kid) in
501
-
List.find_map (fun (k, v) ->
502
-
if Cbort.Cbor.equal k kid_key then
503
-
match v with
504
-
| Cbort.Cbor.Bytes s -> Some s
505
-
| Cbort.Cbor.Text s -> Some s
506
-
| _ -> None
507
-
else None
508
-
) pairs
509
510
(** Decode protected header to extract algorithm and kid *)
511
let decode_protected_header bytes =
···
513
| Error _ -> (None, None)
514
| Ok (Cbort.Cbor.Map pairs) ->
515
let alg_key = Cbort.Cbor.Int (Z.of_int header_alg) in
516
-
let alg_int = List.find_map (fun (k, v) ->
517
-
if Cbort.Cbor.equal k alg_key then
518
-
match v with
519
-
| Cbort.Cbor.Int z -> Some (Z.to_int z)
520
-
| _ -> None
521
-
else None
522
-
) pairs in
523
-
let algorithm = Option.bind alg_int (fun n ->
524
-
match Algorithm.of_cose_int n with
525
-
| Ok alg -> Some alg
526
-
| Error _ -> None)
527
in
528
let kid = extract_kid_from_header pairs in
529
(algorithm, kid)
···
538
let parse bytes =
539
match Cbort.decode_string Cbort.any bytes with
540
| Error e -> Error (cbort_error_to_error e)
541
-
| Ok cbor ->
542
(* Handle optional COSE tag and extract the array *)
543
-
let cose_array = match cbor with
544
-
| Cbort.Cbor.Tag (18, arr) -> Some arr (* COSE_Sign1 *)
545
-
| Cbort.Cbor.Tag (17, arr) -> Some arr (* COSE_Mac0 *)
546
| Cbort.Cbor.Array _ as arr -> Some arr (* Untagged *)
547
| _ -> None
548
in
549
match cose_array with
550
-
| None -> Error (Invalid_cose "expected COSE_Sign1 or COSE_Mac0 structure")
551
-
| Some (Cbort.Cbor.Array [protected_bstr; unprotected; payload_bstr; sig_bstr]) ->
552
(* Extract byte strings *)
553
-
let protected_header = match protected_bstr with
554
-
| Cbort.Cbor.Bytes s -> Some s
555
-
| _ -> None
556
in
557
-
let signature = match sig_bstr with
558
-
| Cbort.Cbor.Bytes s -> Some s
559
-
| _ -> None
560
in
561
-
(match protected_header, signature with
562
-
| Some protected_header, Some signature ->
563
-
(* Decode protected header for algorithm and kid *)
564
-
let (algorithm, protected_kid) = decode_protected_header protected_header in
565
-
(* Decode unprotected header for kid - prefer unprotected over protected *)
566
-
let unprotected_kid = decode_unprotected_header unprotected in
567
-
let kid = match unprotected_kid with
568
-
| Some _ -> unprotected_kid
569
-
| None -> protected_kid
570
-
in
571
-
(* Decode claims from payload - handle detached payloads *)
572
-
(match payload_bstr with
573
-
| Cbort.Cbor.Null ->
574
-
(* Detached payload: not currently supported *)
575
-
Error (Invalid_cose "detached payloads are not supported")
576
-
| Cbort.Cbor.Bytes payload ->
577
-
(match Claims.of_cbor payload with
578
-
| Error e -> Error e
579
-
| Ok claims ->
580
-
Ok { claims; algorithm; kid; protected_header; signature; raw = bytes })
581
-
| _ -> Error (Invalid_cose "payload must be a byte string or null"))
582
-
| _ -> Error (Invalid_cose "invalid COSE structure fields"))
583
| Some (Cbort.Cbor.Array _) ->
584
Error (Invalid_cose "COSE structure must have exactly 4 elements")
585
-
| Some _ ->
586
-
Error (Invalid_cose "expected COSE array structure")
587
588
(* Cryptographic operations *)
589
···
614
| Error _ -> Error (Key_type_mismatch "Invalid P-256 private key")
615
| Ok priv ->
616
let hash = Digestif.SHA256.(digest_string payload |> to_raw_string) in
617
-
let (r, s) = Mirage_crypto_ec.P256.Dsa.sign ~key:priv hash in
618
let pad32 s =
619
let len = String.length s in
620
if len >= 32 then String.sub s (len - 32) 32
···
627
| Error _ -> Error (Key_type_mismatch "Invalid P-384 private key")
628
| Ok priv ->
629
let hash = Digestif.SHA384.(digest_string payload |> to_raw_string) in
630
-
let (r, s) = Mirage_crypto_ec.P384.Dsa.sign ~key:priv hash in
631
let pad48 s =
632
let len = String.length s in
633
if len >= 48 then String.sub s (len - 48) 48
···
640
| Error _ -> Error (Key_type_mismatch "Invalid P-521 private key")
641
| Ok priv ->
642
let hash = Digestif.SHA512.(digest_string payload |> to_raw_string) in
643
-
let (r, s) = Mirage_crypto_ec.P521.Dsa.sign ~key:priv hash in
644
let pad66 s =
645
let len = String.length s in
646
if len >= 66 then String.sub s (len - 66) 66
···
656
(** Build Sig_structure or MAC_structure for COSE operations *)
657
let build_sig_structure ~context_string ~protected_header ~payload =
658
let open Cbort.Cbor in
659
-
Array [
660
-
Text context_string;
661
-
Bytes protected_header;
662
-
Bytes ""; (* external_aad = empty *)
663
-
Bytes payload;
664
-
]
665
|> Cbort.encode_string Cbort.any
666
667
(** Expected signature/MAC length for each algorithm *)
668
let expected_sig_length = function
669
-
| Algorithm.ES256 -> 64 (* 32 + 32 *)
670
-
| Algorithm.ES384 -> 96 (* 48 + 48 *)
671
-
| Algorithm.ES512 -> 132 (* 66 + 66 *)
672
| Algorithm.EdDSA -> 64
673
| Algorithm.HMAC_256_64 -> 8
674
| Algorithm.HMAC_256 -> 32
···
677
678
let verify ~key ?allowed_algs t =
679
(* Check algorithm is allowed *)
680
-
let alg = match t.algorithm with
681
| None -> Error (Invalid_cose "No algorithm in protected header")
682
| Some a -> Ok a
683
in
684
match alg with
685
| Error e -> Error e
686
| Ok alg ->
687
-
let allowed = match allowed_algs with
688
-
| None -> Algorithm.all
689
-
| Some l -> l
690
in
691
if not (List.mem alg allowed) then
692
Error (Algorithm_not_allowed (Algorithm.to_string alg))
···
695
let expected_len = expected_sig_length alg in
696
let actual_len = String.length t.signature in
697
if actual_len <> expected_len then
698
-
Error (Invalid_cose (Printf.sprintf
699
-
"signature length mismatch: expected %d, got %d" expected_len actual_len))
700
else
701
(* Build Sig_structure or MAC_structure for verification *)
702
-
let context_string = match alg with
703
-
| Algorithm.HMAC_256_64 | Algorithm.HMAC_256
704
-
| Algorithm.HMAC_384 | Algorithm.HMAC_512 -> "MAC0"
705
| _ -> "Signature1"
706
in
707
let payload = Claims.to_cbor t.claims in
708
-
let sig_structure = build_sig_structure
709
-
~context_string ~protected_header:t.protected_header ~payload
710
in
711
(* Verify based on algorithm - returns Result to distinguish key mismatch from sig failure *)
712
-
let verify_result = match alg, key.Cose_key.key_data with
713
-
| (Algorithm.HMAC_256_64 | Algorithm.HMAC_256
714
-
| Algorithm.HMAC_384 | Algorithm.HMAC_512), Cose_key.Symmetric_key { k } ->
715
if hmac_verify alg k sig_structure t.signature then Ok ()
716
else Error Signature_mismatch
717
-
| Algorithm.EdDSA, (Cose_key.Ed25519_pub { x } | Cose_key.Ed25519_priv { x; _ }) ->
718
-
(match Mirage_crypto_ec.Ed25519.pub_of_octets x with
719
-
| Ok pub ->
720
-
if Mirage_crypto_ec.Ed25519.verify ~key:pub t.signature ~msg:sig_structure
721
-
then Ok ()
722
-
else Error Signature_mismatch
723
-
| Error _ -> Error (Key_type_mismatch "Invalid Ed25519 public key"))
724
-
| Algorithm.ES256, (Cose_key.P256_pub { x; y } | Cose_key.P256_priv { x; y; _ }) ->
725
-
(match Mirage_crypto_ec.P256.Dsa.pub_of_octets ("\x04" ^ x ^ y) with
726
-
| Ok pub ->
727
-
let hash = Digestif.SHA256.(digest_string sig_structure |> to_raw_string) in
728
-
let r = String.sub t.signature 0 32 in
729
-
let s = String.sub t.signature 32 32 in
730
-
if Mirage_crypto_ec.P256.Dsa.verify ~key:pub (r, s) hash
731
-
then Ok ()
732
-
else Error Signature_mismatch
733
-
| Error _ -> Error (Key_type_mismatch "Invalid P-256 public key"))
734
-
| Algorithm.ES384, (Cose_key.P384_pub { x; y } | Cose_key.P384_priv { x; y; _ }) ->
735
-
(match Mirage_crypto_ec.P384.Dsa.pub_of_octets ("\x04" ^ x ^ y) with
736
-
| Ok pub ->
737
-
let hash = Digestif.SHA384.(digest_string sig_structure |> to_raw_string) in
738
-
let r = String.sub t.signature 0 48 in
739
-
let s = String.sub t.signature 48 48 in
740
-
if Mirage_crypto_ec.P384.Dsa.verify ~key:pub (r, s) hash
741
-
then Ok ()
742
-
else Error Signature_mismatch
743
-
| Error _ -> Error (Key_type_mismatch "Invalid P-384 public key"))
744
-
| Algorithm.ES512, (Cose_key.P521_pub { x; y } | Cose_key.P521_priv { x; y; _ }) ->
745
-
(match Mirage_crypto_ec.P521.Dsa.pub_of_octets ("\x04" ^ x ^ y) with
746
-
| Ok pub ->
747
-
let hash = Digestif.SHA512.(digest_string sig_structure |> to_raw_string) in
748
-
let r = String.sub t.signature 0 66 in
749
-
let s = String.sub t.signature 66 66 in
750
-
if Mirage_crypto_ec.P521.Dsa.verify ~key:pub (r, s) hash
751
-
then Ok ()
752
-
else Error Signature_mismatch
753
-
| Error _ -> Error (Key_type_mismatch "Invalid P-521 public key"))
754
| _ ->
755
-
Error (Key_type_mismatch
756
-
(Printf.sprintf "Key type doesn't match algorithm %s"
757
-
(Algorithm.to_string alg)))
758
in
759
verify_result
760
···
763
(* Check exp *)
764
let check_exp () =
765
match t.claims.exp with
766
-
| Some exp ->
767
-
(match Ptime.add_span exp leeway with
768
-
| Some exp' when Ptime.is_later now ~than:exp' -> Error Token_expired
769
-
| _ -> Ok ())
770
| None -> Ok ()
771
in
772
(* Check nbf *)
773
let check_nbf () =
774
match t.claims.nbf with
775
-
| Some nbf ->
776
-
(match Ptime.sub_span nbf leeway with
777
-
| Some nbf' when Ptime.is_earlier now ~than:nbf' -> Error Token_not_yet_valid
778
-
| _ -> Ok ())
779
| None -> Ok ()
780
in
781
(* Check iss *)
782
let check_iss () =
783
match iss with
784
-
| Some expected_iss ->
785
-
(match t.claims.iss with
786
-
| Some actual_iss when actual_iss = expected_iss -> Ok ()
787
-
| _ -> Error Invalid_issuer)
788
| None -> Ok ()
789
in
790
(* Check aud *)
···
797
in
798
match check_exp () with
799
| Error _ as e -> e
800
-
| Ok () ->
801
match check_nbf () with
802
| Error _ as e -> e
803
-
| Ok () ->
804
-
match check_iss () with
805
-
| Error _ as e -> e
806
-
| Ok () -> check_aud ()
807
808
let verify_and_validate ~key ~now ?allowed_algs ?iss ?aud ?leeway t =
809
match verify ~key ?allowed_algs t with
···
813
(** Encode protected header as CBOR map *)
814
let encode_protected_header algorithm =
815
let open Cbort.Cbor in
816
-
Map [
817
-
(Int (Z.of_int header_alg), Int (Z.of_int (Algorithm.to_cose_int algorithm)));
818
-
]
819
|> Cbort.encode_string Cbort.any
820
821
(** Encode COSE_Sign1 or COSE_Mac0 structure *)
822
let encode_cose_message ~cose_tag ~protected_header ~payload ~signature =
823
-
Cbort.Cbor.Tag (cose_tag, Cbort.Cbor.Array [
824
-
Cbort.Cbor.Bytes protected_header;
825
-
Cbort.Cbor.Map []; (* unprotected header - empty *)
826
-
Cbort.Cbor.Bytes payload;
827
-
Cbort.Cbor.Bytes signature;
828
-
])
829
|> Cbort.encode_string Cbort.any
830
831
let create ~algorithm ~claims ~key =
···
833
let protected_header = encode_protected_header algorithm in
834
835
(* Build Sig_structure or MAC_structure *)
836
-
let context_string = match algorithm with
837
-
| Algorithm.HMAC_256_64 | Algorithm.HMAC_256
838
-
| Algorithm.HMAC_384 | Algorithm.HMAC_512 -> "MAC0"
839
| _ -> "Signature1"
840
in
841
let payload = Claims.to_cbor claims in
842
-
let to_be_signed = build_sig_structure ~context_string ~protected_header ~payload in
843
844
(* Sign or MAC *)
845
-
let signature_result = match algorithm, key.Cose_key.key_data with
846
-
| (Algorithm.HMAC_256_64 | Algorithm.HMAC_256
847
-
| Algorithm.HMAC_384 | Algorithm.HMAC_512), Cose_key.Symmetric_key { k } ->
848
hmac_sign algorithm k to_be_signed
849
| Algorithm.EdDSA, Cose_key.Ed25519_priv { d; _ } ->
850
ed25519_sign ~priv:d to_be_signed
···
854
p384_sign ~priv:d to_be_signed
855
| Algorithm.ES512, Cose_key.P521_priv { d; _ } ->
856
p521_sign ~priv:d to_be_signed
857
-
| _ ->
858
-
Error (Key_type_mismatch "Key type doesn't match algorithm")
859
in
860
861
match signature_result with
862
| Error e -> Error e
863
| Ok signature ->
864
(* Encode COSE_Sign1 or COSE_Mac0 structure *)
865
-
let cose_tag = match algorithm with
866
-
| Algorithm.HMAC_256_64 | Algorithm.HMAC_256
867
-
| Algorithm.HMAC_384 | Algorithm.HMAC_512 -> cose_mac0_tag
868
| _ -> cose_sign1_tag
869
in
870
-
let raw = encode_cose_message ~cose_tag ~protected_header ~payload ~signature in
871
-
Ok {
872
-
claims;
873
-
algorithm = Some algorithm;
874
-
kid = key.Cose_key.kid;
875
-
protected_header;
876
-
signature;
877
-
raw;
878
-
}
879
880
let encode t = t.raw
881
882
let is_expired ~now ?leeway t =
883
match t.claims.exp with
884
| None -> false
885
-
| Some exp ->
886
let leeway = Option.value leeway ~default:Ptime.Span.zero in
887
match Ptime.add_span exp leeway with
888
| Some exp' -> Ptime.is_later now ~than:exp'
889
-
| None -> true
890
891
let time_to_expiry ~now t =
892
match t.claims.exp with
893
| None -> None
894
| Some exp ->
895
let diff = Ptime.diff exp now in
896
-
if Ptime.Span.compare diff Ptime.Span.zero <= 0 then None
897
-
else Some diff
···
33
| Invalid_audience -> Format.fprintf ppf "Invalid audience"
34
| Key_type_mismatch s -> Format.fprintf ppf "Key type mismatch: %s" s
35
36
+
let error_to_string e = Format.asprintf "%a" pp_error e
37
38
(* Cbort codec helpers *)
39
40
+
let cbort_error_to_error e = Invalid_cbor (Cbort.Error.to_string e)
41
42
(* COSE Algorithms - RFC 9053 *)
43
···
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 ]
88
end
89
90
(* COSE Key - RFC 9052 Section 7 *)
91
92
module Cose_key = struct
93
+
type kty = Okp | Ec2 | Symmetric
94
95
(* COSE key labels *)
96
let label_kty = 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
···
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 }
···
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
···
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
···
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;
···
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))
292
end
···
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;
···
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 }
···
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
···
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 *)
···
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"
···
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
···
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
478
end
···
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
499
let claims t = t.claims
···
504
(** Extract kid from header - can be Text or Bytes per RFC 9052 *)
505
let 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 *)
518
let decode_protected_header bytes =
···
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)
···
547
let 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
···
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
···
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
···
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
···
678
(** Build Sig_structure or MAC_structure for COSE operations *)
679
let 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 *)
692
let 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
···
701
702
let 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))
···
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
···
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 *)
···
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
868
let verify_and_validate ~key ~now ?allowed_algs ?iss ?aud ?leeway t =
869
match verify ~key ?allowed_algs t with
···
873
(** Encode protected header as CBOR map *)
874
let 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 *)
884
let 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
897
let create ~algorithm ~claims ~key =
···
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
···
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
956
let encode t = t.raw
957
958
let 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
967
let 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
+124
-106
ocaml-jsonwt/lib/cwt.mli
+124
-106
ocaml-jsonwt/lib/cwt.mli
···
9
{{:https://datatracker.ietf.org/doc/html/rfc8392}RFC 8392}.
10
11
CWTs are the CBOR-based equivalent of JWTs, designed for constrained
12
-
environments where compact binary representation is important. CWTs use
13
-
COSE ({{:https://datatracker.ietf.org/doc/html/rfc9052}RFC 9052}) for
14
cryptographic protection.
15
16
{2 Quick Start}
17
18
{[
19
(* Create claims *)
20
-
let claims = Cwt.Claims.(empty
21
-
|> set_iss "https://example.com"
22
-
|> set_sub "user123"
23
-
|> set_exp (Ptime.add_span (Ptime_clock.now ()) (Ptime.Span.of_int_s 3600) |> Option.get)
24
-
|> build)
25
26
(* Create a symmetric key *)
27
-
let key = Cwt.Cose_key.symmetric (Bytes.of_string "my-secret-key-32-bytes-long!!!!!")
28
29
(* Create and encode the CWT *)
30
-
let cwt = Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key |> Result.get_ok
31
let encoded = Cwt.encode cwt
32
33
(* Parse and verify *)
···
36
]}
37
38
{2 References}
39
-
{ul
40
-
{- {{:https://datatracker.ietf.org/doc/html/rfc8392}RFC 8392} - CBOR Web Token (CWT)}
41
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9052}RFC 9052} - CBOR Object Signing and Encryption (COSE) Structures}
42
-
{- {{:https://datatracker.ietf.org/doc/html/rfc9053}RFC 9053} - CBOR Object Signing and Encryption (COSE) Algorithms}
43
-
{- {{:https://datatracker.ietf.org/doc/html/rfc8949}RFC 8949} - Concise Binary Object Representation (CBOR)}} *)
44
45
(** {1 Error Handling} *)
46
47
type error =
48
-
| Invalid_cbor of string
49
-
(** CBOR parsing failed *)
50
-
| Invalid_cose of string
51
-
(** COSE structure validation failed *)
52
-
| Invalid_claims of string
53
-
(** Claims validation failed *)
54
-
| Unsupported_algorithm of string
55
-
(** Unknown COSE algorithm identifier *)
56
| Algorithm_not_allowed of string
57
(** Algorithm rejected by allowed_algs policy *)
58
-
| Signature_mismatch
59
-
(** Signature/MAC verification failed *)
60
| Token_expired
61
(** exp claim validation failed per
62
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.4}RFC 8392 Section 3.1.4} *)
63
| Token_not_yet_valid
64
(** nbf claim validation failed per
65
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.5}RFC 8392 Section 3.1.5} *)
66
| Invalid_issuer
67
(** iss claim mismatch per
68
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.1}RFC 8392 Section 3.1.1} *)
69
| Invalid_audience
70
(** aud claim mismatch per
71
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.3}RFC 8392 Section 3.1.3} *)
72
-
| Key_type_mismatch of string
73
-
(** Key doesn't match algorithm *)
74
75
val pp_error : Format.formatter -> error -> unit
76
(** Pretty-print an error. *)
···
83
Cryptographic algorithms for COSE as specified in
84
{{:https://datatracker.ietf.org/doc/html/rfc9053}RFC 9053}.
85
86
-
Each algorithm has a registered integer identifier in the IANA
87
-
COSE Algorithms registry. *)
88
89
module Algorithm : sig
90
type t =
91
-
| ES256 (** ECDSA w/ SHA-256, COSE alg = -7 *)
92
-
| ES384 (** ECDSA w/ SHA-384, COSE alg = -35 *)
93
-
| ES512 (** ECDSA w/ SHA-512, COSE alg = -36 *)
94
-
| EdDSA (** EdDSA (Ed25519), COSE alg = -8 *)
95
| HMAC_256_64 (** HMAC w/ SHA-256 truncated to 64 bits, COSE alg = 4 *)
96
-
| HMAC_256 (** HMAC w/ SHA-256 (256 bits), COSE alg = 5 *)
97
-
| HMAC_384 (** HMAC w/ SHA-384, COSE alg = 6 *)
98
-
| HMAC_512 (** HMAC w/ SHA-512, COSE alg = 7 *)
99
100
val to_cose_int : t -> int
101
(** Convert to COSE algorithm identifier (negative for signatures). *)
···
112
113
(** {1 COSE Key}
114
115
-
Key representation for COSE operations.
116
-
See {{:https://datatracker.ietf.org/doc/html/rfc9052#section-7}RFC 9052 Section 7}
117
-
and {{:https://datatracker.ietf.org/doc/html/rfc9053}RFC 9053}. *)
118
119
module Cose_key : sig
120
-
121
-
(** Key type per COSE Key Type registry.
122
-
See {{:https://www.iana.org/assignments/cose/cose.xhtml#key-type}IANA COSE Key Types}. *)
123
type kty =
124
-
| Okp (** Octet Key Pair (kty = 1), used for EdDSA *)
125
-
| Ec2 (** Elliptic Curve with x,y coordinates (kty = 2) *)
126
| Symmetric (** Symmetric key (kty = 4) *)
127
128
(** A COSE key.
129
130
Supported key types and curves:
···
133
- P-384 (NIST, crv = 2) for ES384
134
- P-521 (NIST, crv = 3) for ES512
135
- Ed25519 (crv = 6) for EdDSA *)
136
-
type t
137
138
(** {2 Constructors} *)
139
140
val symmetric : string -> t
141
-
(** [symmetric k] creates a symmetric COSE key from raw bytes.
142
-
Used for HMAC algorithms. The key should be at least as long
143
-
as the hash output (32 bytes for HMAC_256, etc.). *)
144
145
val ed25519_pub : string -> t
146
-
(** [ed25519_pub pub] creates an Ed25519 public key from the 32-byte
147
-
public key value. *)
148
149
val ed25519_priv : pub:string -> priv:string -> t
150
-
(** [ed25519_priv ~pub ~priv] creates an Ed25519 private key.
151
-
[pub] is the 32-byte public key, [priv] is the 32-byte seed. *)
152
153
val p256_pub : x:string -> y:string -> t
154
-
(** [p256_pub ~x ~y] creates a P-256 public key from the x and y
155
-
coordinates (each 32 bytes). *)
156
157
val p256_priv : x:string -> y:string -> d:string -> t
158
-
(** [p256_priv ~x ~y ~d] creates a P-256 private key.
159
-
[d] is the 32-byte private key value. *)
160
161
val p384_pub : x:string -> y:string -> t
162
-
(** [p384_pub ~x ~y] creates a P-384 public key (coordinates are 48 bytes each). *)
163
164
val p384_priv : x:string -> y:string -> d:string -> t
165
(** [p384_priv ~x ~y ~d] creates a P-384 private key. *)
166
167
val p521_pub : x:string -> y:string -> t
168
-
(** [p521_pub ~x ~y] creates a P-521 public key (coordinates are 66 bytes each). *)
169
170
val p521_priv : x:string -> y:string -> d:string -> t
171
(** [p521_priv ~x ~y ~d] creates a P-521 private key. *)
···
198
199
(** {1 CWT Claims}
200
201
-
CWT Claims Set using CBOR integer keys for compactness.
202
-
See {{:https://datatracker.ietf.org/doc/html/rfc8392#section-3}RFC 8392 Section 3}.
203
204
{2 Claim Key Mapping}
205
206
-
| Claim | Integer Key | Type |
207
-
|-------|-------------|------|
208
-
| iss | 1 | text string |
209
-
| sub | 2 | text string |
210
-
| aud | 3 | text string |
211
-
| exp | 4 | integer (NumericDate) |
212
-
| nbf | 5 | integer (NumericDate) |
213
-
| iat | 6 | integer (NumericDate) |
214
-
| cti | 7 | byte string | *)
215
216
module Claims : sig
217
type t
218
219
(** {2 Registered Claim Names}
220
221
-
See {{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1}RFC 8392 Section 3.1}. *)
222
223
val iss : t -> string option
224
(** Issuer claim (key 1) per
225
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.1}Section 3.1.1}. *)
226
227
val sub : t -> string option
228
(** Subject claim (key 2) per
229
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.2}Section 3.1.2}. *)
230
231
val aud : t -> string list
232
(** Audience claim (key 3) per
233
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.3}Section 3.1.3}.
234
-
Returns empty list if not present. May be single string or array in CWT. *)
235
236
val exp : t -> Ptime.t option
237
(** Expiration time claim (key 4) per
238
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.4}Section 3.1.4}. *)
239
240
val nbf : t -> Ptime.t option
241
(** Not Before claim (key 5) per
242
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.5}Section 3.1.5}. *)
243
244
val iat : t -> Ptime.t option
245
(** Issued At claim (key 6) per
246
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.6}Section 3.1.6}. *)
247
248
val cti : t -> string option
249
(** CWT ID claim (key 7) per
250
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.7}Section 3.1.7}.
251
-
Note: Unlike JWT's jti which is a string, CWT's cti is a byte string. *)
252
253
(** {2 Custom Claims}
254
255
CWT supports both integer and text string keys for custom claims. *)
256
257
val get_int_key : int -> t -> Cbort.Cbor.t option
258
-
(** [get_int_key key claims] returns the CBOR value of custom claim
259
-
with integer key [key]. *)
260
261
val get_string_key : string -> t -> Cbort.Cbor.t option
262
-
(** [get_string_key key claims] returns the CBOR value of custom claim
263
-
with string key [key]. *)
264
265
(** {2 Construction} *)
266
···
314
(** {1 CWT Token} *)
315
316
type t
317
-
(** A parsed CWT token (COSE_Sign1 or COSE_Mac0 structure).
318
-
Note: COSE_Encrypt0 is not currently supported. *)
319
320
(** {2 Parsing}
321
322
-
Parse CWT from CBOR bytes. The CWT may be tagged (with COSE tag)
323
-
or untagged per {{:https://datatracker.ietf.org/doc/html/rfc8392#section-2}RFC 8392 Section 2}. *)
324
325
val parse : string -> (t, error) result
326
(** [parse cwt_bytes] parses a CWT from CBOR bytes.
327
328
-
This parses the COSE structure and extracts the claims, but does NOT
329
-
verify the signature/MAC. Use {!verify} to validate cryptographic
330
-
protection after parsing. *)
331
332
(** {2 Accessors} *)
333
···
348
Verify cryptographic protection and validate claims. *)
349
350
val verify :
351
-
key:Cose_key.t ->
352
-
?allowed_algs:Algorithm.t list ->
353
-
t ->
354
-
(unit, error) result
355
(** [verify ~key ?allowed_algs t] verifies the COSE signature or MAC.
356
357
@param key The key to verify with (must match algorithm)
···
380
?leeway:Ptime.Span.t ->
381
t ->
382
(unit, error) result
383
-
(** [verify_and_validate ~key ~now ...] verifies signature and validates claims. *)
384
385
(** {2 Creation}
386
···
393
(t, error) result
394
(** [create ~algorithm ~claims ~key] creates and signs a new CWT.
395
396
-
Creates a COSE_Sign1 structure for signature algorithms (ES256, ES384, ES512, EdDSA)
397
-
or COSE_Mac0 for MAC algorithms (HMAC_256, HMAC_384, HMAC_512).
398
399
The [key] must be appropriate for the algorithm:
400
- HMAC algorithms: symmetric key
···
404
- EdDSA: Ed25519 private key *)
405
406
val encode : t -> string
407
-
(** [encode t] returns the CBOR serialization of the CWT.
408
-
The result is a tagged COSE structure (COSE_Sign1 or COSE_Mac0). *)
409
410
(** {1 Utilities} *)
411
412
val is_expired : now:Ptime.t -> ?leeway:Ptime.Span.t -> t -> bool
413
-
(** [is_expired ~now ?leeway t] checks if the token has expired.
414
-
Returns false if no exp claim present. *)
415
416
val time_to_expiry : now:Ptime.t -> t -> Ptime.Span.t option
417
-
(** [time_to_expiry ~now t] returns time until expiration, or [None] if
418
-
no expiration claim or already expired. *)
···
9
{{:https://datatracker.ietf.org/doc/html/rfc8392}RFC 8392}.
10
11
CWTs are the CBOR-based equivalent of JWTs, designed for constrained
12
+
environments where compact binary representation is important. CWTs use COSE
13
+
({{:https://datatracker.ietf.org/doc/html/rfc9052}RFC 9052}) for
14
cryptographic protection.
15
16
{2 Quick Start}
17
18
{[
19
(* Create claims *)
20
+
let claims =
21
+
Cwt.Claims.(
22
+
empty
23
+
|> set_iss "https://example.com"
24
+
|> set_sub "user123"
25
+
|> set_exp
26
+
(Ptime.add_span (Ptime_clock.now ()) (Ptime.Span.of_int_s 3600)
27
+
|> Option.get)
28
+
|> build)
29
30
(* Create a symmetric key *)
31
+
let key =
32
+
Cwt.Cose_key.symmetric
33
+
(Bytes.of_string "my-secret-key-32-bytes-long!!!!!")
34
35
(* Create and encode the CWT *)
36
+
let cwt =
37
+
Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key
38
+
|> Result.get_ok
39
+
40
let encoded = Cwt.encode cwt
41
42
(* Parse and verify *)
···
45
]}
46
47
{2 References}
48
+
- {{:https://datatracker.ietf.org/doc/html/rfc8392}RFC 8392} - CBOR Web
49
+
Token (CWT)
50
+
- {{:https://datatracker.ietf.org/doc/html/rfc9052}RFC 9052} - CBOR Object
51
+
Signing and Encryption (COSE) Structures
52
+
- {{:https://datatracker.ietf.org/doc/html/rfc9053}RFC 9053} - CBOR Object
53
+
Signing and Encryption (COSE) Algorithms
54
+
- {{:https://datatracker.ietf.org/doc/html/rfc8949}RFC 8949} - Concise
55
+
Binary Object Representation (CBOR) *)
56
57
(** {1 Error Handling} *)
58
59
type error =
60
+
| Invalid_cbor of string (** CBOR parsing failed *)
61
+
| Invalid_cose of string (** COSE structure validation failed *)
62
+
| Invalid_claims of string (** Claims validation failed *)
63
+
| Unsupported_algorithm of string (** Unknown COSE algorithm identifier *)
64
| Algorithm_not_allowed of string
65
(** Algorithm rejected by allowed_algs policy *)
66
+
| Signature_mismatch (** Signature/MAC verification failed *)
67
| Token_expired
68
(** exp claim validation failed per
69
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.4}RFC
70
+
8392 Section 3.1.4} *)
71
| Token_not_yet_valid
72
(** nbf claim validation failed per
73
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.5}RFC
74
+
8392 Section 3.1.5} *)
75
| Invalid_issuer
76
(** iss claim mismatch per
77
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.1}RFC
78
+
8392 Section 3.1.1} *)
79
| Invalid_audience
80
(** aud claim mismatch per
81
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.3}RFC
82
+
8392 Section 3.1.3} *)
83
+
| Key_type_mismatch of string (** Key doesn't match algorithm *)
84
85
val pp_error : Format.formatter -> error -> unit
86
(** Pretty-print an error. *)
···
93
Cryptographic algorithms for COSE as specified in
94
{{:https://datatracker.ietf.org/doc/html/rfc9053}RFC 9053}.
95
96
+
Each algorithm has a registered integer identifier in the IANA COSE
97
+
Algorithms registry. *)
98
99
module Algorithm : sig
100
type t =
101
+
| ES256 (** ECDSA w/ SHA-256, COSE alg = -7 *)
102
+
| ES384 (** ECDSA w/ SHA-384, COSE alg = -35 *)
103
+
| ES512 (** ECDSA w/ SHA-512, COSE alg = -36 *)
104
+
| EdDSA (** EdDSA (Ed25519), COSE alg = -8 *)
105
| HMAC_256_64 (** HMAC w/ SHA-256 truncated to 64 bits, COSE alg = 4 *)
106
+
| HMAC_256 (** HMAC w/ SHA-256 (256 bits), COSE alg = 5 *)
107
+
| HMAC_384 (** HMAC w/ SHA-384, COSE alg = 6 *)
108
+
| HMAC_512 (** HMAC w/ SHA-512, COSE alg = 7 *)
109
110
val to_cose_int : t -> int
111
(** Convert to COSE algorithm identifier (negative for signatures). *)
···
122
123
(** {1 COSE Key}
124
125
+
Key representation for COSE operations. See
126
+
{{:https://datatracker.ietf.org/doc/html/rfc9052#section-7}RFC 9052 Section
127
+
7} and {{:https://datatracker.ietf.org/doc/html/rfc9053}RFC 9053}. *)
128
129
module Cose_key : sig
130
+
(** Key type per COSE Key Type registry. See
131
+
{{:https://www.iana.org/assignments/cose/cose.xhtml#key-type}IANA COSE Key
132
+
Types}. *)
133
type kty =
134
+
| Okp (** Octet Key Pair (kty = 1), used for EdDSA *)
135
+
| Ec2 (** Elliptic Curve with x,y coordinates (kty = 2) *)
136
| Symmetric (** Symmetric key (kty = 4) *)
137
138
+
type t
139
(** A COSE key.
140
141
Supported key types and curves:
···
144
- P-384 (NIST, crv = 2) for ES384
145
- P-521 (NIST, crv = 3) for ES512
146
- Ed25519 (crv = 6) for EdDSA *)
147
148
(** {2 Constructors} *)
149
150
val symmetric : string -> t
151
+
(** [symmetric k] creates a symmetric COSE key from raw bytes. Used for HMAC
152
+
algorithms. The key should be at least as long as the hash output (32
153
+
bytes for HMAC_256, etc.). *)
154
155
val ed25519_pub : string -> t
156
+
(** [ed25519_pub pub] creates an Ed25519 public key from the 32-byte public
157
+
key value. *)
158
159
val ed25519_priv : pub:string -> priv:string -> t
160
+
(** [ed25519_priv ~pub ~priv] creates an Ed25519 private key. [pub] is the
161
+
32-byte public key, [priv] is the 32-byte seed. *)
162
163
val p256_pub : x:string -> y:string -> t
164
+
(** [p256_pub ~x ~y] creates a P-256 public key from the x and y coordinates
165
+
(each 32 bytes). *)
166
167
val p256_priv : x:string -> y:string -> d:string -> t
168
+
(** [p256_priv ~x ~y ~d] creates a P-256 private key. [d] is the 32-byte
169
+
private key value. *)
170
171
val p384_pub : x:string -> y:string -> t
172
+
(** [p384_pub ~x ~y] creates a P-384 public key (coordinates are 48 bytes
173
+
each). *)
174
175
val p384_priv : x:string -> y:string -> d:string -> t
176
(** [p384_priv ~x ~y ~d] creates a P-384 private key. *)
177
178
val p521_pub : x:string -> y:string -> t
179
+
(** [p521_pub ~x ~y] creates a P-521 public key (coordinates are 66 bytes
180
+
each). *)
181
182
val p521_priv : x:string -> y:string -> d:string -> t
183
(** [p521_priv ~x ~y ~d] creates a P-521 private key. *)
···
210
211
(** {1 CWT Claims}
212
213
+
CWT Claims Set using CBOR integer keys for compactness. See
214
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3}RFC 8392 Section
215
+
3}.
216
217
{2 Claim Key Mapping}
218
219
+
| Claim | Integer Key | Type | |-------|-------------|------| | iss | 1 |
220
+
text string | | sub | 2 | text string | | aud | 3 | text string | | exp | 4
221
+
| integer (NumericDate) | | nbf | 5 | integer (NumericDate) | | iat | 6 |
222
+
integer (NumericDate) | | cti | 7 | byte string | *)
223
224
module Claims : sig
225
type t
226
227
(** {2 Registered Claim Names}
228
229
+
See
230
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1}RFC 8392
231
+
Section 3.1}. *)
232
233
val iss : t -> string option
234
(** Issuer claim (key 1) per
235
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.1}Section
236
+
3.1.1}. *)
237
238
val sub : t -> string option
239
(** Subject claim (key 2) per
240
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.2}Section
241
+
3.1.2}. *)
242
243
val aud : t -> string list
244
(** Audience claim (key 3) per
245
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.3}Section
246
+
3.1.3}. Returns empty list if not present. May be single string or array
247
+
in CWT. *)
248
249
val exp : t -> Ptime.t option
250
(** Expiration time claim (key 4) per
251
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.4}Section
252
+
3.1.4}. *)
253
254
val nbf : t -> Ptime.t option
255
(** Not Before claim (key 5) per
256
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.5}Section
257
+
3.1.5}. *)
258
259
val iat : t -> Ptime.t option
260
(** Issued At claim (key 6) per
261
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.6}Section
262
+
3.1.6}. *)
263
264
val cti : t -> string option
265
(** CWT ID claim (key 7) per
266
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.7}Section
267
+
3.1.7}. Note: Unlike JWT's jti which is a string, CWT's cti is a byte
268
+
string. *)
269
270
(** {2 Custom Claims}
271
272
CWT supports both integer and text string keys for custom claims. *)
273
274
val get_int_key : int -> t -> Cbort.Cbor.t option
275
+
(** [get_int_key key claims] returns the CBOR value of custom claim with
276
+
integer key [key]. *)
277
278
val get_string_key : string -> t -> Cbort.Cbor.t option
279
+
(** [get_string_key key claims] returns the CBOR value of custom claim with
280
+
string key [key]. *)
281
282
(** {2 Construction} *)
283
···
331
(** {1 CWT Token} *)
332
333
type t
334
+
(** A parsed CWT token (COSE_Sign1 or COSE_Mac0 structure). Note: COSE_Encrypt0
335
+
is not currently supported. *)
336
337
(** {2 Parsing}
338
339
+
Parse CWT from CBOR bytes. The CWT may be tagged (with COSE tag) or untagged
340
+
per
341
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-2}RFC 8392 Section
342
+
2}. *)
343
344
val parse : string -> (t, error) result
345
(** [parse cwt_bytes] parses a CWT from CBOR bytes.
346
347
+
This parses the COSE structure and extracts the claims, but does NOT verify
348
+
the signature/MAC. Use {!verify} to validate cryptographic protection after
349
+
parsing. *)
350
351
(** {2 Accessors} *)
352
···
367
Verify cryptographic protection and validate claims. *)
368
369
val verify :
370
+
key:Cose_key.t -> ?allowed_algs:Algorithm.t list -> t -> (unit, error) result
371
(** [verify ~key ?allowed_algs t] verifies the COSE signature or MAC.
372
373
@param key The key to verify with (must match algorithm)
···
396
?leeway:Ptime.Span.t ->
397
t ->
398
(unit, error) result
399
+
(** [verify_and_validate ~key ~now ...] verifies signature and validates claims.
400
+
*)
401
402
(** {2 Creation}
403
···
410
(t, error) result
411
(** [create ~algorithm ~claims ~key] creates and signs a new CWT.
412
413
+
Creates a COSE_Sign1 structure for signature algorithms (ES256, ES384,
414
+
ES512, EdDSA) or COSE_Mac0 for MAC algorithms (HMAC_256, HMAC_384,
415
+
HMAC_512).
416
417
The [key] must be appropriate for the algorithm:
418
- HMAC algorithms: symmetric key
···
422
- EdDSA: Ed25519 private key *)
423
424
val encode : t -> string
425
+
(** [encode t] returns the CBOR serialization of the CWT. The result is a tagged
426
+
COSE structure (COSE_Sign1 or COSE_Mac0). *)
427
428
(** {1 Utilities} *)
429
430
val is_expired : now:Ptime.t -> ?leeway:Ptime.Span.t -> t -> bool
431
+
(** [is_expired ~now ?leeway t] checks if the token has expired. Returns false
432
+
if no exp claim present. *)
433
434
val time_to_expiry : now:Ptime.t -> t -> Ptime.Span.t option
435
+
(** [time_to_expiry ~now t] returns time until expiration, or [None] if no
436
+
expiration claim or already expired. *)
+299
-239
ocaml-jsonwt/lib/jsonwt.ml
+299
-239
ocaml-jsonwt/lib/jsonwt.ml
···
39
| Unsecured_not_allowed -> Format.fprintf fmt "Unsecured JWT not allowed"
40
| Nesting_too_deep -> Format.fprintf fmt "Nested JWT too deep"
41
42
-
let error_to_string e =
43
-
Format.asprintf "%a" pp_error e
44
45
(* Base64url encoding/decoding per RFC 7515 Appendix C *)
46
let base64url_encode s =
···
64
let scheme = String.sub s 0 i in
65
(* Check scheme is alphanumeric with +.- allowed after first char *)
66
let valid_scheme =
67
-
String.length scheme > 0 &&
68
-
(match scheme.[0] with 'a'..'z' | 'A'..'Z' -> true | _ -> false) &&
69
-
String.for_all (fun c ->
70
-
match c with
71
-
| 'a'..'z' | 'A'..'Z' | '0'..'9' | '+' | '-' | '.' -> true
72
-
| _ -> false
73
-
) scheme
74
in
75
if valid_scheme then Ok s
76
else Error (Invalid_uri (Printf.sprintf "Invalid URI scheme in: %s" s))
77
| _ -> Error (Invalid_uri (Printf.sprintf "Invalid URI: %s" s))
78
-
else
79
-
Ok s
80
81
(* Algorithm module *)
82
module Algorithm = struct
···
120
| "EdDSA" -> Ok EdDSA
121
| s -> Error (Unsupported_algorithm s)
122
123
-
let all = [ HS256; HS384; HS512; RS256; RS384; RS512; ES256; ES384; ES512; EdDSA ]
124
let all_with_none = None :: all
125
end
126
127
(* JWK module *)
128
module Jwk = struct
129
type kty = Oct | Rsa | Ec | Okp
130
-
131
type crv = P256 | P384 | P521 | Ed25519
132
133
type key_data =
···
164
{ key_data = Ed25519_pub { x }; kid = None; alg = Some Algorithm.EdDSA }
165
166
let ed25519_priv ~pub ~priv =
167
-
{ key_data = Ed25519_priv { x = pub; d = priv }; kid = None; alg = Some Algorithm.EdDSA }
168
169
let p256_pub ~x ~y =
170
{ key_data = P256_pub { x; y }; kid = None; alg = Some Algorithm.ES256 }
···
188
{ key_data = Rsa_pub { n; e }; kid = None; alg = Some Algorithm.RS256 }
189
190
let rsa_priv ~n ~e ~d ~p ~q ~dp ~dq ~qi =
191
-
{ key_data = Rsa_priv { n; e; d; p; q; dp; dq; qi }; kid = None; alg = Some Algorithm.RS256 }
192
193
let kty t =
194
match t.key_data with
195
| Symmetric _ -> Oct
196
| Ed25519_pub _ | Ed25519_priv _ -> Okp
197
-
| P256_pub _ | P256_priv _ | P384_pub _ | P384_priv _ | P521_pub _ | P521_priv _ -> Ec
198
| Rsa_pub _ | Rsa_priv _ -> Rsa
199
200
let kid t = t.kid
201
let alg t = t.alg
202
-
203
let with_kid id t = { t with kid = Some id }
204
let with_alg a t = { t with alg = Some a }
205
206
(* Helper to extract string from Jsont.json object members *)
207
let get_json_string members name =
208
-
List.find_map (fun ((n, _), v) ->
209
-
if n = name then
210
-
match v with
211
-
| Jsont.String (s, _) -> Some s
212
-
| _ -> None
213
-
else None
214
-
) members
215
216
let get_json_string_req members name =
217
match get_json_string members name with
218
| Some s -> Ok s
219
-
| None -> Error (Invalid_json (Printf.sprintf "missing required field: %s" name))
220
221
let of_json s =
222
(* Parse the JSON to determine key type first *)
223
match Jsont_bytesrw.decode_string Jsont.json s with
224
| Error e -> Error (Invalid_json e)
225
| Ok (Jsont.Null _) -> Error (Invalid_json "null is not a valid JWK")
226
-
| Ok (Jsont.Object (members, _)) ->
227
let ( let* ) = Result.bind in
228
let* kty_s = get_json_string_req members "kty" in
229
let kid = get_json_string members "kid" in
230
let alg_opt =
231
match get_json_string members "alg" with
232
| None -> Ok None
233
-
| Some s ->
234
match Algorithm.of_string s with
235
| Ok a -> Ok (Some a)
236
-
| Error _ -> Ok None (* ignore unknown alg in JWK *)
237
in
238
let* alg = alg_opt in
239
-
(match kty_s with
240
| "oct" ->
241
let* k_b64 = get_json_string_req members "k" in
242
let* k = base64url_decode k_b64 in
243
Ok { key_data = Symmetric { k }; kid; alg }
244
-
| "OKP" ->
245
let* crv = get_json_string_req members "crv" in
246
if crv <> "Ed25519" then
247
Error (Invalid_json (Printf.sprintf "unsupported curve: %s" crv))
248
else
249
let* x_b64 = get_json_string_req members "x" in
250
let* x = base64url_decode x_b64 in
251
-
(match get_json_string members "d" with
252
-
| None -> Ok { key_data = Ed25519_pub { x }; kid; alg }
253
-
| Some d_b64 ->
254
-
let* d = base64url_decode d_b64 in
255
-
Ok { key_data = Ed25519_priv { x; d }; kid; alg })
256
-
| "EC" ->
257
let* crv = get_json_string_req members "crv" in
258
let* x_b64 = get_json_string_req members "x" in
259
let* y_b64 = get_json_string_req members "y" in
···
264
let* d_b64 = get_json_string_req members "d" in
265
base64url_decode d_b64
266
in
267
-
(match crv with
268
-
| "P-256" ->
269
-
if has_d then
270
-
let* d = get_d () in
271
-
Ok { key_data = P256_priv { x; y; d }; kid; alg }
272
-
else
273
-
Ok { key_data = P256_pub { x; y }; kid; alg }
274
-
| "P-384" ->
275
-
if has_d then
276
-
let* d = get_d () in
277
-
Ok { key_data = P384_priv { x; y; d }; kid; alg }
278
-
else
279
-
Ok { key_data = P384_pub { x; y }; kid; alg }
280
-
| "P-521" ->
281
-
if has_d then
282
-
let* d = get_d () in
283
-
Ok { key_data = P521_priv { x; y; d }; kid; alg }
284
-
else
285
-
Ok { key_data = P521_pub { x; y }; kid; alg }
286
-
| _ -> Error (Invalid_json (Printf.sprintf "unsupported curve: %s" crv)))
287
-
| "RSA" ->
288
let* n_b64 = get_json_string_req members "n" in
289
let* e_b64 = get_json_string_req members "e" in
290
let* n = base64url_decode n_b64 in
291
let* e = base64url_decode e_b64 in
292
-
(match get_json_string members "d" with
293
-
| None -> Ok { key_data = Rsa_pub { n; e }; kid; alg }
294
-
| Some d_b64 ->
295
-
let* d = base64url_decode d_b64 in
296
-
let* p_b64 = get_json_string_req members "p" in
297
-
let* q_b64 = get_json_string_req members "q" in
298
-
let* dp_b64 = get_json_string_req members "dp" in
299
-
let* dq_b64 = get_json_string_req members "dq" in
300
-
let* qi_b64 = get_json_string_req members "qi" in
301
-
let* p = base64url_decode p_b64 in
302
-
let* q = base64url_decode q_b64 in
303
-
let* dp = base64url_decode dp_b64 in
304
-
let* dq = base64url_decode dq_b64 in
305
-
let* qi = base64url_decode qi_b64 in
306
-
Ok { key_data = Rsa_priv { n; e; d; p; q; dp; dq; qi }; kid; alg })
307
-
| _ -> Error (Invalid_json (Printf.sprintf "unsupported kty: %s" kty_s)))
308
| Ok _ -> Error (Invalid_json "JWK must be a JSON object")
309
310
(* Helper to create JSON members *)
···
320
in
321
let members = [] in
322
let members = add_opt "kid" t.kid members in
323
-
let members = add_opt "alg" (Option.map Algorithm.to_string t.alg) members in
324
let members =
325
match t.key_data with
326
| Symmetric { k } ->
327
-
json_mem "kty" (json_string "oct") ::
328
-
json_mem "k" (json_string (base64url_encode k)) :: members
329
| Ed25519_pub { x } ->
330
-
json_mem "kty" (json_string "OKP") ::
331
-
json_mem "crv" (json_string "Ed25519") ::
332
-
json_mem "x" (json_string (base64url_encode x)) :: members
333
| Ed25519_priv { x; d } ->
334
-
json_mem "kty" (json_string "OKP") ::
335
-
json_mem "crv" (json_string "Ed25519") ::
336
-
json_mem "x" (json_string (base64url_encode x)) ::
337
-
json_mem "d" (json_string (base64url_encode d)) :: members
338
| P256_pub { x; y } ->
339
-
json_mem "kty" (json_string "EC") ::
340
-
json_mem "crv" (json_string "P-256") ::
341
-
json_mem "x" (json_string (base64url_encode x)) ::
342
-
json_mem "y" (json_string (base64url_encode y)) :: members
343
| P256_priv { x; y; d } ->
344
-
json_mem "kty" (json_string "EC") ::
345
-
json_mem "crv" (json_string "P-256") ::
346
-
json_mem "x" (json_string (base64url_encode x)) ::
347
-
json_mem "y" (json_string (base64url_encode y)) ::
348
-
json_mem "d" (json_string (base64url_encode d)) :: members
349
| P384_pub { x; y } ->
350
-
json_mem "kty" (json_string "EC") ::
351
-
json_mem "crv" (json_string "P-384") ::
352
-
json_mem "x" (json_string (base64url_encode x)) ::
353
-
json_mem "y" (json_string (base64url_encode y)) :: members
354
| P384_priv { x; y; d } ->
355
-
json_mem "kty" (json_string "EC") ::
356
-
json_mem "crv" (json_string "P-384") ::
357
-
json_mem "x" (json_string (base64url_encode x)) ::
358
-
json_mem "y" (json_string (base64url_encode y)) ::
359
-
json_mem "d" (json_string (base64url_encode d)) :: members
360
| P521_pub { x; y } ->
361
-
json_mem "kty" (json_string "EC") ::
362
-
json_mem "crv" (json_string "P-521") ::
363
-
json_mem "x" (json_string (base64url_encode x)) ::
364
-
json_mem "y" (json_string (base64url_encode y)) :: members
365
| P521_priv { x; y; d } ->
366
-
json_mem "kty" (json_string "EC") ::
367
-
json_mem "crv" (json_string "P-521") ::
368
-
json_mem "x" (json_string (base64url_encode x)) ::
369
-
json_mem "y" (json_string (base64url_encode y)) ::
370
-
json_mem "d" (json_string (base64url_encode d)) :: members
371
| Rsa_pub { n; e } ->
372
-
json_mem "kty" (json_string "RSA") ::
373
-
json_mem "n" (json_string (base64url_encode n)) ::
374
-
json_mem "e" (json_string (base64url_encode e)) :: members
375
| Rsa_priv { n; e; d; p; q; dp; dq; qi } ->
376
-
json_mem "kty" (json_string "RSA") ::
377
-
json_mem "n" (json_string (base64url_encode n)) ::
378
-
json_mem "e" (json_string (base64url_encode e)) ::
379
-
json_mem "d" (json_string (base64url_encode d)) ::
380
-
json_mem "p" (json_string (base64url_encode p)) ::
381
-
json_mem "q" (json_string (base64url_encode q)) ::
382
-
json_mem "dp" (json_string (base64url_encode dp)) ::
383
-
json_mem "dq" (json_string (base64url_encode dq)) ::
384
-
json_mem "qi" (json_string (base64url_encode qi)) :: members
385
in
386
-
match Jsont_bytesrw.encode_string Jsont.json (Jsont.Object (members, meta)) with
387
| Ok s -> s
388
| Error _ -> "{}" (* Should not happen *)
389
end
···
406
407
(* Helper to extract string from Jsont.json object members *)
408
let get_json_string members name =
409
-
List.find_map (fun ((n, _), v) ->
410
-
if n = name then
411
-
match v with
412
-
| Jsont.String (s, _) -> Some s
413
-
| _ -> None
414
-
else None
415
-
) members
416
417
let of_json s =
418
match Jsont_bytesrw.decode_string Jsont.json s with
419
| Error e -> Error (Invalid_json e)
420
| Ok (Jsont.Null _) -> Error (Invalid_header "null is not a valid header")
421
-
| Ok (Jsont.Object (members, _)) ->
422
let ( let* ) = Result.bind in
423
let alg_s = get_json_string members "alg" in
424
-
(match alg_s with
425
| None -> Error (Invalid_header "missing required 'alg' field")
426
| Some alg_str ->
427
let* alg = Algorithm.of_string alg_str in
···
436
let json_mem name value = ((name, meta), value)
437
438
let to_json h =
439
-
let members = [ json_mem "alg" (json_string (Algorithm.to_string h.alg)) ] in
440
let add_opt name v_opt acc =
441
match v_opt with
442
| None -> acc
···
445
let members = add_opt "typ" h.typ members in
446
let members = add_opt "kid" h.kid members in
447
let members = add_opt "cty" h.cty members in
448
-
match Jsont_bytesrw.encode_string Jsont.json (Jsont.Object (List.rev members, meta)) with
449
| Ok s -> s
450
| Error _ -> "{}"
451
end
···
470
let nbf t = t.nbf
471
let iat t = t.iat
472
let jti t = t.jti
473
-
474
let get name t = List.assoc_opt name t.custom
475
476
let get_string name t =
477
-
match get name t with
478
-
| Some (Jsont.String (s, _)) -> Some s
479
-
| _ -> None
480
481
let get_int name t =
482
match get name t with
483
-
| Some (Jsont.Number (n, _)) -> (try Some (int_of_float n) with _ -> None)
484
| _ -> None
485
486
let get_bool name t =
487
-
match get name t with
488
-
| Some (Jsont.Bool (b, _)) -> Some b
489
-
| _ -> None
490
491
let meta = Jsont.Meta.none
492
let json_string s = Jsont.String (s, meta)
···
496
497
type builder = t
498
499
-
let empty = {
500
-
iss = None;
501
-
sub = None;
502
-
aud = [];
503
-
exp = None;
504
-
nbf = None;
505
-
iat = None;
506
-
jti = None;
507
-
custom = [];
508
-
}
509
510
let set_iss v t = { t with iss = Some v }
511
let set_sub v t = { t with sub = Some v }
···
524
let span = Ptime.Span.of_float_s n in
525
Option.bind span (fun s -> Ptime.of_span s)
526
527
-
let numeric_date_of_ptime t =
528
-
Ptime.to_span t |> Ptime.Span.to_float_s
529
530
(* Helper to extract values from Jsont.json object members *)
531
let get_json_string members name =
532
-
List.find_map (fun ((n, _), v) ->
533
-
if n = name then
534
-
match v with
535
-
| Jsont.String (s, _) -> Some s
536
-
| _ -> None
537
-
else None
538
-
) members
539
540
let get_json_number members name =
541
-
List.find_map (fun ((n, _), v) ->
542
-
if n = name then
543
-
match v with
544
-
| Jsont.Number (n, _) -> Some n
545
-
| _ -> None
546
-
else None
547
-
) members
548
549
let get_json_aud members =
550
-
List.find_map (fun ((n, _), v) ->
551
-
if n = "aud" then
552
-
match v with
553
-
| Jsont.String (s, _) -> Some [ s ]
554
-
| Jsont.Array (arr, _) ->
555
-
Some (List.filter_map (function
556
-
| Jsont.String (s, _) -> Some s
557
-
| _ -> None
558
-
) arr)
559
-
| _ -> None
560
-
else None
561
-
) members |> Option.value ~default:[]
562
563
let of_json ?(strict = true) s =
564
match Jsont_bytesrw.decode_string Jsont.json s with
565
| Error e -> Error (Invalid_json e)
566
-
| Ok (Jsont.Null _) -> Error (Invalid_claims "null is not a valid claims set")
567
| Ok (Jsont.Object (members, _)) ->
568
let ( let* ) = Result.bind in
569
(* Check for duplicates in strict mode *)
···
594
let* _ = validate_string_or_uri s in
595
Ok (Some s)
596
in
597
-
let exp = Option.bind (get_json_number members "exp") ptime_of_numeric_date in
598
-
let nbf = Option.bind (get_json_number members "nbf") ptime_of_numeric_date in
599
-
let iat = Option.bind (get_json_number members "iat") ptime_of_numeric_date in
600
let jti = get_json_string members "jti" in
601
let aud = get_json_aud members in
602
(* Collect custom claims (everything not registered) *)
603
let registered = [ "iss"; "sub"; "aud"; "exp"; "nbf"; "iat"; "jti" ] in
604
let custom =
605
-
List.filter_map (fun ((n, _), v) ->
606
-
if List.mem n registered then None
607
-
else Some (n, v)
608
-
) members
609
in
610
Ok { iss; sub; aud; exp; nbf; iat; jti; custom }
611
| Ok _ -> Error (Invalid_claims "claims must be a JSON object")
···
637
let members = add_time "iat" t.iat members in
638
let members = add_string "jti" t.jti members in
639
let members =
640
-
List.fold_left (fun acc (name, value) ->
641
-
json_mem name value :: acc
642
-
) members t.custom
643
in
644
-
match Jsont_bytesrw.encode_string Jsont.json (Jsont.Object (List.rev members, meta)) with
645
| Ok s -> s
646
| Error _ -> "{}"
647
end
···
658
let claims t = t.claims
659
let signature t = t.signature
660
let raw t = t.raw
661
-
662
let is_nested t = Header.is_nested t.header
663
664
(* Parsing *)
···
688
let parse_nested ?(strict = true) ?(max_depth = 5) token =
689
let ( let* ) = Result.bind in
690
let rec loop depth acc tok =
691
-
if depth > max_depth then
692
-
Error Nesting_too_deep
693
else
694
let* jwt = parse ~strict tok in
695
let acc = jwt :: acc in
···
700
let* inner_token = base64url_decode payload_b64 in
701
loop (depth + 1) acc inner_token
702
| _ -> Ok (List.rev acc)
703
-
else
704
-
Ok (List.rev acc)
705
in
706
loop 1 [] token
707
···
710
let hmac_sha256 ~key data =
711
let key = Cstruct.of_string key in
712
let data = Cstruct.of_string data in
713
-
Digestif.SHA256.hmac_string ~key:(Cstruct.to_string key) (Cstruct.to_string data)
714
|> Digestif.SHA256.to_raw_string
715
716
let hmac_sha384 ~key data =
717
let key = Cstruct.of_string key in
718
let data = Cstruct.of_string data in
719
-
Digestif.SHA384.hmac_string ~key:(Cstruct.to_string key) (Cstruct.to_string data)
720
|> Digestif.SHA384.to_raw_string
721
722
let hmac_sha512 ~key data =
723
let key = Cstruct.of_string key in
724
let data = Cstruct.of_string data in
725
-
Digestif.SHA512.hmac_string ~key:(Cstruct.to_string key) (Cstruct.to_string data)
726
|> Digestif.SHA512.to_raw_string
727
728
(* EdDSA signing using mirage-crypto-ec *)
···
737
match Mirage_crypto_ec.Ed25519.pub_of_octets pub with
738
| Error _ -> Error (Key_type_mismatch "Invalid Ed25519 public key")
739
| Ok pub ->
740
-
let valid = Mirage_crypto_ec.Ed25519.verify ~key:pub signature ~msg:data in
741
if valid then Ok () else Error Signature_mismatch
742
743
(* P-256 ECDSA *)
···
745
match Mirage_crypto_ec.P256.Dsa.priv_of_octets priv with
746
| Error _ -> Error (Key_type_mismatch "Invalid P-256 private key")
747
| Ok priv ->
748
-
let hash = Digestif.SHA256.digest_string data |> Digestif.SHA256.to_raw_string in
749
-
let (r, s) = Mirage_crypto_ec.P256.Dsa.sign ~key:priv hash in
750
(* JWS uses raw R||S format, each 32 bytes for P-256 *)
751
(* Pad to 32 bytes each *)
752
let pad32 s =
···
757
Ok (pad32 r ^ pad32 s)
758
759
let p256_verify ~pub ~signature data =
760
-
if String.length signature <> 64 then
761
-
Error Signature_mismatch
762
else
763
let r = String.sub signature 0 32 in
764
let s = String.sub signature 32 32 in
765
match Mirage_crypto_ec.P256.Dsa.pub_of_octets pub with
766
| Error _ -> Error (Key_type_mismatch "Invalid P-256 public key")
767
| Ok pub ->
768
-
let hash = Digestif.SHA256.digest_string data |> Digestif.SHA256.to_raw_string in
769
let valid = Mirage_crypto_ec.P256.Dsa.verify ~key:pub (r, s) hash in
770
if valid then Ok () else Error Signature_mismatch
771
···
774
match Mirage_crypto_ec.P384.Dsa.priv_of_octets priv with
775
| Error _ -> Error (Key_type_mismatch "Invalid P-384 private key")
776
| Ok priv ->
777
-
let hash = Digestif.SHA384.digest_string data |> Digestif.SHA384.to_raw_string in
778
-
let (r, s) = Mirage_crypto_ec.P384.Dsa.sign ~key:priv hash in
779
let pad48 s =
780
let len = String.length s in
781
if len >= 48 then String.sub s (len - 48) 48
···
784
Ok (pad48 r ^ pad48 s)
785
786
let p384_verify ~pub ~signature data =
787
-
if String.length signature <> 96 then
788
-
Error Signature_mismatch
789
else
790
let r = String.sub signature 0 48 in
791
let s = String.sub signature 48 48 in
792
match Mirage_crypto_ec.P384.Dsa.pub_of_octets pub with
793
| Error _ -> Error (Key_type_mismatch "Invalid P-384 public key")
794
| Ok pub ->
795
-
let hash = Digestif.SHA384.digest_string data |> Digestif.SHA384.to_raw_string in
796
let valid = Mirage_crypto_ec.P384.Dsa.verify ~key:pub (r, s) hash in
797
if valid then Ok () else Error Signature_mismatch
798
···
801
match Mirage_crypto_ec.P521.Dsa.priv_of_octets priv with
802
| Error _ -> Error (Key_type_mismatch "Invalid P-521 private key")
803
| Ok priv ->
804
-
let hash = Digestif.SHA512.digest_string data |> Digestif.SHA512.to_raw_string in
805
-
let (r, s) = Mirage_crypto_ec.P521.Dsa.sign ~key:priv hash in
806
let pad66 s =
807
let len = String.length s in
808
if len >= 66 then String.sub s (len - 66) 66
···
811
Ok (pad66 r ^ pad66 s)
812
813
let p521_verify ~pub ~signature data =
814
-
if String.length signature <> 132 then
815
-
Error Signature_mismatch
816
else
817
let r = String.sub signature 0 66 in
818
let s = String.sub signature 66 66 in
819
match Mirage_crypto_ec.P521.Dsa.pub_of_octets pub with
820
| Error _ -> Error (Key_type_mismatch "Invalid P-521 public key")
821
| Ok pub ->
822
-
let hash = Digestif.SHA512.digest_string data |> Digestif.SHA512.to_raw_string in
823
let valid = Mirage_crypto_ec.P521.Dsa.verify ~key:pub (r, s) hash in
824
if valid then Ok () else Error Signature_mismatch
825
···
847
let* () =
848
if alg = Algorithm.None then
849
(* For alg:none, only allow_none flag matters *)
850
-
if allow_none then Ok ()
851
-
else Error Unsecured_not_allowed
852
else if List.mem alg allowed_algs then Ok ()
853
else Error (Algorithm_not_allowed alg_str)
854
in
855
let input = signing_input t.raw in
856
-
match alg, key.Jwk.key_data with
857
| Algorithm.None, _ ->
858
(* Unsecured JWT - signature must be empty *)
859
-
if t.signature = "" then Ok ()
860
-
else Error Signature_mismatch
861
| Algorithm.HS256, Jwk.Symmetric { k } ->
862
let expected = Sign.hmac_sha256 ~key:k input in
863
if Eqaf.equal expected t.signature then Ok ()
···
875
| Algorithm.EdDSA, Jwk.Ed25519_priv { x; d = _ } ->
876
Sign.ed25519_verify ~pub:x ~signature:t.signature input
877
| Algorithm.ES256, Jwk.P256_pub { x; y } ->
878
-
let pub = x ^ y in (* Uncompressed point *)
879
Sign.p256_verify ~pub ~signature:t.signature input
880
| Algorithm.ES256, Jwk.P256_priv { x; y; d = _ } ->
881
let pub = x ^ y in
···
899
| Algorithm.RS512, Jwk.Rsa_pub _ ->
900
Error (Key_type_mismatch "RSA verification not yet implemented")
901
| alg, _ ->
902
-
Error (Key_type_mismatch
903
-
(Printf.sprintf "Key type doesn't match algorithm %s" (Algorithm.to_string alg)))
904
905
(* Claims validation *)
906
let validate ~now ?iss ?aud ?(leeway = Ptime.Span.zero) t =
···
911
match Claims.exp claims with
912
| None -> Ok ()
913
| Some exp_time ->
914
-
let exp_with_leeway = Ptime.add_span exp_time leeway |> Option.value ~default:exp_time in
915
-
if Ptime.is_later now ~than:exp_with_leeway then
916
-
Error Token_expired
917
else Ok ()
918
in
919
(* Check nbf claim *)
···
921
match Claims.nbf claims with
922
| None -> Ok ()
923
| Some nbf_time ->
924
-
let nbf_with_leeway = Ptime.sub_span nbf_time leeway |> Option.value ~default:nbf_time in
925
if Ptime.is_earlier now ~than:nbf_with_leeway then
926
Error Token_not_yet_valid
927
else Ok ()
···
930
let* () =
931
match iss with
932
| None -> Ok ()
933
-
| Some expected_iss ->
934
match Claims.iss claims with
935
| None -> Error Invalid_issuer
936
| Some actual_iss ->
937
if String.equal expected_iss actual_iss then Ok ()
938
-
else Error Invalid_issuer
939
in
940
(* Check aud claim *)
941
let* () =
···
948
in
949
Ok ()
950
951
-
let verify_and_validate ~key ~now ?allow_none ?allowed_algs ?iss ?aud ?leeway t =
952
let ( let* ) = Result.bind in
953
let* () = verify ~key ?allow_none ?allowed_algs t in
954
validate ~now ?iss ?aud ?leeway t
···
962
let payload_b64 = base64url_encode claims_json in
963
let signing_input = header_b64 ^ "." ^ payload_b64 in
964
let* signature =
965
-
match header.Header.alg, key.Jwk.key_data with
966
| Algorithm.None, _ -> Ok ""
967
| Algorithm.HS256, Jwk.Symmetric { k } ->
968
Ok (Sign.hmac_sha256 ~key:k signing_input)
···
979
| Algorithm.ES512, Jwk.P521_priv { x = _; y = _; d } ->
980
Sign.p521_sign ~priv:d signing_input
981
| alg, _ ->
982
-
Error (Key_type_mismatch
983
-
(Printf.sprintf "Cannot sign with algorithm %s and given key"
984
-
(Algorithm.to_string alg)))
985
in
986
let sig_b64 = base64url_encode signature in
987
let raw = signing_input ^ "." ^ sig_b64 in
···
994
match Claims.exp t.claims with
995
| None -> false
996
| Some exp_time ->
997
-
let exp_with_leeway = Ptime.add_span exp_time leeway |> Option.value ~default:exp_time in
998
Ptime.is_later now ~than:exp_with_leeway
999
1000
let time_to_expiry ~now t =
···
1002
| None -> None
1003
| Some exp_time ->
1004
let diff = Ptime.diff exp_time now in
1005
-
if Ptime.Span.compare diff Ptime.Span.zero <= 0 then None
1006
-
else Some diff
1007
1008
-
(** CBOR Web Token (CWT) support *)
1009
module Cwt = Cwt
···
39
| Unsecured_not_allowed -> Format.fprintf fmt "Unsecured JWT not allowed"
40
| Nesting_too_deep -> Format.fprintf fmt "Nested JWT too deep"
41
42
+
let error_to_string e = Format.asprintf "%a" pp_error e
43
44
(* Base64url encoding/decoding per RFC 7515 Appendix C *)
45
let base64url_encode s =
···
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 *)
84
module Algorithm = struct
···
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
129
end
130
131
(* JWK module *)
132
module Jwk = struct
133
type kty = Oct | Rsa | Ec | Okp
134
type crv = P256 | P384 | P521 | Ed25519
135
136
type key_data =
···
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 }
···
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
···
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 *)
···
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 *)
421
end
···
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
···
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
···
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 _ -> "{}"
487
end
···
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)
···
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 }
···
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 *)
···
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")
···
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 _ -> "{}"
689
end
···
700
let claims t = t.claims
701
let signature t = t.signature
702
let raw t = t.raw
703
let is_nested t = Header.is_nested t.header
704
705
(* Parsing *)
···
729
let 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
···
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
···
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 *)
···
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 *)
···
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 =
···
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
···
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
···
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
···
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
···
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
···
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 ()
···
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
···
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 *)
960
let validate ~now ?iss ?aud ?(leeway = Ptime.Span.zero) t =
···
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 *)
···
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 ()
···
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* () =
···
1005
in
1006
Ok ()
1007
1008
+
let 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
···
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)
···
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
···
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
1061
let time_to_expiry ~now t =
···
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
1068
module Cwt = Cwt
1069
+
(** CBOR Web Token (CWT) support *)
+177
-115
ocaml-jsonwt/lib/jsonwt.mli
+177
-115
ocaml-jsonwt/lib/jsonwt.mli
···
9
{{:https://datatracker.ietf.org/doc/html/rfc7519}RFC 7519}.
10
11
JWTs are compact, URL-safe means of representing claims to be transferred
12
-
between two parties. The claims are encoded as a JSON object that is used
13
-
as the payload of a JSON Web Signature (JWS) structure, enabling the claims
14
-
to be digitally signed or integrity protected with a Message Authentication
15
Code (MAC).
16
17
{2 References}
18
-
{ul
19
-
{- {{:https://datatracker.ietf.org/doc/html/rfc7519}RFC 7519} - JSON Web Token (JWT)}
20
-
{- {{:https://datatracker.ietf.org/doc/html/rfc7515}RFC 7515} - JSON Web Signature (JWS)}
21
-
{- {{:https://datatracker.ietf.org/doc/html/rfc7517}RFC 7517} - JSON Web Key (JWK)}
22
-
{- {{:https://datatracker.ietf.org/doc/html/rfc7518}RFC 7518} - JSON Web Algorithms (JWA)}} *)
23
24
(** {1 Error Handling} *)
25
26
type error =
27
-
| Invalid_json of string
28
-
(** JSON parsing failed *)
29
-
| Invalid_base64url of string
30
-
(** Base64url decoding failed *)
31
| Invalid_structure of string
32
(** Wrong number of parts or malformed structure *)
33
-
| Invalid_header of string
34
-
(** Header validation failed *)
35
-
| Invalid_claims of string
36
-
(** Claims validation failed *)
37
| Invalid_uri of string
38
(** StringOrURI validation failed per
39
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-2}RFC 7519 Section 2} *)
40
| Duplicate_claim of string
41
(** Duplicate claim name found in strict mode per
42
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4}RFC 7519 Section 4} *)
43
-
| Unsupported_algorithm of string
44
-
(** Unknown algorithm identifier *)
45
| Algorithm_not_allowed of string
46
(** Algorithm rejected by allowed_algs policy *)
47
-
| Signature_mismatch
48
-
(** Signature verification failed *)
49
| Token_expired
50
(** exp claim validation failed per
51
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.4}RFC 7519 Section 4.1.4} *)
52
| Token_not_yet_valid
53
(** nbf claim validation failed per
54
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.5}RFC 7519 Section 4.1.5} *)
55
| Invalid_issuer
56
(** iss claim mismatch per
57
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.1}RFC 7519 Section 4.1.1} *)
58
| Invalid_audience
59
(** aud claim mismatch per
60
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.3}RFC 7519 Section 4.1.3} *)
61
-
| Key_type_mismatch of string
62
-
(** Key doesn't match algorithm *)
63
| Unsecured_not_allowed
64
(** alg:none used without explicit opt-in per
65
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-6}RFC 7519 Section 6} *)
66
-
| Nesting_too_deep
67
-
(** Nested JWT exceeds max_depth *)
68
69
val pp_error : Format.formatter -> error -> unit
70
(** Pretty-print an error. *)
···
74
75
(** {1 Algorithms}
76
77
-
Signature and MAC algorithms for JWT.
78
-
See {{:https://datatracker.ietf.org/doc/html/rfc7518#section-3}RFC 7518 Section 3}. *)
79
80
module Algorithm : sig
81
type t =
82
-
| None (** No digital signature or MAC per
83
-
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3.6}RFC 7518 Section 3.6} *)
84
-
| HS256 (** HMAC using SHA-256 per
85
-
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3.2}RFC 7518 Section 3.2} *)
86
| HS384 (** HMAC using SHA-384 *)
87
| HS512 (** HMAC using SHA-512 *)
88
-
| RS256 (** RSASSA-PKCS1-v1_5 using SHA-256 per
89
-
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3.3}RFC 7518 Section 3.3} *)
90
| RS384 (** RSASSA-PKCS1-v1_5 using SHA-384 *)
91
| RS512 (** RSASSA-PKCS1-v1_5 using SHA-512 *)
92
-
| ES256 (** ECDSA using P-256 and SHA-256 per
93
-
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3.4}RFC 7518 Section 3.4} *)
94
| ES384 (** ECDSA using P-384 and SHA-384 *)
95
| ES512 (** ECDSA using P-521 and SHA-512 *)
96
-
| EdDSA (** EdDSA using Ed25519 per
97
-
{{:https://datatracker.ietf.org/doc/html/rfc8037}RFC 8037} *)
98
99
val to_string : t -> string
100
(** Convert algorithm to JWA identifier string. *)
···
111
112
(** {1 JSON Web Key}
113
114
-
Key representation for JWT signature verification.
115
-
See {{:https://datatracker.ietf.org/doc/html/rfc7517}RFC 7517}. *)
116
117
module Jwk : sig
118
-
119
-
(** Key type per {{:https://datatracker.ietf.org/doc/html/rfc7517#section-4.1}RFC 7517 Section 4.1}. *)
120
type kty =
121
| Oct (** Octet sequence (symmetric key) *)
122
| Rsa (** RSA key *)
123
-
| Ec (** Elliptic Curve key *)
124
| Okp (** Octet Key Pair (Ed25519, X25519) *)
125
126
-
(** Elliptic curve identifiers per {{:https://datatracker.ietf.org/doc/html/rfc7518#section-6.2.1.1}RFC 7518 Section 6.2.1.1}. *)
127
type crv =
128
-
| P256 (** NIST P-256 curve *)
129
-
| P384 (** NIST P-384 curve *)
130
-
| P521 (** NIST P-521 curve *)
131
-
| Ed25519 (** Ed25519 curve per {{:https://datatracker.ietf.org/doc/html/rfc8037}RFC 8037} *)
132
133
(** A JSON Web Key. *)
134
-
type t
135
136
(** {2 Constructors} *)
137
138
val symmetric : string -> t
139
-
(** [symmetric k] creates a symmetric key from raw bytes.
140
-
Used for HMAC algorithms (HS256, HS384, HS512). *)
141
142
val ed25519_pub : string -> t
143
-
(** [ed25519_pub pub] creates an Ed25519 public key from 32-byte public key. *)
144
145
val ed25519_priv : pub:string -> priv:string -> t
146
(** [ed25519_priv ~pub ~priv] creates an Ed25519 private key. *)
···
167
(** [rsa_pub ~n ~e] creates an RSA public key from modulus and exponent. *)
168
169
val rsa_priv :
170
-
n:string -> e:string -> d:string -> p:string -> q:string ->
171
-
dp:string -> dq:string -> qi:string -> t
172
(** [rsa_priv ~n ~e ~d ~p ~q ~dp ~dq ~qi] creates an RSA private key. *)
173
174
(** {2 Accessors} *)
···
199
200
(** {1 JOSE Header}
201
202
-
The JOSE (JSON Object Signing and Encryption) Header.
203
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-5}RFC 7519 Section 5}. *)
204
205
module Header : sig
206
type t = {
207
-
alg : Algorithm.t; (** Algorithm used (REQUIRED) *)
208
-
typ : string option; (** Type - RECOMMENDED to be "JWT" per
209
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-5.1}RFC 7519 Section 5.1} *)
210
kid : string option; (** Key ID for key lookup *)
211
-
cty : string option; (** Content type - MUST be "JWT" for nested JWTs per
212
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-5.2}RFC 7519 Section 5.2} *)
213
}
214
215
val make : ?typ:string -> ?kid:string -> ?cty:string -> Algorithm.t -> t
···
228
229
(** {1 Claims}
230
231
-
JWT Claims Set.
232
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4}RFC 7519 Section 4}. *)
233
234
module Claims : sig
235
type t
236
237
(** {2 Registered Claim Names}
238
239
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1}RFC 7519 Section 4.1}. *)
240
241
val iss : t -> string option
242
-
(** Issuer claim per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.1}Section 4.1.1}. *)
243
244
val sub : t -> string option
245
-
(** Subject claim per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.2}Section 4.1.2}. *)
246
247
val aud : t -> string list
248
-
(** Audience claim per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.3}Section 4.1.3}.
249
-
Returns empty list if not present. May be single string or array in JWT. *)
250
251
val exp : t -> Ptime.t option
252
-
(** Expiration time claim per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.4}Section 4.1.4}. *)
253
254
val nbf : t -> Ptime.t option
255
-
(** Not Before claim per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.5}Section 4.1.5}. *)
256
257
val iat : t -> Ptime.t option
258
-
(** Issued At claim per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.6}Section 4.1.6}. *)
259
260
val jti : t -> string option
261
-
(** JWT ID claim per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.7}Section 4.1.7}. *)
262
263
(** {2 Custom Claims}
264
265
For Public and Private claims per
266
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.2}Sections 4.2} and
267
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.3}4.3}. *)
268
269
val get : string -> t -> Jsont.json option
270
(** [get name claims] returns the value of custom claim [name]. *)
271
272
val get_string : string -> t -> string option
273
-
(** [get_string name claims] returns the string value of custom claim [name]. *)
274
275
val get_int : string -> t -> int option
276
(** [get_int name claims] returns the integer value of custom claim [name]. *)
277
278
val get_bool : string -> t -> bool option
279
-
(** [get_bool name claims] returns the boolean value of custom claim [name]. *)
280
281
(** {2 Construction} *)
282
···
326
327
val of_json : ?strict:bool -> string -> (t, error) result
328
(** [of_json ?strict json] parses claims from JSON string.
329
-
@param strict If true (default), reject duplicate claim names per
330
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4}RFC 7519 Section 4}.
331
-
If false, use lexically last duplicate. *)
332
333
val to_json : t -> string
334
(** Serialize claims to JSON string. *)
···
337
(** {1 JWT Token} *)
338
339
type t = {
340
-
header : Header.t; (** JOSE header *)
341
-
claims : Claims.t; (** Claims set *)
342
-
signature : string; (** Raw signature bytes *)
343
-
raw : string; (** Original compact serialization *)
344
}
345
(** A parsed JWT token. *)
346
347
(** {2 Parsing}
348
349
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519 Section 7.2}. *)
350
351
val parse : ?strict:bool -> string -> (t, error) result
352
(** [parse ?strict token_string] parses a JWT from its compact serialization.
353
354
-
This parses the token structure but does NOT verify the signature.
355
-
Use {!verify} to validate the signature after parsing.
356
357
@param strict If true (default), reject duplicate claim names. *)
358
···
362
363
(** {2 Nested JWTs}
364
365
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519 Section 7.2 step 8}
366
-
and {{:https://datatracker.ietf.org/doc/html/rfc7519#appendix-A.2}Appendix A.2}. *)
367
368
val parse_nested :
369
-
?strict:bool ->
370
-
?max_depth:int ->
371
-
string ->
372
-
(t list, error) result
373
(** [parse_nested ?strict ?max_depth token] parses a potentially nested JWT.
374
Returns a list of JWTs from outermost to innermost.
375
@param max_depth Maximum nesting depth (default 5). *)
376
377
val is_nested : t -> bool
378
-
(** [is_nested t] returns true if the JWT has [cty: "JWT"] header,
379
-
indicating it contains a nested JWT. *)
380
381
(** {2 Accessors} *)
382
···
394
395
(** {2 Verification}
396
397
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519 Section 7.2}. *)
398
399
val verify :
400
key:Jwk.t ->
···
405
(** [verify ~key ?allow_none ?allowed_algs t] verifies the JWT signature.
406
407
@param key The key to verify with (must match algorithm)
408
-
@param allow_none If true, accept [alg:"none"]. Default: false.
409
-
Per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-6}RFC 7519 Section 6},
410
-
unsecured JWTs should only be used when security is provided by other means.
411
-
@param allowed_algs List of acceptable algorithms. Default: all except none.
412
-
Note: "none" is only allowed if BOTH in this list AND [allow_none=true]. *)
413
414
val validate :
415
now:Ptime.t ->
···
435
?leeway:Ptime.Span.t ->
436
t ->
437
(unit, error) result
438
-
(** [verify_and_validate ~key ~now ...] verifies signature and validates claims. *)
439
440
(** {2 Creation}
441
442
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.1}RFC 7519 Section 7.1}. *)
443
444
-
val create : header:Header.t -> claims:Claims.t -> key:Jwk.t -> (t, error) result
445
(** [create ~header ~claims ~key] creates and signs a new JWT.
446
447
-
The [key] must be appropriate for the algorithm specified in [header].
448
-
For [alg:none], pass any key (it will be ignored). *)
449
450
val encode : t -> string
451
(** [encode t] returns the compact serialization of the JWT. *)
···
453
(** {1 Utilities} *)
454
455
val is_expired : now:Ptime.t -> ?leeway:Ptime.Span.t -> t -> bool
456
-
(** [is_expired ~now ?leeway t] checks if the token has expired.
457
-
Returns false if no exp claim present. *)
458
459
val time_to_expiry : now:Ptime.t -> t -> Ptime.Span.t option
460
-
(** [time_to_expiry ~now t] returns time until expiration, or [None] if
461
-
no expiration claim or already expired. *)
462
463
(** {1 Base64url Utilities}
464
···
466
467
val base64url_encode : string -> string
468
(** Base64url encode without padding per
469
-
{{:https://datatracker.ietf.org/doc/html/rfc7515#appendix-C}RFC 7515 Appendix C}. *)
470
471
val base64url_decode : string -> (string, error) result
472
(** Base64url decode, handling missing padding. *)
···
9
{{:https://datatracker.ietf.org/doc/html/rfc7519}RFC 7519}.
10
11
JWTs are compact, URL-safe means of representing claims to be transferred
12
+
between two parties. The claims are encoded as a JSON object that is used as
13
+
the payload of a JSON Web Signature (JWS) structure, enabling the claims to
14
+
be digitally signed or integrity protected with a Message Authentication
15
Code (MAC).
16
17
{2 References}
18
+
- {{:https://datatracker.ietf.org/doc/html/rfc7519}RFC 7519} - JSON Web
19
+
Token (JWT)
20
+
- {{:https://datatracker.ietf.org/doc/html/rfc7515}RFC 7515} - JSON Web
21
+
Signature (JWS)
22
+
- {{:https://datatracker.ietf.org/doc/html/rfc7517}RFC 7517} - JSON Web Key
23
+
(JWK)
24
+
- {{:https://datatracker.ietf.org/doc/html/rfc7518}RFC 7518} - JSON Web
25
+
Algorithms (JWA) *)
26
27
(** {1 Error Handling} *)
28
29
type error =
30
+
| Invalid_json of string (** JSON parsing failed *)
31
+
| Invalid_base64url of string (** Base64url decoding failed *)
32
| Invalid_structure of string
33
(** Wrong number of parts or malformed structure *)
34
+
| Invalid_header of string (** Header validation failed *)
35
+
| Invalid_claims of string (** Claims validation failed *)
36
| Invalid_uri of string
37
(** StringOrURI validation failed per
38
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-2}RFC 7519
39
+
Section 2} *)
40
| Duplicate_claim of string
41
(** Duplicate claim name found in strict mode per
42
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4}RFC 7519
43
+
Section 4} *)
44
+
| Unsupported_algorithm of string (** Unknown algorithm identifier *)
45
| Algorithm_not_allowed of string
46
(** Algorithm rejected by allowed_algs policy *)
47
+
| Signature_mismatch (** Signature verification failed *)
48
| Token_expired
49
(** exp claim validation failed per
50
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.4}RFC
51
+
7519 Section 4.1.4} *)
52
| Token_not_yet_valid
53
(** nbf claim validation failed per
54
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.5}RFC
55
+
7519 Section 4.1.5} *)
56
| Invalid_issuer
57
(** iss claim mismatch per
58
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.1}RFC
59
+
7519 Section 4.1.1} *)
60
| Invalid_audience
61
(** aud claim mismatch per
62
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.3}RFC
63
+
7519 Section 4.1.3} *)
64
+
| Key_type_mismatch of string (** Key doesn't match algorithm *)
65
| Unsecured_not_allowed
66
(** alg:none used without explicit opt-in per
67
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-6}RFC 7519
68
+
Section 6} *)
69
+
| Nesting_too_deep (** Nested JWT exceeds max_depth *)
70
71
val pp_error : Format.formatter -> error -> unit
72
(** Pretty-print an error. *)
···
76
77
(** {1 Algorithms}
78
79
+
Signature and MAC algorithms for JWT. See
80
+
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3}RFC 7518 Section
81
+
3}. *)
82
83
module Algorithm : sig
84
type t =
85
+
| None
86
+
(** No digital signature or MAC per
87
+
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3.6}RFC
88
+
7518 Section 3.6} *)
89
+
| HS256
90
+
(** HMAC using SHA-256 per
91
+
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3.2}RFC
92
+
7518 Section 3.2} *)
93
| HS384 (** HMAC using SHA-384 *)
94
| HS512 (** HMAC using SHA-512 *)
95
+
| RS256
96
+
(** RSASSA-PKCS1-v1_5 using SHA-256 per
97
+
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3.3}RFC
98
+
7518 Section 3.3} *)
99
| RS384 (** RSASSA-PKCS1-v1_5 using SHA-384 *)
100
| RS512 (** RSASSA-PKCS1-v1_5 using SHA-512 *)
101
+
| ES256
102
+
(** ECDSA using P-256 and SHA-256 per
103
+
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3.4}RFC
104
+
7518 Section 3.4} *)
105
| ES384 (** ECDSA using P-384 and SHA-384 *)
106
| ES512 (** ECDSA using P-521 and SHA-512 *)
107
+
| EdDSA
108
+
(** EdDSA using Ed25519 per
109
+
{{:https://datatracker.ietf.org/doc/html/rfc8037}RFC 8037} *)
110
111
val to_string : t -> string
112
(** Convert algorithm to JWA identifier string. *)
···
123
124
(** {1 JSON Web Key}
125
126
+
Key representation for JWT signature verification. See
127
+
{{:https://datatracker.ietf.org/doc/html/rfc7517}RFC 7517}. *)
128
129
module Jwk : sig
130
+
(** Key type per
131
+
{{:https://datatracker.ietf.org/doc/html/rfc7517#section-4.1}RFC 7517
132
+
Section 4.1}. *)
133
type kty =
134
| Oct (** Octet sequence (symmetric key) *)
135
| Rsa (** RSA key *)
136
+
| Ec (** Elliptic Curve key *)
137
| Okp (** Octet Key Pair (Ed25519, X25519) *)
138
139
+
(** Elliptic curve identifiers per
140
+
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-6.2.1.1}RFC 7518
141
+
Section 6.2.1.1}. *)
142
type crv =
143
+
| P256 (** NIST P-256 curve *)
144
+
| P384 (** NIST P-384 curve *)
145
+
| P521 (** NIST P-521 curve *)
146
+
| Ed25519
147
+
(** Ed25519 curve per
148
+
{{:https://datatracker.ietf.org/doc/html/rfc8037}RFC 8037} *)
149
150
+
type t
151
(** A JSON Web Key. *)
152
153
(** {2 Constructors} *)
154
155
val symmetric : string -> t
156
+
(** [symmetric k] creates a symmetric key from raw bytes. Used for HMAC
157
+
algorithms (HS256, HS384, HS512). *)
158
159
val ed25519_pub : string -> t
160
+
(** [ed25519_pub pub] creates an Ed25519 public key from 32-byte public key.
161
+
*)
162
163
val ed25519_priv : pub:string -> priv:string -> t
164
(** [ed25519_priv ~pub ~priv] creates an Ed25519 private key. *)
···
185
(** [rsa_pub ~n ~e] creates an RSA public key from modulus and exponent. *)
186
187
val rsa_priv :
188
+
n:string ->
189
+
e:string ->
190
+
d:string ->
191
+
p:string ->
192
+
q:string ->
193
+
dp:string ->
194
+
dq:string ->
195
+
qi:string ->
196
+
t
197
(** [rsa_priv ~n ~e ~d ~p ~q ~dp ~dq ~qi] creates an RSA private key. *)
198
199
(** {2 Accessors} *)
···
224
225
(** {1 JOSE Header}
226
227
+
The JOSE (JSON Object Signing and Encryption) Header. See
228
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-5}RFC 7519 Section
229
+
5}. *)
230
231
module Header : sig
232
type t = {
233
+
alg : Algorithm.t; (** Algorithm used (REQUIRED) *)
234
+
typ : string option;
235
+
(** Type - RECOMMENDED to be "JWT" per
236
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-5.1}RFC
237
+
7519 Section 5.1} *)
238
kid : string option; (** Key ID for key lookup *)
239
+
cty : string option;
240
+
(** Content type - MUST be "JWT" for nested JWTs per
241
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-5.2}RFC
242
+
7519 Section 5.2} *)
243
}
244
245
val make : ?typ:string -> ?kid:string -> ?cty:string -> Algorithm.t -> t
···
258
259
(** {1 Claims}
260
261
+
JWT Claims Set. See
262
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4}RFC 7519 Section
263
+
4}. *)
264
265
module Claims : sig
266
type t
267
268
(** {2 Registered Claim Names}
269
270
+
See
271
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1}RFC 7519
272
+
Section 4.1}. *)
273
274
val iss : t -> string option
275
+
(** Issuer claim per
276
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.1}Section
277
+
4.1.1}. *)
278
279
val sub : t -> string option
280
+
(** Subject claim per
281
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.2}Section
282
+
4.1.2}. *)
283
284
val aud : t -> string list
285
+
(** Audience claim per
286
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.3}Section
287
+
4.1.3}. Returns empty list if not present. May be single string or array
288
+
in JWT. *)
289
290
val exp : t -> Ptime.t option
291
+
(** Expiration time claim per
292
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.4}Section
293
+
4.1.4}. *)
294
295
val nbf : t -> Ptime.t option
296
+
(** Not Before claim per
297
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.5}Section
298
+
4.1.5}. *)
299
300
val iat : t -> Ptime.t option
301
+
(** Issued At claim per
302
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.6}Section
303
+
4.1.6}. *)
304
305
val jti : t -> string option
306
+
(** JWT ID claim per
307
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.7}Section
308
+
4.1.7}. *)
309
310
(** {2 Custom Claims}
311
312
For Public and Private claims per
313
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.2}Sections 4.2}
314
+
and {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.3}4.3}. *)
315
316
val get : string -> t -> Jsont.json option
317
(** [get name claims] returns the value of custom claim [name]. *)
318
319
val get_string : string -> t -> string option
320
+
(** [get_string name claims] returns the string value of custom claim [name].
321
+
*)
322
323
val get_int : string -> t -> int option
324
(** [get_int name claims] returns the integer value of custom claim [name]. *)
325
326
val get_bool : string -> t -> bool option
327
+
(** [get_bool name claims] returns the boolean value of custom claim [name].
328
+
*)
329
330
(** {2 Construction} *)
331
···
375
376
val of_json : ?strict:bool -> string -> (t, error) result
377
(** [of_json ?strict json] parses claims from JSON string.
378
+
@param strict
379
+
If true (default), reject duplicate claim names per
380
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4}RFC 7519
381
+
Section 4}. If false, use lexically last duplicate. *)
382
383
val to_json : t -> string
384
(** Serialize claims to JSON string. *)
···
387
(** {1 JWT Token} *)
388
389
type t = {
390
+
header : Header.t; (** JOSE header *)
391
+
claims : Claims.t; (** Claims set *)
392
+
signature : string; (** Raw signature bytes *)
393
+
raw : string; (** Original compact serialization *)
394
}
395
(** A parsed JWT token. *)
396
397
(** {2 Parsing}
398
399
+
See
400
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519
401
+
Section 7.2}. *)
402
403
val parse : ?strict:bool -> string -> (t, error) result
404
(** [parse ?strict token_string] parses a JWT from its compact serialization.
405
406
+
This parses the token structure but does NOT verify the signature. Use
407
+
{!verify} to validate the signature after parsing.
408
409
@param strict If true (default), reject duplicate claim names. *)
410
···
414
415
(** {2 Nested JWTs}
416
417
+
See
418
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519
419
+
Section 7.2 step 8} and
420
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#appendix-A.2}Appendix A.2}.
421
+
*)
422
423
val parse_nested :
424
+
?strict:bool -> ?max_depth:int -> string -> (t list, error) result
425
(** [parse_nested ?strict ?max_depth token] parses a potentially nested JWT.
426
Returns a list of JWTs from outermost to innermost.
427
@param max_depth Maximum nesting depth (default 5). *)
428
429
val is_nested : t -> bool
430
+
(** [is_nested t] returns true if the JWT has [cty: "JWT"] header, indicating it
431
+
contains a nested JWT. *)
432
433
(** {2 Accessors} *)
434
···
446
447
(** {2 Verification}
448
449
+
See
450
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519
451
+
Section 7.2}. *)
452
453
val verify :
454
key:Jwk.t ->
···
459
(** [verify ~key ?allow_none ?allowed_algs t] verifies the JWT signature.
460
461
@param key The key to verify with (must match algorithm)
462
+
@param allow_none
463
+
If true, accept [alg:"none"]. Default: false. Per
464
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-6}RFC 7519
465
+
Section 6}, unsecured JWTs should only be used when security is provided
466
+
by other means.
467
+
@param allowed_algs
468
+
List of acceptable algorithms. Default: all except none. Note: "none" is
469
+
only allowed if BOTH in this list AND [allow_none=true]. *)
470
471
val validate :
472
now:Ptime.t ->
···
492
?leeway:Ptime.Span.t ->
493
t ->
494
(unit, error) result
495
+
(** [verify_and_validate ~key ~now ...] verifies signature and validates claims.
496
+
*)
497
498
(** {2 Creation}
499
500
+
See
501
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.1}RFC 7519
502
+
Section 7.1}. *)
503
504
+
val create :
505
+
header:Header.t -> claims:Claims.t -> key:Jwk.t -> (t, error) result
506
(** [create ~header ~claims ~key] creates and signs a new JWT.
507
508
+
The [key] must be appropriate for the algorithm specified in [header]. For
509
+
[alg:none], pass any key (it will be ignored). *)
510
511
val encode : t -> string
512
(** [encode t] returns the compact serialization of the JWT. *)
···
514
(** {1 Utilities} *)
515
516
val is_expired : now:Ptime.t -> ?leeway:Ptime.Span.t -> t -> bool
517
+
(** [is_expired ~now ?leeway t] checks if the token has expired. Returns false
518
+
if no exp claim present. *)
519
520
val time_to_expiry : now:Ptime.t -> t -> Ptime.Span.t option
521
+
(** [time_to_expiry ~now t] returns time until expiration, or [None] if no
522
+
expiration claim or already expired. *)
523
524
(** {1 Base64url Utilities}
525
···
527
528
val base64url_encode : string -> string
529
(** Base64url encode without padding per
530
+
{{:https://datatracker.ietf.org/doc/html/rfc7515#appendix-C}RFC 7515
531
+
Appendix C}. *)
532
533
val base64url_decode : string -> (string, error) result
534
(** Base64url decode, handling missing padding. *)
+379
-296
ocaml-jsonwt/test/test_cbor.ml
+379
-296
ocaml-jsonwt/test/test_cbor.ml
···
1
(** CBOR Encoding Tests
2
3
-
Tests derived from RFC 8949 Appendix A (Examples of Encoded CBOR Data Items). *)
4
5
(* Helper to encode to hex string *)
6
let encode_to_hex f =
···
10
f enc;
11
Cbort.Rw.flush_encoder enc;
12
let bytes = Buffer.contents buf in
13
-
String.concat "" (List.init (String.length bytes) (fun i ->
14
-
Printf.sprintf "%02x" (Char.code (String.get bytes i))))
15
16
(* Helper to convert hex string to bytes for comparison *)
17
let hex_to_bytes hex =
···
63
Alcotest.(check string) "1000000" "1a000f4240" hex
64
65
let test_uint_1000000000000 () =
66
-
let hex = encode_to_hex (fun enc -> Cbort.Rw.write_int64 enc 1000000000000L) in
67
Alcotest.(check string) "1000000000000" "1b000000e8d4a51000" hex
68
69
(* ============= Negative Integer Tests ============= *)
···
172
173
let test_text_utf8_emoji () =
174
(* U+10151 = 𐅑 = 0xf0 0x90 0x85 0x91 in UTF-8 *)
175
-
let hex = encode_to_hex (fun enc -> Cbort.Rw.write_text enc "\xf0\x90\x85\x91") in
176
Alcotest.(check string) "𐅑" "64f0908591" hex
177
178
(* ============= Byte String Tests ============= *)
179
180
let test_bytes_empty () =
181
-
let hex = encode_to_hex (fun enc ->
182
-
Cbort.Rw.write_bytes_header enc 0) in
183
Alcotest.(check string) "empty bytes" "40" hex
184
185
let test_bytes_01020304 () =
186
-
let hex = encode_to_hex (fun enc ->
187
-
Cbort.Rw.write_bytes_header enc 4;
188
-
Cbort.Rw.write_bytes enc (hex_to_bytes "01020304")) in
189
Alcotest.(check string) "h'01020304'" "4401020304" hex
190
191
(* ============= Array Tests ============= *)
···
195
Alcotest.(check string) "[]" "80" hex
196
197
let test_array_123 () =
198
-
let hex = encode_to_hex (fun enc ->
199
-
Cbort.Rw.write_array_start enc 3;
200
-
Cbort.Rw.write_int enc 1;
201
-
Cbort.Rw.write_int enc 2;
202
-
Cbort.Rw.write_int enc 3) in
203
Alcotest.(check string) "[1, 2, 3]" "83010203" hex
204
205
let test_array_nested () =
206
(* [1, [2, 3], [4, 5]] *)
207
-
let hex = encode_to_hex (fun enc ->
208
-
Cbort.Rw.write_array_start enc 3;
209
-
Cbort.Rw.write_int enc 1;
210
-
Cbort.Rw.write_array_start enc 2;
211
-
Cbort.Rw.write_int enc 2;
212
-
Cbort.Rw.write_int enc 3;
213
-
Cbort.Rw.write_array_start enc 2;
214
-
Cbort.Rw.write_int enc 4;
215
-
Cbort.Rw.write_int enc 5) in
216
Alcotest.(check string) "[1, [2, 3], [4, 5]]" "8301820203820405" hex
217
218
let test_array_25_items () =
219
(* [1, 2, 3, ..., 25] - requires 1-byte length encoding *)
220
-
let hex = encode_to_hex (fun enc ->
221
-
Cbort.Rw.write_array_start enc 25;
222
-
for i = 1 to 25 do
223
-
Cbort.Rw.write_int enc i
224
-
done) in
225
(* 0x98 0x19 = array with 1-byte length (25) *)
226
-
Alcotest.(check string) "[1..25]" "98190102030405060708090a0b0c0d0e0f101112131415161718181819" hex
227
228
(* ============= Map Tests ============= *)
229
···
233
234
let test_map_int_keys () =
235
(* {1: 2, 3: 4} *)
236
-
let hex = encode_to_hex (fun enc ->
237
-
Cbort.Rw.write_map_start enc 2;
238
-
Cbort.Rw.write_int enc 1;
239
-
Cbort.Rw.write_int enc 2;
240
-
Cbort.Rw.write_int enc 3;
241
-
Cbort.Rw.write_int enc 4) in
242
Alcotest.(check string) "{1: 2, 3: 4}" "a201020304" hex
243
244
let test_map_string_keys () =
245
(* {"a": 1, "b": [2, 3]} *)
246
-
let hex = encode_to_hex (fun enc ->
247
-
Cbort.Rw.write_map_start enc 2;
248
-
Cbort.Rw.write_text enc "a";
249
-
Cbort.Rw.write_int enc 1;
250
-
Cbort.Rw.write_text enc "b";
251
-
Cbort.Rw.write_array_start enc 2;
252
-
Cbort.Rw.write_int enc 2;
253
-
Cbort.Rw.write_int enc 3) in
254
Alcotest.(check string) "{\"a\": 1, \"b\": [2, 3]}" "a26161016162820203" hex
255
256
let test_mixed_array_map () =
257
(* ["a", {"b": "c"}] *)
258
-
let hex = encode_to_hex (fun enc ->
259
-
Cbort.Rw.write_array_start enc 2;
260
-
Cbort.Rw.write_text enc "a";
261
-
Cbort.Rw.write_map_start enc 1;
262
-
Cbort.Rw.write_text enc "b";
263
-
Cbort.Rw.write_text enc "c") in
264
Alcotest.(check string) "[\"a\", {\"b\": \"c\"}]" "826161a161626163" hex
265
266
let test_map_5_pairs () =
267
(* {"a": "A", "b": "B", "c": "C", "d": "D", "e": "E"} *)
268
-
let hex = encode_to_hex (fun enc ->
269
-
Cbort.Rw.write_map_start enc 5;
270
-
Cbort.Rw.write_text enc "a"; Cbort.Rw.write_text enc "A";
271
-
Cbort.Rw.write_text enc "b"; Cbort.Rw.write_text enc "B";
272
-
Cbort.Rw.write_text enc "c"; Cbort.Rw.write_text enc "C";
273
-
Cbort.Rw.write_text enc "d"; Cbort.Rw.write_text enc "D";
274
-
Cbort.Rw.write_text enc "e"; Cbort.Rw.write_text enc "E") in
275
-
Alcotest.(check string) "{a:A, b:B, c:C, d:D, e:E}" "a56161614161626142616361436164614461656145" hex
276
277
(* ============= Tag Tests ============= *)
278
279
let test_tag_epoch_timestamp () =
280
(* 1(1363896240) - epoch-based date/time *)
281
-
let hex = encode_to_hex (fun enc ->
282
-
Cbort.Rw.write_type_arg enc Cbort.Rw.major_tag 1;
283
-
Cbort.Rw.write_int enc 1363896240) in
284
Alcotest.(check string) "1(1363896240)" "c11a514b67b0" hex
285
286
(* ============= Major Type Constants Test ============= *)
···
313
(* Round-trip tests using Cbort.encode_string and Cbort.decode_string *)
314
315
let test_codec_int_roundtrip () =
316
-
let values = [0; 1; 23; 24; 100; 1000; 1000000; -1; -10; -100; -1000] in
317
-
List.iter (fun v ->
318
-
let encoded = Cbort.encode_string Cbort.int v in
319
-
match Cbort.decode_string Cbort.int encoded with
320
-
| Ok decoded -> Alcotest.(check int) (Printf.sprintf "int %d" v) v decoded
321
-
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
322
-
) values
323
324
let test_codec_int64_roundtrip () =
325
-
let values = [0L; 1L; 1000000000000L; -1L; Int64.max_int; Int64.min_int] in
326
-
List.iter (fun v ->
327
-
let encoded = Cbort.encode_string Cbort.int64 v in
328
-
match Cbort.decode_string Cbort.int64 encoded with
329
-
| Ok decoded -> Alcotest.(check int64) (Printf.sprintf "int64 %Ld" v) v decoded
330
-
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
331
-
) values
332
333
let test_codec_bool_roundtrip () =
334
-
List.iter (fun v ->
335
-
let encoded = Cbort.encode_string Cbort.bool v in
336
-
match Cbort.decode_string Cbort.bool encoded with
337
-
| Ok decoded -> Alcotest.(check bool) (Printf.sprintf "bool %b" v) v decoded
338
-
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
339
-
) [true; false]
340
341
let test_codec_null_roundtrip () =
342
let encoded = Cbort.encode_string Cbort.null () in
···
345
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
346
347
let test_codec_float_roundtrip () =
348
-
let values = [0.0; 1.0; -1.0; 1.5; 3.14159; 1e10; -1e-10] in
349
-
List.iter (fun v ->
350
-
let encoded = Cbort.encode_string Cbort.float v in
351
-
match Cbort.decode_string Cbort.float encoded with
352
-
| Ok decoded ->
353
-
let diff = abs_float (v -. decoded) in
354
-
Alcotest.(check bool) (Printf.sprintf "float %g" v) true (diff < 1e-10)
355
-
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
356
-
) values
357
358
let test_codec_string_roundtrip () =
359
-
let values = [""; "a"; "hello"; "UTF-8: \xc3\xbc \xe6\xb0\xb4"; "with\nnewline"] in
360
-
List.iter (fun v ->
361
-
let encoded = Cbort.encode_string Cbort.string v in
362
-
match Cbort.decode_string Cbort.string encoded with
363
-
| Ok decoded -> Alcotest.(check string) (Printf.sprintf "string %S" v) v decoded
364
-
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
365
-
) values
366
367
let test_codec_bytes_roundtrip () =
368
-
let values = [""; "\x00\x01\x02\x03"; String.make 100 '\xff'] in
369
-
List.iter (fun v ->
370
-
let encoded = Cbort.encode_string Cbort.bytes v in
371
-
match Cbort.decode_string Cbort.bytes encoded with
372
-
| Ok decoded -> Alcotest.(check string) "bytes" v decoded
373
-
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
374
-
) values
375
376
let test_codec_array_roundtrip () =
377
-
let values = [[]; [1]; [1;2;3]; List.init 25 (fun i -> i)] in
378
let int_list = Cbort.array Cbort.int in
379
-
List.iter (fun v ->
380
-
let encoded = Cbort.encode_string int_list v in
381
-
match Cbort.decode_string int_list encoded with
382
-
| Ok decoded -> Alcotest.(check (list int)) "array" v decoded
383
-
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
384
-
) values
385
386
let test_codec_nested_array () =
387
let nested = Cbort.array (Cbort.array Cbort.int) in
388
-
let v = [[1;2]; [3;4;5]; []] in
389
let encoded = Cbort.encode_string nested v in
390
match Cbort.decode_string nested encoded with
391
| Ok decoded -> Alcotest.(check (list (list int))) "nested array" v decoded
···
393
394
let test_codec_string_map_roundtrip () =
395
let map = Cbort.string_map Cbort.int in
396
-
let v = [("a", 1); ("b", 2); ("c", 3)] in
397
let encoded = Cbort.encode_string map v in
398
match Cbort.decode_string map encoded with
399
| Ok decoded ->
400
(* Maps may reorder, so sort before comparing *)
401
let sort = List.sort compare in
402
-
Alcotest.(check (list (pair string int))) "string map" (sort v) (sort decoded)
403
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
404
405
let test_codec_int_map_roundtrip () =
406
let map = Cbort.int_map Cbort.string in
407
-
let v = [(1, "one"); (2, "two"); (3, "three")] in
408
let encoded = Cbort.encode_string map v in
409
match Cbort.decode_string map encoded with
410
| Ok decoded ->
411
let sort = List.sort compare in
412
-
Alcotest.(check (list (pair int string))) "int map" (sort v) (sort decoded)
413
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
414
415
let test_codec_tuple2 () =
···
426
let encoded = Cbort.encode_string codec v in
427
match Cbort.decode_string codec encoded with
428
| Ok decoded ->
429
-
let (a, b, c) = decoded in
430
Alcotest.(check int) "tuple3.0" 42 a;
431
Alcotest.(check string) "tuple3.1" "hello" b;
432
Alcotest.(check bool) "tuple3.2" true c
···
438
let v1 = Some 42 in
439
let encoded1 = Cbort.encode_string codec v1 in
440
(match Cbort.decode_string codec encoded1 with
441
-
| Ok decoded -> Alcotest.(check (option int)) "nullable some" v1 decoded
442
-
| Error e -> Alcotest.fail (Cbort.Error.to_string e));
443
(* Test None *)
444
let v2 = None in
445
let encoded2 = Cbort.encode_string codec v2 in
···
452
type person = { name : string; age : int; email : string option }
453
454
let person_codec =
455
-
Cbort.Obj.finish @@
456
let open Cbort.Obj in
457
let* name = mem "name" (fun p -> p.name) Cbort.string in
458
let* age = mem "age" (fun p -> p.age) Cbort.int in
···
484
(* CWT-style claims with integer keys per RFC 8392:
485
1=iss, 2=sub, 3=aud, 4=exp, 5=nbf, 6=iat, 7=cti *)
486
type cwt_claims = {
487
-
iss : string option; (* key 1 *)
488
-
sub : string option; (* key 2 *)
489
-
exp : int64 option; (* key 4 *)
490
}
491
492
let cwt_claims_codec =
493
-
Cbort.Obj_int.finish @@
494
let open Cbort.Obj_int in
495
let* iss = mem_opt 1 (fun c -> c.iss) Cbort.string in
496
let* sub = mem_opt 2 (fun c -> c.sub) Cbort.string in
···
498
return { iss; sub; exp }
499
500
let test_obj_int_codec () =
501
-
let v = { iss = Some "https://example.com"; sub = Some "user123"; exp = Some 1700000000L } in
502
let encoded = Cbort.encode_string cwt_claims_codec v in
503
match Cbort.decode_string cwt_claims_codec encoded with
504
| Ok decoded ->
···
525
let v = 1363896240L in
526
let encoded = Cbort.encode_string epoch_codec v in
527
(* Should match RFC 8949 example: c11a514b67b0 *)
528
-
let hex = String.concat "" (List.init (String.length encoded) (fun i ->
529
-
Printf.sprintf "%02x" (Char.code (String.get encoded i)))) in
530
Alcotest.(check string) "epoch tag hex" "c11a514b67b0" hex;
531
match Cbort.decode_string epoch_codec encoded with
532
| Ok decoded -> Alcotest.(check int64) "epoch value" v decoded
···
539
(* Encode with tag *)
540
let encoded = Cbort.encode_string uri_codec v in
541
(match Cbort.decode_string uri_codec encoded with
542
-
| Ok decoded -> Alcotest.(check string) "uri tagged" v decoded
543
-
| Error e -> Alcotest.fail (Cbort.Error.to_string e));
544
(* Decode without tag should also work *)
545
let plain = Cbort.encode_string Cbort.string v in
546
match Cbort.decode_string uri_codec plain with
···
551
552
let test_decode_rfc_integers () =
553
(* RFC 8949 Appendix A test vectors *)
554
-
let tests = [
555
-
("00", 0L);
556
-
("01", 1L);
557
-
("0a", 10L);
558
-
("17", 23L);
559
-
("1818", 24L);
560
-
("1819", 25L);
561
-
("1864", 100L);
562
-
("1903e8", 1000L);
563
-
("1a000f4240", 1000000L);
564
-
("1b000000e8d4a51000", 1000000000000L);
565
-
("20", -1L);
566
-
("29", -10L);
567
-
("3863", -100L);
568
-
("3903e7", -1000L);
569
-
] in
570
-
List.iter (fun (hex, expected) ->
571
-
let bytes = hex_to_bytes hex in
572
-
match Cbort.decode_string Cbort.int64 bytes with
573
-
| Ok decoded -> Alcotest.(check int64) hex expected decoded
574
-
| Error e -> Alcotest.fail (Printf.sprintf "%s: %s" hex (Cbort.Error.to_string e))
575
-
) tests
576
577
let test_decode_rfc_strings () =
578
-
let tests = [
579
-
("60", "");
580
-
("6161", "a");
581
-
("6449455446", "IETF");
582
-
("62225c", "\"\\");
583
-
("62c3bc", "\xc3\xbc"); (* ü *)
584
-
("63e6b0b4", "\xe6\xb0\xb4"); (* 水 *)
585
-
] in
586
-
List.iter (fun (hex, expected) ->
587
-
let bytes = hex_to_bytes hex in
588
-
match Cbort.decode_string Cbort.string bytes with
589
-
| Ok decoded -> Alcotest.(check string) hex expected decoded
590
-
| Error e -> Alcotest.fail (Printf.sprintf "%s: %s" hex (Cbort.Error.to_string e))
591
-
) tests
592
593
let test_decode_rfc_arrays () =
594
let int_list = Cbort.array Cbort.int in
595
-
let tests = [
596
-
("80", []);
597
-
("83010203", [1; 2; 3]);
598
-
] in
599
-
List.iter (fun (hex, expected) ->
600
-
let bytes = hex_to_bytes hex in
601
-
match Cbort.decode_string int_list bytes with
602
-
| Ok decoded -> Alcotest.(check (list int)) hex expected decoded
603
-
| Error e -> Alcotest.fail (Printf.sprintf "%s: %s" hex (Cbort.Error.to_string e))
604
-
) tests
605
606
let test_decode_rfc_booleans () =
607
-
let tests = [
608
-
("f4", false);
609
-
("f5", true);
610
-
] in
611
-
List.iter (fun (hex, expected) ->
612
-
let bytes = hex_to_bytes hex in
613
-
match Cbort.decode_string Cbort.bool bytes with
614
-
| Ok decoded -> Alcotest.(check bool) hex expected decoded
615
-
| Error e -> Alcotest.fail (Printf.sprintf "%s: %s" hex (Cbort.Error.to_string e))
616
-
) tests
617
618
let test_decode_rfc_null () =
619
let bytes = hex_to_bytes "f6" in
···
625
626
let test_decode_type_mismatch () =
627
(* Try to decode an integer as a string *)
628
-
let bytes = hex_to_bytes "01" in (* integer 1 *)
629
match Cbort.decode_string Cbort.string bytes with
630
| Ok _ -> Alcotest.fail "Expected type mismatch error"
631
| Error e ->
632
let msg = Cbort.Error.to_string e in
633
-
Alcotest.(check bool) "error contains type info" true (String.length msg > 0)
634
635
let test_decode_truncated () =
636
(* Truncated integer (header says 4 bytes follow but only 2 provided) *)
···
642
(* ============= Test Runner ============= *)
643
644
let () =
645
-
Alcotest.run "Cbort" [
646
-
(* Low-level encoding tests *)
647
-
"Unsigned Integers (RFC 8949)", [
648
-
Alcotest.test_case "0" `Quick test_uint_0;
649
-
Alcotest.test_case "1" `Quick test_uint_1;
650
-
Alcotest.test_case "10" `Quick test_uint_10;
651
-
Alcotest.test_case "23" `Quick test_uint_23;
652
-
Alcotest.test_case "24" `Quick test_uint_24;
653
-
Alcotest.test_case "25" `Quick test_uint_25;
654
-
Alcotest.test_case "100" `Quick test_uint_100;
655
-
Alcotest.test_case "1000" `Quick test_uint_1000;
656
-
Alcotest.test_case "1000000" `Quick test_uint_1000000;
657
-
Alcotest.test_case "1000000000000" `Quick test_uint_1000000000000;
658
-
];
659
-
"Negative Integers (RFC 8949)", [
660
-
Alcotest.test_case "-1" `Quick test_nint_minus1;
661
-
Alcotest.test_case "-10" `Quick test_nint_minus10;
662
-
Alcotest.test_case "-100" `Quick test_nint_minus100;
663
-
Alcotest.test_case "-1000" `Quick test_nint_minus1000;
664
-
];
665
-
"Booleans and Null (RFC 8949)", [
666
-
Alcotest.test_case "false" `Quick test_false;
667
-
Alcotest.test_case "true" `Quick test_true;
668
-
Alcotest.test_case "null" `Quick test_null;
669
-
];
670
-
"Floats (RFC 8949)", [
671
-
Alcotest.test_case "1.0" `Quick test_float_1_0;
672
-
Alcotest.test_case "1.1" `Quick test_float_1_1;
673
-
Alcotest.test_case "-4.1" `Quick test_float_neg_4_1;
674
-
Alcotest.test_case "1.0e+300" `Quick test_float_1e300;
675
-
Alcotest.test_case "Infinity" `Quick test_float_infinity;
676
-
Alcotest.test_case "-Infinity" `Quick test_float_neg_infinity;
677
-
Alcotest.test_case "NaN" `Quick test_float_nan;
678
-
];
679
-
"Text Strings (RFC 8949)", [
680
-
Alcotest.test_case "empty" `Quick test_text_empty;
681
-
Alcotest.test_case "a" `Quick test_text_a;
682
-
Alcotest.test_case "IETF" `Quick test_text_ietf;
683
-
Alcotest.test_case "quote_backslash" `Quick test_text_quote_backslash;
684
-
Alcotest.test_case "utf8_umlaut" `Quick test_text_utf8_umlaut;
685
-
Alcotest.test_case "utf8_water" `Quick test_text_utf8_water;
686
-
Alcotest.test_case "utf8_emoji" `Quick test_text_utf8_emoji;
687
-
];
688
-
"Byte Strings (RFC 8949)", [
689
-
Alcotest.test_case "empty" `Quick test_bytes_empty;
690
-
Alcotest.test_case "01020304" `Quick test_bytes_01020304;
691
-
];
692
-
"Arrays (RFC 8949)", [
693
-
Alcotest.test_case "empty" `Quick test_array_empty;
694
-
Alcotest.test_case "[1,2,3]" `Quick test_array_123;
695
-
Alcotest.test_case "nested" `Quick test_array_nested;
696
-
Alcotest.test_case "25_items" `Quick test_array_25_items;
697
-
];
698
-
"Maps (RFC 8949)", [
699
-
Alcotest.test_case "empty" `Quick test_map_empty;
700
-
Alcotest.test_case "int_keys" `Quick test_map_int_keys;
701
-
Alcotest.test_case "string_keys" `Quick test_map_string_keys;
702
-
Alcotest.test_case "mixed" `Quick test_mixed_array_map;
703
-
Alcotest.test_case "5_pairs" `Quick test_map_5_pairs;
704
-
];
705
-
"Tags (RFC 8949)", [
706
-
Alcotest.test_case "epoch_timestamp" `Quick test_tag_epoch_timestamp;
707
-
];
708
-
"Constants", [
709
-
Alcotest.test_case "major_types" `Quick test_major_type_constants;
710
-
Alcotest.test_case "simple_values" `Quick test_simple_value_constants;
711
-
Alcotest.test_case "additional_info" `Quick test_additional_info_constants;
712
-
];
713
-
(* High-level codec roundtrip tests *)
714
-
"Codec Roundtrip", [
715
-
Alcotest.test_case "int" `Quick test_codec_int_roundtrip;
716
-
Alcotest.test_case "int64" `Quick test_codec_int64_roundtrip;
717
-
Alcotest.test_case "bool" `Quick test_codec_bool_roundtrip;
718
-
Alcotest.test_case "null" `Quick test_codec_null_roundtrip;
719
-
Alcotest.test_case "float" `Quick test_codec_float_roundtrip;
720
-
Alcotest.test_case "string" `Quick test_codec_string_roundtrip;
721
-
Alcotest.test_case "bytes" `Quick test_codec_bytes_roundtrip;
722
-
Alcotest.test_case "array" `Quick test_codec_array_roundtrip;
723
-
Alcotest.test_case "nested_array" `Quick test_codec_nested_array;
724
-
Alcotest.test_case "string_map" `Quick test_codec_string_map_roundtrip;
725
-
Alcotest.test_case "int_map" `Quick test_codec_int_map_roundtrip;
726
-
Alcotest.test_case "tuple2" `Quick test_codec_tuple2;
727
-
Alcotest.test_case "tuple3" `Quick test_codec_tuple3;
728
-
Alcotest.test_case "nullable" `Quick test_codec_nullable;
729
-
];
730
-
"Obj Codec (String Keys)", [
731
-
Alcotest.test_case "basic" `Quick test_obj_codec_basic;
732
-
Alcotest.test_case "with_optional" `Quick test_obj_codec_with_optional;
733
-
];
734
-
"Obj_int Codec (Integer Keys)", [
735
-
Alcotest.test_case "full" `Quick test_obj_int_codec;
736
-
Alcotest.test_case "partial" `Quick test_obj_int_partial;
737
-
];
738
-
"Tag Codec", [
739
-
Alcotest.test_case "tag" `Quick test_codec_tag;
740
-
Alcotest.test_case "tag_opt" `Quick test_codec_tag_opt;
741
-
];
742
-
"Decode RFC Vectors", [
743
-
Alcotest.test_case "integers" `Quick test_decode_rfc_integers;
744
-
Alcotest.test_case "strings" `Quick test_decode_rfc_strings;
745
-
Alcotest.test_case "arrays" `Quick test_decode_rfc_arrays;
746
-
Alcotest.test_case "booleans" `Quick test_decode_rfc_booleans;
747
-
Alcotest.test_case "null" `Quick test_decode_rfc_null;
748
-
];
749
-
"Error Handling", [
750
-
Alcotest.test_case "type_mismatch" `Quick test_decode_type_mismatch;
751
-
Alcotest.test_case "truncated" `Quick test_decode_truncated;
752
-
];
753
-
]
···
1
(** CBOR Encoding Tests
2
3
+
Tests derived from RFC 8949 Appendix A (Examples of Encoded CBOR Data
4
+
Items). *)
5
6
(* Helper to encode to hex string *)
7
let encode_to_hex f =
···
11
f enc;
12
Cbort.Rw.flush_encoder enc;
13
let bytes = Buffer.contents buf in
14
+
String.concat ""
15
+
(List.init (String.length bytes) (fun i ->
16
+
Printf.sprintf "%02x" (Char.code (String.get bytes i))))
17
18
(* Helper to convert hex string to bytes for comparison *)
19
let hex_to_bytes hex =
···
65
Alcotest.(check string) "1000000" "1a000f4240" hex
66
67
let test_uint_1000000000000 () =
68
+
let hex =
69
+
encode_to_hex (fun enc -> Cbort.Rw.write_int64 enc 1000000000000L)
70
+
in
71
Alcotest.(check string) "1000000000000" "1b000000e8d4a51000" hex
72
73
(* ============= Negative Integer Tests ============= *)
···
176
177
let test_text_utf8_emoji () =
178
(* U+10151 = 𐅑 = 0xf0 0x90 0x85 0x91 in UTF-8 *)
179
+
let hex =
180
+
encode_to_hex (fun enc -> Cbort.Rw.write_text enc "\xf0\x90\x85\x91")
181
+
in
182
Alcotest.(check string) "𐅑" "64f0908591" hex
183
184
(* ============= Byte String Tests ============= *)
185
186
let test_bytes_empty () =
187
+
let hex = encode_to_hex (fun enc -> Cbort.Rw.write_bytes_header enc 0) in
188
Alcotest.(check string) "empty bytes" "40" hex
189
190
let test_bytes_01020304 () =
191
+
let hex =
192
+
encode_to_hex (fun enc ->
193
+
Cbort.Rw.write_bytes_header enc 4;
194
+
Cbort.Rw.write_bytes enc (hex_to_bytes "01020304"))
195
+
in
196
Alcotest.(check string) "h'01020304'" "4401020304" hex
197
198
(* ============= Array Tests ============= *)
···
202
Alcotest.(check string) "[]" "80" hex
203
204
let test_array_123 () =
205
+
let hex =
206
+
encode_to_hex (fun enc ->
207
+
Cbort.Rw.write_array_start enc 3;
208
+
Cbort.Rw.write_int enc 1;
209
+
Cbort.Rw.write_int enc 2;
210
+
Cbort.Rw.write_int enc 3)
211
+
in
212
Alcotest.(check string) "[1, 2, 3]" "83010203" hex
213
214
let test_array_nested () =
215
(* [1, [2, 3], [4, 5]] *)
216
+
let hex =
217
+
encode_to_hex (fun enc ->
218
+
Cbort.Rw.write_array_start enc 3;
219
+
Cbort.Rw.write_int enc 1;
220
+
Cbort.Rw.write_array_start enc 2;
221
+
Cbort.Rw.write_int enc 2;
222
+
Cbort.Rw.write_int enc 3;
223
+
Cbort.Rw.write_array_start enc 2;
224
+
Cbort.Rw.write_int enc 4;
225
+
Cbort.Rw.write_int enc 5)
226
+
in
227
Alcotest.(check string) "[1, [2, 3], [4, 5]]" "8301820203820405" hex
228
229
let test_array_25_items () =
230
(* [1, 2, 3, ..., 25] - requires 1-byte length encoding *)
231
+
let hex =
232
+
encode_to_hex (fun enc ->
233
+
Cbort.Rw.write_array_start enc 25;
234
+
for i = 1 to 25 do
235
+
Cbort.Rw.write_int enc i
236
+
done)
237
+
in
238
(* 0x98 0x19 = array with 1-byte length (25) *)
239
+
Alcotest.(check string)
240
+
"[1..25]" "98190102030405060708090a0b0c0d0e0f101112131415161718181819" hex
241
242
(* ============= Map Tests ============= *)
243
···
247
248
let test_map_int_keys () =
249
(* {1: 2, 3: 4} *)
250
+
let hex =
251
+
encode_to_hex (fun enc ->
252
+
Cbort.Rw.write_map_start enc 2;
253
+
Cbort.Rw.write_int enc 1;
254
+
Cbort.Rw.write_int enc 2;
255
+
Cbort.Rw.write_int enc 3;
256
+
Cbort.Rw.write_int enc 4)
257
+
in
258
Alcotest.(check string) "{1: 2, 3: 4}" "a201020304" hex
259
260
let test_map_string_keys () =
261
(* {"a": 1, "b": [2, 3]} *)
262
+
let hex =
263
+
encode_to_hex (fun enc ->
264
+
Cbort.Rw.write_map_start enc 2;
265
+
Cbort.Rw.write_text enc "a";
266
+
Cbort.Rw.write_int enc 1;
267
+
Cbort.Rw.write_text enc "b";
268
+
Cbort.Rw.write_array_start enc 2;
269
+
Cbort.Rw.write_int enc 2;
270
+
Cbort.Rw.write_int enc 3)
271
+
in
272
Alcotest.(check string) "{\"a\": 1, \"b\": [2, 3]}" "a26161016162820203" hex
273
274
let test_mixed_array_map () =
275
(* ["a", {"b": "c"}] *)
276
+
let hex =
277
+
encode_to_hex (fun enc ->
278
+
Cbort.Rw.write_array_start enc 2;
279
+
Cbort.Rw.write_text enc "a";
280
+
Cbort.Rw.write_map_start enc 1;
281
+
Cbort.Rw.write_text enc "b";
282
+
Cbort.Rw.write_text enc "c")
283
+
in
284
Alcotest.(check string) "[\"a\", {\"b\": \"c\"}]" "826161a161626163" hex
285
286
let test_map_5_pairs () =
287
(* {"a": "A", "b": "B", "c": "C", "d": "D", "e": "E"} *)
288
+
let hex =
289
+
encode_to_hex (fun enc ->
290
+
Cbort.Rw.write_map_start enc 5;
291
+
Cbort.Rw.write_text enc "a";
292
+
Cbort.Rw.write_text enc "A";
293
+
Cbort.Rw.write_text enc "b";
294
+
Cbort.Rw.write_text enc "B";
295
+
Cbort.Rw.write_text enc "c";
296
+
Cbort.Rw.write_text enc "C";
297
+
Cbort.Rw.write_text enc "d";
298
+
Cbort.Rw.write_text enc "D";
299
+
Cbort.Rw.write_text enc "e";
300
+
Cbort.Rw.write_text enc "E")
301
+
in
302
+
Alcotest.(check string)
303
+
"{a:A, b:B, c:C, d:D, e:E}" "a56161614161626142616361436164614461656145" hex
304
305
(* ============= Tag Tests ============= *)
306
307
let test_tag_epoch_timestamp () =
308
(* 1(1363896240) - epoch-based date/time *)
309
+
let hex =
310
+
encode_to_hex (fun enc ->
311
+
Cbort.Rw.write_type_arg enc Cbort.Rw.major_tag 1;
312
+
Cbort.Rw.write_int enc 1363896240)
313
+
in
314
Alcotest.(check string) "1(1363896240)" "c11a514b67b0" hex
315
316
(* ============= Major Type Constants Test ============= *)
···
343
(* Round-trip tests using Cbort.encode_string and Cbort.decode_string *)
344
345
let test_codec_int_roundtrip () =
346
+
let values = [ 0; 1; 23; 24; 100; 1000; 1000000; -1; -10; -100; -1000 ] in
347
+
List.iter
348
+
(fun v ->
349
+
let encoded = Cbort.encode_string Cbort.int v in
350
+
match Cbort.decode_string Cbort.int encoded with
351
+
| Ok decoded -> Alcotest.(check int) (Printf.sprintf "int %d" v) v decoded
352
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e))
353
+
values
354
355
let test_codec_int64_roundtrip () =
356
+
let values = [ 0L; 1L; 1000000000000L; -1L; Int64.max_int; Int64.min_int ] in
357
+
List.iter
358
+
(fun v ->
359
+
let encoded = Cbort.encode_string Cbort.int64 v in
360
+
match Cbort.decode_string Cbort.int64 encoded with
361
+
| Ok decoded ->
362
+
Alcotest.(check int64) (Printf.sprintf "int64 %Ld" v) v decoded
363
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e))
364
+
values
365
366
let test_codec_bool_roundtrip () =
367
+
List.iter
368
+
(fun v ->
369
+
let encoded = Cbort.encode_string Cbort.bool v in
370
+
match Cbort.decode_string Cbort.bool encoded with
371
+
| Ok decoded ->
372
+
Alcotest.(check bool) (Printf.sprintf "bool %b" v) v decoded
373
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e))
374
+
[ true; false ]
375
376
let test_codec_null_roundtrip () =
377
let encoded = Cbort.encode_string Cbort.null () in
···
380
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
381
382
let test_codec_float_roundtrip () =
383
+
let values = [ 0.0; 1.0; -1.0; 1.5; 3.14159; 1e10; -1e-10 ] in
384
+
List.iter
385
+
(fun v ->
386
+
let encoded = Cbort.encode_string Cbort.float v in
387
+
match Cbort.decode_string Cbort.float encoded with
388
+
| Ok decoded ->
389
+
let diff = abs_float (v -. decoded) in
390
+
Alcotest.(check bool) (Printf.sprintf "float %g" v) true (diff < 1e-10)
391
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e))
392
+
values
393
394
let test_codec_string_roundtrip () =
395
+
let values =
396
+
[ ""; "a"; "hello"; "UTF-8: \xc3\xbc \xe6\xb0\xb4"; "with\nnewline" ]
397
+
in
398
+
List.iter
399
+
(fun v ->
400
+
let encoded = Cbort.encode_string Cbort.string v in
401
+
match Cbort.decode_string Cbort.string encoded with
402
+
| Ok decoded ->
403
+
Alcotest.(check string) (Printf.sprintf "string %S" v) v decoded
404
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e))
405
+
values
406
407
let test_codec_bytes_roundtrip () =
408
+
let values = [ ""; "\x00\x01\x02\x03"; String.make 100 '\xff' ] in
409
+
List.iter
410
+
(fun v ->
411
+
let encoded = Cbort.encode_string Cbort.bytes v in
412
+
match Cbort.decode_string Cbort.bytes encoded with
413
+
| Ok decoded -> Alcotest.(check string) "bytes" v decoded
414
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e))
415
+
values
416
417
let test_codec_array_roundtrip () =
418
+
let values = [ []; [ 1 ]; [ 1; 2; 3 ]; List.init 25 (fun i -> i) ] in
419
let int_list = Cbort.array Cbort.int in
420
+
List.iter
421
+
(fun v ->
422
+
let encoded = Cbort.encode_string int_list v in
423
+
match Cbort.decode_string int_list encoded with
424
+
| Ok decoded -> Alcotest.(check (list int)) "array" v decoded
425
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e))
426
+
values
427
428
let test_codec_nested_array () =
429
let nested = Cbort.array (Cbort.array Cbort.int) in
430
+
let v = [ [ 1; 2 ]; [ 3; 4; 5 ]; [] ] in
431
let encoded = Cbort.encode_string nested v in
432
match Cbort.decode_string nested encoded with
433
| Ok decoded -> Alcotest.(check (list (list int))) "nested array" v decoded
···
435
436
let test_codec_string_map_roundtrip () =
437
let map = Cbort.string_map Cbort.int in
438
+
let v = [ ("a", 1); ("b", 2); ("c", 3) ] in
439
let encoded = Cbort.encode_string map v in
440
match Cbort.decode_string map encoded with
441
| Ok decoded ->
442
(* Maps may reorder, so sort before comparing *)
443
let sort = List.sort compare in
444
+
Alcotest.(check (list (pair string int)))
445
+
"string map" (sort v) (sort decoded)
446
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
447
448
let test_codec_int_map_roundtrip () =
449
let map = Cbort.int_map Cbort.string in
450
+
let v = [ (1, "one"); (2, "two"); (3, "three") ] in
451
let encoded = Cbort.encode_string map v in
452
match Cbort.decode_string map encoded with
453
| Ok decoded ->
454
let sort = List.sort compare in
455
+
Alcotest.(check (list (pair int string)))
456
+
"int map" (sort v) (sort decoded)
457
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
458
459
let test_codec_tuple2 () =
···
470
let encoded = Cbort.encode_string codec v in
471
match Cbort.decode_string codec encoded with
472
| Ok decoded ->
473
+
let a, b, c = decoded in
474
Alcotest.(check int) "tuple3.0" 42 a;
475
Alcotest.(check string) "tuple3.1" "hello" b;
476
Alcotest.(check bool) "tuple3.2" true c
···
482
let v1 = Some 42 in
483
let encoded1 = Cbort.encode_string codec v1 in
484
(match Cbort.decode_string codec encoded1 with
485
+
| Ok decoded -> Alcotest.(check (option int)) "nullable some" v1 decoded
486
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e));
487
(* Test None *)
488
let v2 = None in
489
let encoded2 = Cbort.encode_string codec v2 in
···
496
type person = { name : string; age : int; email : string option }
497
498
let person_codec =
499
+
Cbort.Obj.finish
500
+
@@
501
let open Cbort.Obj in
502
let* name = mem "name" (fun p -> p.name) Cbort.string in
503
let* age = mem "age" (fun p -> p.age) Cbort.int in
···
529
(* CWT-style claims with integer keys per RFC 8392:
530
1=iss, 2=sub, 3=aud, 4=exp, 5=nbf, 6=iat, 7=cti *)
531
type cwt_claims = {
532
+
iss : string option; (* key 1 *)
533
+
sub : string option; (* key 2 *)
534
+
exp : int64 option; (* key 4 *)
535
}
536
537
let cwt_claims_codec =
538
+
Cbort.Obj_int.finish
539
+
@@
540
let open Cbort.Obj_int in
541
let* iss = mem_opt 1 (fun c -> c.iss) Cbort.string in
542
let* sub = mem_opt 2 (fun c -> c.sub) Cbort.string in
···
544
return { iss; sub; exp }
545
546
let test_obj_int_codec () =
547
+
let v =
548
+
{
549
+
iss = Some "https://example.com";
550
+
sub = Some "user123";
551
+
exp = Some 1700000000L;
552
+
}
553
+
in
554
let encoded = Cbort.encode_string cwt_claims_codec v in
555
match Cbort.decode_string cwt_claims_codec encoded with
556
| Ok decoded ->
···
577
let v = 1363896240L in
578
let encoded = Cbort.encode_string epoch_codec v in
579
(* Should match RFC 8949 example: c11a514b67b0 *)
580
+
let hex =
581
+
String.concat ""
582
+
(List.init (String.length encoded) (fun i ->
583
+
Printf.sprintf "%02x" (Char.code (String.get encoded i))))
584
+
in
585
Alcotest.(check string) "epoch tag hex" "c11a514b67b0" hex;
586
match Cbort.decode_string epoch_codec encoded with
587
| Ok decoded -> Alcotest.(check int64) "epoch value" v decoded
···
594
(* Encode with tag *)
595
let encoded = Cbort.encode_string uri_codec v in
596
(match Cbort.decode_string uri_codec encoded with
597
+
| Ok decoded -> Alcotest.(check string) "uri tagged" v decoded
598
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e));
599
(* Decode without tag should also work *)
600
let plain = Cbort.encode_string Cbort.string v in
601
match Cbort.decode_string uri_codec plain with
···
606
607
let test_decode_rfc_integers () =
608
(* RFC 8949 Appendix A test vectors *)
609
+
let tests =
610
+
[
611
+
("00", 0L);
612
+
("01", 1L);
613
+
("0a", 10L);
614
+
("17", 23L);
615
+
("1818", 24L);
616
+
("1819", 25L);
617
+
("1864", 100L);
618
+
("1903e8", 1000L);
619
+
("1a000f4240", 1000000L);
620
+
("1b000000e8d4a51000", 1000000000000L);
621
+
("20", -1L);
622
+
("29", -10L);
623
+
("3863", -100L);
624
+
("3903e7", -1000L);
625
+
]
626
+
in
627
+
List.iter
628
+
(fun (hex, expected) ->
629
+
let bytes = hex_to_bytes hex in
630
+
match Cbort.decode_string Cbort.int64 bytes with
631
+
| Ok decoded -> Alcotest.(check int64) hex expected decoded
632
+
| Error e ->
633
+
Alcotest.fail (Printf.sprintf "%s: %s" hex (Cbort.Error.to_string e)))
634
+
tests
635
636
let test_decode_rfc_strings () =
637
+
let tests =
638
+
[
639
+
("60", "");
640
+
("6161", "a");
641
+
("6449455446", "IETF");
642
+
("62225c", "\"\\");
643
+
("62c3bc", "\xc3\xbc");
644
+
(* ü *)
645
+
("63e6b0b4", "\xe6\xb0\xb4");
646
+
(* 水 *)
647
+
]
648
+
in
649
+
List.iter
650
+
(fun (hex, expected) ->
651
+
let bytes = hex_to_bytes hex in
652
+
match Cbort.decode_string Cbort.string bytes with
653
+
| Ok decoded -> Alcotest.(check string) hex expected decoded
654
+
| Error e ->
655
+
Alcotest.fail (Printf.sprintf "%s: %s" hex (Cbort.Error.to_string e)))
656
+
tests
657
658
let test_decode_rfc_arrays () =
659
let int_list = Cbort.array Cbort.int in
660
+
let tests = [ ("80", []); ("83010203", [ 1; 2; 3 ]) ] in
661
+
List.iter
662
+
(fun (hex, expected) ->
663
+
let bytes = hex_to_bytes hex in
664
+
match Cbort.decode_string int_list bytes with
665
+
| Ok decoded -> Alcotest.(check (list int)) hex expected decoded
666
+
| Error e ->
667
+
Alcotest.fail (Printf.sprintf "%s: %s" hex (Cbort.Error.to_string e)))
668
+
tests
669
670
let test_decode_rfc_booleans () =
671
+
let tests = [ ("f4", false); ("f5", true) ] in
672
+
List.iter
673
+
(fun (hex, expected) ->
674
+
let bytes = hex_to_bytes hex in
675
+
match Cbort.decode_string Cbort.bool bytes with
676
+
| Ok decoded -> Alcotest.(check bool) hex expected decoded
677
+
| Error e ->
678
+
Alcotest.fail (Printf.sprintf "%s: %s" hex (Cbort.Error.to_string e)))
679
+
tests
680
681
let test_decode_rfc_null () =
682
let bytes = hex_to_bytes "f6" in
···
688
689
let test_decode_type_mismatch () =
690
(* Try to decode an integer as a string *)
691
+
let bytes = hex_to_bytes "01" in
692
+
(* integer 1 *)
693
match Cbort.decode_string Cbort.string bytes with
694
| Ok _ -> Alcotest.fail "Expected type mismatch error"
695
| Error e ->
696
let msg = Cbort.Error.to_string e in
697
+
Alcotest.(check bool)
698
+
"error contains type info" true
699
+
(String.length msg > 0)
700
701
let test_decode_truncated () =
702
(* Truncated integer (header says 4 bytes follow but only 2 provided) *)
···
708
(* ============= Test Runner ============= *)
709
710
let () =
711
+
Alcotest.run "Cbort"
712
+
[
713
+
(* Low-level encoding tests *)
714
+
( "Unsigned Integers (RFC 8949)",
715
+
[
716
+
Alcotest.test_case "0" `Quick test_uint_0;
717
+
Alcotest.test_case "1" `Quick test_uint_1;
718
+
Alcotest.test_case "10" `Quick test_uint_10;
719
+
Alcotest.test_case "23" `Quick test_uint_23;
720
+
Alcotest.test_case "24" `Quick test_uint_24;
721
+
Alcotest.test_case "25" `Quick test_uint_25;
722
+
Alcotest.test_case "100" `Quick test_uint_100;
723
+
Alcotest.test_case "1000" `Quick test_uint_1000;
724
+
Alcotest.test_case "1000000" `Quick test_uint_1000000;
725
+
Alcotest.test_case "1000000000000" `Quick test_uint_1000000000000;
726
+
] );
727
+
( "Negative Integers (RFC 8949)",
728
+
[
729
+
Alcotest.test_case "-1" `Quick test_nint_minus1;
730
+
Alcotest.test_case "-10" `Quick test_nint_minus10;
731
+
Alcotest.test_case "-100" `Quick test_nint_minus100;
732
+
Alcotest.test_case "-1000" `Quick test_nint_minus1000;
733
+
] );
734
+
( "Booleans and Null (RFC 8949)",
735
+
[
736
+
Alcotest.test_case "false" `Quick test_false;
737
+
Alcotest.test_case "true" `Quick test_true;
738
+
Alcotest.test_case "null" `Quick test_null;
739
+
] );
740
+
( "Floats (RFC 8949)",
741
+
[
742
+
Alcotest.test_case "1.0" `Quick test_float_1_0;
743
+
Alcotest.test_case "1.1" `Quick test_float_1_1;
744
+
Alcotest.test_case "-4.1" `Quick test_float_neg_4_1;
745
+
Alcotest.test_case "1.0e+300" `Quick test_float_1e300;
746
+
Alcotest.test_case "Infinity" `Quick test_float_infinity;
747
+
Alcotest.test_case "-Infinity" `Quick test_float_neg_infinity;
748
+
Alcotest.test_case "NaN" `Quick test_float_nan;
749
+
] );
750
+
( "Text Strings (RFC 8949)",
751
+
[
752
+
Alcotest.test_case "empty" `Quick test_text_empty;
753
+
Alcotest.test_case "a" `Quick test_text_a;
754
+
Alcotest.test_case "IETF" `Quick test_text_ietf;
755
+
Alcotest.test_case "quote_backslash" `Quick test_text_quote_backslash;
756
+
Alcotest.test_case "utf8_umlaut" `Quick test_text_utf8_umlaut;
757
+
Alcotest.test_case "utf8_water" `Quick test_text_utf8_water;
758
+
Alcotest.test_case "utf8_emoji" `Quick test_text_utf8_emoji;
759
+
] );
760
+
( "Byte Strings (RFC 8949)",
761
+
[
762
+
Alcotest.test_case "empty" `Quick test_bytes_empty;
763
+
Alcotest.test_case "01020304" `Quick test_bytes_01020304;
764
+
] );
765
+
( "Arrays (RFC 8949)",
766
+
[
767
+
Alcotest.test_case "empty" `Quick test_array_empty;
768
+
Alcotest.test_case "[1,2,3]" `Quick test_array_123;
769
+
Alcotest.test_case "nested" `Quick test_array_nested;
770
+
Alcotest.test_case "25_items" `Quick test_array_25_items;
771
+
] );
772
+
( "Maps (RFC 8949)",
773
+
[
774
+
Alcotest.test_case "empty" `Quick test_map_empty;
775
+
Alcotest.test_case "int_keys" `Quick test_map_int_keys;
776
+
Alcotest.test_case "string_keys" `Quick test_map_string_keys;
777
+
Alcotest.test_case "mixed" `Quick test_mixed_array_map;
778
+
Alcotest.test_case "5_pairs" `Quick test_map_5_pairs;
779
+
] );
780
+
( "Tags (RFC 8949)",
781
+
[ Alcotest.test_case "epoch_timestamp" `Quick test_tag_epoch_timestamp ]
782
+
);
783
+
( "Constants",
784
+
[
785
+
Alcotest.test_case "major_types" `Quick test_major_type_constants;
786
+
Alcotest.test_case "simple_values" `Quick test_simple_value_constants;
787
+
Alcotest.test_case "additional_info" `Quick
788
+
test_additional_info_constants;
789
+
] );
790
+
(* High-level codec roundtrip tests *)
791
+
( "Codec Roundtrip",
792
+
[
793
+
Alcotest.test_case "int" `Quick test_codec_int_roundtrip;
794
+
Alcotest.test_case "int64" `Quick test_codec_int64_roundtrip;
795
+
Alcotest.test_case "bool" `Quick test_codec_bool_roundtrip;
796
+
Alcotest.test_case "null" `Quick test_codec_null_roundtrip;
797
+
Alcotest.test_case "float" `Quick test_codec_float_roundtrip;
798
+
Alcotest.test_case "string" `Quick test_codec_string_roundtrip;
799
+
Alcotest.test_case "bytes" `Quick test_codec_bytes_roundtrip;
800
+
Alcotest.test_case "array" `Quick test_codec_array_roundtrip;
801
+
Alcotest.test_case "nested_array" `Quick test_codec_nested_array;
802
+
Alcotest.test_case "string_map" `Quick test_codec_string_map_roundtrip;
803
+
Alcotest.test_case "int_map" `Quick test_codec_int_map_roundtrip;
804
+
Alcotest.test_case "tuple2" `Quick test_codec_tuple2;
805
+
Alcotest.test_case "tuple3" `Quick test_codec_tuple3;
806
+
Alcotest.test_case "nullable" `Quick test_codec_nullable;
807
+
] );
808
+
( "Obj Codec (String Keys)",
809
+
[
810
+
Alcotest.test_case "basic" `Quick test_obj_codec_basic;
811
+
Alcotest.test_case "with_optional" `Quick test_obj_codec_with_optional;
812
+
] );
813
+
( "Obj_int Codec (Integer Keys)",
814
+
[
815
+
Alcotest.test_case "full" `Quick test_obj_int_codec;
816
+
Alcotest.test_case "partial" `Quick test_obj_int_partial;
817
+
] );
818
+
( "Tag Codec",
819
+
[
820
+
Alcotest.test_case "tag" `Quick test_codec_tag;
821
+
Alcotest.test_case "tag_opt" `Quick test_codec_tag_opt;
822
+
] );
823
+
( "Decode RFC Vectors",
824
+
[
825
+
Alcotest.test_case "integers" `Quick test_decode_rfc_integers;
826
+
Alcotest.test_case "strings" `Quick test_decode_rfc_strings;
827
+
Alcotest.test_case "arrays" `Quick test_decode_rfc_arrays;
828
+
Alcotest.test_case "booleans" `Quick test_decode_rfc_booleans;
829
+
Alcotest.test_case "null" `Quick test_decode_rfc_null;
830
+
] );
831
+
( "Error Handling",
832
+
[
833
+
Alcotest.test_case "type_mismatch" `Quick test_decode_type_mismatch;
834
+
Alcotest.test_case "truncated" `Quick test_decode_truncated;
835
+
] );
836
+
]
+415
-280
ocaml-jsonwt/test/test_cwt.ml
+415
-280
ocaml-jsonwt/test/test_cwt.ml
···
1
(** CWT Library Tests
2
3
-
Tests derived from RFC 8392 (CBOR Web Token) and
4
-
RFC 9052/9053 (COSE) specifications. *)
5
6
module Cwt = Jsonwt.Cwt
7
···
18
19
(* RFC 8392 Appendix A.1: Example CWT Claims Set *)
20
let rfc_claims_hex =
21
-
"a70175636f61703a2f2f61732e6578616d706c652e636f6d02656572696b7703" ^
22
-
"7818636f61703a2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0" ^
23
-
"051a5610d9f0061a5610d9f007420b71"
24
25
(* RFC 8392 Appendix A.2.2: 256-Bit Symmetric Key *)
26
let rfc_256bit_key_hex =
27
-
"a4205820403697de87af64611c1d32a05dab0fe1fcb715a86ab435f1ec99192d" ^
28
-
"795693880104024c53796d6d6574726963323536030a"
29
30
(* Just the raw key bytes for HMAC *)
31
let rfc_256bit_key_bytes =
32
-
hex_to_bytes "403697de87af64611c1d32a05dab0fe1fcb715a86ab435f1ec99192d79569388"
33
34
(* RFC 8392 Appendix A.2.3: ECDSA P-256 Key *)
35
-
let rfc_p256_d = hex_to_bytes "6c1382765aec5358f117733d281c1c7bdc39884d04a45a1e6c67c858bc206c19"
36
-
let rfc_p256_x = hex_to_bytes "143329cce7868e416927599cf65a34f3ce2ffda55a7eca69ed8919a394d42f0f"
37
-
let rfc_p256_y = hex_to_bytes "60f7f1a780d8a783bfb7a2dd6b2796e8128dbbcef9d3d168db9529971a36e7b9"
38
39
(* RFC 8392 Appendix A.3: Signed CWT *)
40
let rfc_signed_cwt_hex =
41
-
"d28443a10126a104524173796d6d657472696345434453413235365850a70175" ^
42
-
"636f61703a2f2f61732e6578616d706c652e636f6d02656572696b77037818636f" ^
43
-
"61703a2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0051a5610d" ^
44
-
"9f0061a5610d9f007420b7158405427c1ff28d23fbad1f29c4c7c6a555e601d6f" ^
45
-
"a29f9179bc3d7438bacaca5acd08c8d4d4f96131680c429a01f85951ecee743a5" ^
46
-
"2b9b63632c57209120e1c9e30"
47
48
(* RFC 8392 Appendix A.4: MACed CWT with CWT tag *)
49
let rfc_maced_cwt_hex =
50
-
"d83dd18443a10104a1044c53796d6d65747269633235365850a70175636f6170" ^
51
-
"3a2f2f61732e6578616d706c652e636f6d02656572696b77037818636f61703a" ^
52
-
"2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0051a5610d9f006" ^
53
-
"1a5610d9f007420b7148093101ef6d789200"
54
55
(* ============= COSE Algorithm Tests ============= *)
56
57
let test_algorithm_roundtrip () =
58
let open Cwt.Algorithm in
59
-
let algs = [ ES256; ES384; ES512; EdDSA; HMAC_256_64; HMAC_256; HMAC_384; HMAC_512 ] in
60
-
List.iter (fun alg ->
61
-
let cose_int = to_cose_int alg in
62
-
match of_cose_int cose_int with
63
-
| Ok alg' ->
64
-
Alcotest.(check int) "roundtrip" cose_int (to_cose_int alg')
65
-
| Error e ->
66
-
Alcotest.fail (Cwt.error_to_string e)
67
-
) algs
68
69
let test_algorithm_cose_values () =
70
let open Cwt.Algorithm in
···
88
89
let test_cose_key_symmetric () =
90
let key = Cwt.Cose_key.symmetric "my-secret-key-32-bytes-long!!!!!" in
91
-
Alcotest.(check bool) "kty is Symmetric" true (Cwt.Cose_key.kty key = Cwt.Cose_key.Symmetric)
92
93
let test_cose_key_ed25519 () =
94
let pub = String.make 32 '\x00' in
95
let key = Cwt.Cose_key.ed25519_pub pub in
96
-
Alcotest.(check bool) "kty is Okp" true (Cwt.Cose_key.kty key = Cwt.Cose_key.Okp);
97
-
Alcotest.(check bool) "alg is EdDSA" true (Cwt.Cose_key.alg key = Some Cwt.Algorithm.EdDSA)
98
99
let test_cose_key_p256 () =
100
let x = String.make 32 '\x00' in
101
let y = String.make 32 '\x00' in
102
let key = Cwt.Cose_key.p256_pub ~x ~y in
103
-
Alcotest.(check bool) "kty is Ec2" true (Cwt.Cose_key.kty key = Cwt.Cose_key.Ec2);
104
-
Alcotest.(check bool) "alg is ES256" true (Cwt.Cose_key.alg key = Some Cwt.Algorithm.ES256)
105
106
let test_cose_key_with_kid () =
107
let key = Cwt.Cose_key.symmetric "secret" in
108
Alcotest.(check (option string)) "no kid" None (Cwt.Cose_key.kid key);
109
let key' = Cwt.Cose_key.with_kid "my-key-id" key in
110
-
Alcotest.(check (option string)) "has kid" (Some "my-key-id") (Cwt.Cose_key.kid key')
111
112
(* ============= Claims Tests ============= *)
113
···
118
|> Cwt.Claims.set_sub "test-subject"
119
|> Cwt.Claims.build
120
in
121
-
Alcotest.(check (option string)) "iss" (Some "test-issuer") (Cwt.Claims.iss claims);
122
-
Alcotest.(check (option string)) "sub" (Some "test-subject") (Cwt.Claims.sub claims)
123
124
let test_claims_with_timestamps () =
125
-
let now = Ptime.of_float_s 1443944944. |> Option.get in (* RFC 8392 example iat *)
126
-
let exp = Ptime.of_float_s 1444064944. |> Option.get in (* RFC 8392 example exp *)
127
let claims =
128
-
Cwt.Claims.empty
129
-
|> Cwt.Claims.set_iat now
130
-
|> Cwt.Claims.set_nbf now
131
-
|> Cwt.Claims.set_exp exp
132
-
|> Cwt.Claims.build
133
in
134
-
Alcotest.(check (option bool)) "has exp" (Some true) (Option.map (fun _ -> true) (Cwt.Claims.exp claims));
135
-
Alcotest.(check (option bool)) "has iat" (Some true) (Option.map (fun _ -> true) (Cwt.Claims.iat claims));
136
-
Alcotest.(check (option bool)) "has nbf" (Some true) (Option.map (fun _ -> true) (Cwt.Claims.nbf claims))
137
138
let test_claims_audience_single () =
139
let claims =
···
141
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
142
|> Cwt.Claims.build
143
in
144
-
Alcotest.(check (list string)) "aud" [ "coap://light.example.com" ] (Cwt.Claims.aud claims)
145
146
let test_claims_audience_multiple () =
147
let claims =
···
149
|> Cwt.Claims.set_aud [ "aud1"; "aud2"; "aud3" ]
150
|> Cwt.Claims.build
151
in
152
-
Alcotest.(check (list string)) "aud" [ "aud1"; "aud2"; "aud3" ] (Cwt.Claims.aud claims)
153
154
let test_claims_cti () =
155
let claims =
156
-
Cwt.Claims.empty
157
-
|> Cwt.Claims.set_cti "\x0b\x71"
158
-
|> Cwt.Claims.build
159
in
160
-
Alcotest.(check (option string)) "cti" (Some "\x0b\x71") (Cwt.Claims.cti claims)
161
162
let test_claims_to_cbor () =
163
(* Build claims like RFC 8392 example *)
···
169
|> Cwt.Claims.set_iss "coap://as.example.com"
170
|> Cwt.Claims.set_sub "erikw"
171
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
172
-
|> Cwt.Claims.set_exp exp
173
-
|> Cwt.Claims.set_nbf nbf
174
|> Cwt.Claims.set_iat iat
175
|> Cwt.Claims.set_cti "\x0b\x71"
176
|> Cwt.Claims.build
···
193
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
194
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
195
| Ok cwt ->
196
-
Alcotest.(check (option string)) "iss" (Some "test-issuer") (Cwt.Claims.iss (Cwt.claims cwt));
197
-
Alcotest.(check bool) "has algorithm" true (Option.is_some (Cwt.algorithm cwt));
198
let encoded = Cwt.encode cwt in
199
Alcotest.(check bool) "non-empty encoding" true (String.length encoded > 0)
200
| Error e ->
201
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
202
203
let test_create_hmac_256_64_cwt () =
204
let claims =
205
-
Cwt.Claims.empty
206
-
|> Cwt.Claims.set_iss "test-issuer"
207
-
|> Cwt.Claims.build
208
in
209
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
210
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256_64 ~claims ~key with
211
| Ok cwt ->
212
-
Alcotest.(check bool) "alg is HMAC_256_64" true
213
(Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_256_64)
214
| Error e ->
215
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
216
217
let test_create_es256_cwt () =
218
let claims =
219
-
Cwt.Claims.empty
220
-
|> Cwt.Claims.set_iss "test-issuer"
221
-
|> Cwt.Claims.build
222
in
223
let key = Cwt.Cose_key.p256_priv ~x:rfc_p256_x ~y:rfc_p256_y ~d:rfc_p256_d in
224
match Cwt.create ~algorithm:Cwt.Algorithm.ES256 ~claims ~key with
225
| Ok cwt ->
226
-
Alcotest.(check bool) "alg is ES256" true (Cwt.algorithm cwt = Some Cwt.Algorithm.ES256);
227
let encoded = Cwt.encode cwt in
228
(* Should start with COSE_Sign1 tag (0xd2 = 18) *)
229
-
Alcotest.(check int) "COSE_Sign1 tag" 0xd2 (Char.code (String.get encoded 0))
230
| Error e ->
231
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
232
233
let test_create_key_mismatch () =
234
let claims =
235
-
Cwt.Claims.empty
236
-
|> Cwt.Claims.set_iss "test"
237
-
|> Cwt.Claims.build
238
in
239
(* Symmetric key with ES256 algorithm *)
240
let key = Cwt.Cose_key.symmetric "secret" in
241
match Cwt.create ~algorithm:Cwt.Algorithm.ES256 ~claims ~key with
242
| Error (Cwt.Key_type_mismatch _) -> ()
243
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Key_type_mismatch, got: %s" (Cwt.error_to_string e))
244
| Ok _ -> Alcotest.fail "Expected key type mismatch error"
245
246
(* ============= Claims Validation Tests ============= *)
247
248
let test_validate_expired_token () =
249
let exp = Ptime.of_float_s 1300819380. |> Option.get in
250
-
let now = Ptime.of_float_s 1400000000. |> Option.get in (* After exp *)
251
-
let claims =
252
-
Cwt.Claims.empty
253
-
|> Cwt.Claims.set_exp exp
254
-
|> Cwt.Claims.build
255
-
in
256
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
257
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
258
-
| Ok cwt ->
259
-
begin match Cwt.validate ~now cwt with
260
| Error Cwt.Token_expired -> ()
261
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Token_expired, got: %s" (Cwt.error_to_string e))
262
| Ok () -> Alcotest.fail "Expected Token_expired error"
263
-
end
264
| Error e -> Alcotest.fail (Cwt.error_to_string e)
265
266
let test_validate_not_yet_valid_token () =
267
let nbf = Ptime.of_float_s 1500000000. |> Option.get in
268
-
let now = Ptime.of_float_s 1400000000. |> Option.get in (* Before nbf *)
269
-
let claims =
270
-
Cwt.Claims.empty
271
-
|> Cwt.Claims.set_nbf nbf
272
-
|> Cwt.Claims.build
273
-
in
274
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
275
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
276
-
| Ok cwt ->
277
-
begin match Cwt.validate ~now cwt with
278
| Error Cwt.Token_not_yet_valid -> ()
279
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Token_not_yet_valid, got: %s" (Cwt.error_to_string e))
280
| Ok () -> Alcotest.fail "Expected Token_not_yet_valid error"
281
-
end
282
| Error e -> Alcotest.fail (Cwt.error_to_string e)
283
284
let test_validate_with_leeway () =
285
let exp = Ptime.of_float_s 1300819380. |> Option.get in
286
-
let now = Ptime.of_float_s 1300819390. |> Option.get in (* 10 seconds after exp *)
287
-
let leeway = Ptime.Span.of_int_s 60 in (* 60 second leeway *)
288
-
let claims =
289
-
Cwt.Claims.empty
290
-
|> Cwt.Claims.set_exp exp
291
-
|> Cwt.Claims.build
292
-
in
293
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
294
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
295
-
| Ok cwt ->
296
-
begin match Cwt.validate ~now ~leeway cwt with
297
| Ok () -> ()
298
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass with leeway, got: %s" (Cwt.error_to_string e))
299
-
end
300
| Error e -> Alcotest.fail (Cwt.error_to_string e)
301
302
let test_validate_issuer_match () =
303
let now = Ptime.of_float_s 1400000000. |> Option.get in
304
let claims =
305
-
Cwt.Claims.empty
306
-
|> Cwt.Claims.set_iss "expected-issuer"
307
-
|> Cwt.Claims.build
308
in
309
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
310
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
311
-
| Ok cwt ->
312
-
begin match Cwt.validate ~now ~iss:"expected-issuer" cwt with
313
| Ok () -> ()
314
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass, got: %s" (Cwt.error_to_string e))
315
-
end
316
| Error e -> Alcotest.fail (Cwt.error_to_string e)
317
318
let test_validate_issuer_mismatch () =
319
let now = Ptime.of_float_s 1400000000. |> Option.get in
320
let claims =
321
-
Cwt.Claims.empty
322
-
|> Cwt.Claims.set_iss "actual-issuer"
323
-
|> Cwt.Claims.build
324
in
325
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
326
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
327
-
| Ok cwt ->
328
-
begin match Cwt.validate ~now ~iss:"expected-issuer" cwt with
329
| Error Cwt.Invalid_issuer -> ()
330
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_issuer, got: %s" (Cwt.error_to_string e))
331
| Ok () -> Alcotest.fail "Expected Invalid_issuer error"
332
-
end
333
| Error e -> Alcotest.fail (Cwt.error_to_string e)
334
335
let test_validate_audience_match () =
···
341
in
342
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
343
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
344
-
| Ok cwt ->
345
-
begin match Cwt.validate ~now ~aud:"my-app" cwt with
346
| Ok () -> ()
347
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass, got: %s" (Cwt.error_to_string e))
348
-
end
349
| Error e -> Alcotest.fail (Cwt.error_to_string e)
350
351
let test_validate_audience_mismatch () =
···
357
in
358
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
359
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
360
-
| Ok cwt ->
361
-
begin match Cwt.validate ~now ~aud:"my-app" cwt with
362
| Error Cwt.Invalid_audience -> ()
363
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_audience, got: %s" (Cwt.error_to_string e))
364
| Ok () -> Alcotest.fail "Expected Invalid_audience error"
365
-
end
366
| Error e -> Alcotest.fail (Cwt.error_to_string e)
367
368
(* ============= Helper Function Tests ============= *)
369
370
let test_is_expired () =
371
let exp = Ptime.of_float_s 1300819380. |> Option.get in
372
-
let claims =
373
-
Cwt.Claims.empty
374
-
|> Cwt.Claims.set_exp exp
375
-
|> Cwt.Claims.build
376
-
in
377
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
378
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
379
| Ok cwt ->
380
let now_before = Ptime.of_float_s 1300819370. |> Option.get in
381
let now_after = Ptime.of_float_s 1300819390. |> Option.get in
382
-
Alcotest.(check bool) "not expired before" false (Cwt.is_expired ~now:now_before cwt);
383
-
Alcotest.(check bool) "expired after" true (Cwt.is_expired ~now:now_after cwt)
384
| Error e -> Alcotest.fail (Cwt.error_to_string e)
385
386
let test_time_to_expiry () =
387
let exp = Ptime.of_float_s 1300819380. |> Option.get in
388
-
let claims =
389
-
Cwt.Claims.empty
390
-
|> Cwt.Claims.set_exp exp
391
-
|> Cwt.Claims.build
392
-
in
393
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
394
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
395
| Ok cwt ->
···
398
| Some span ->
399
let seconds = Ptime.Span.to_float_s span |> int_of_float in
400
Alcotest.(check int) "time to expiry" 10 seconds
401
-
| None ->
402
-
Alcotest.fail "Expected Some time to expiry"
403
end
404
| Error e -> Alcotest.fail (Cwt.error_to_string e)
405
406
(* ============= Error Type Tests ============= *)
407
408
let test_error_to_string () =
409
-
let errors = [
410
-
(Cwt.Invalid_cbor "test", "Invalid CBOR: test");
411
-
(Cwt.Invalid_cose "test", "Invalid COSE: test");
412
-
(Cwt.Invalid_claims "test", "Invalid claims: test");
413
-
(Cwt.Token_expired, "Token expired");
414
-
(Cwt.Token_not_yet_valid, "Token not yet valid");
415
-
(Cwt.Signature_mismatch, "Signature mismatch");
416
-
] in
417
-
List.iter (fun (err, expected) ->
418
-
let actual = Cwt.error_to_string err in
419
-
Alcotest.(check string) "error string" expected actual
420
-
) errors
421
422
(* ============= RFC 8392 Test Vector References ============= *)
423
···
432
|> Cwt.Claims.set_iss "coap://as.example.com"
433
|> Cwt.Claims.set_sub "erikw"
434
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
435
-
|> Cwt.Claims.set_exp exp
436
-
|> Cwt.Claims.set_nbf nbf
437
|> Cwt.Claims.set_iat iat
438
|> Cwt.Claims.set_cti "\x0b\x71"
439
|> Cwt.Claims.build
440
in
441
-
Alcotest.(check (option string)) "iss" (Some "coap://as.example.com") (Cwt.Claims.iss claims);
442
Alcotest.(check (option string)) "sub" (Some "erikw") (Cwt.Claims.sub claims);
443
-
Alcotest.(check (list string)) "aud" ["coap://light.example.com"] (Cwt.Claims.aud claims);
444
-
Alcotest.(check (option string)) "cti" (Some "\x0b\x71") (Cwt.Claims.cti claims)
445
446
(* ============= More Algorithm Coverage Tests ============= *)
447
448
let test_create_hmac_384_cwt () =
449
let claims =
450
-
Cwt.Claims.empty
451
-
|> Cwt.Claims.set_iss "test-issuer"
452
-
|> Cwt.Claims.build
453
in
454
(* Need 48-byte key for HMAC-384 *)
455
let key = Cwt.Cose_key.symmetric (String.make 48 'k') in
456
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_384 ~claims ~key with
457
| Ok cwt ->
458
-
Alcotest.(check bool) "alg is HMAC_384" true (Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_384);
459
let encoded = Cwt.encode cwt in
460
Alcotest.(check bool) "non-empty encoding" true (String.length encoded > 0)
461
| Error e ->
462
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
463
464
let test_create_hmac_512_cwt () =
465
let claims =
466
-
Cwt.Claims.empty
467
-
|> Cwt.Claims.set_iss "test-issuer"
468
-
|> Cwt.Claims.build
469
in
470
(* Need 64-byte key for HMAC-512 *)
471
let key = Cwt.Cose_key.symmetric (String.make 64 'k') in
472
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_512 ~claims ~key with
473
| Ok cwt ->
474
-
Alcotest.(check bool) "alg is HMAC_512" true (Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_512);
475
let encoded = Cwt.encode cwt in
476
Alcotest.(check bool) "non-empty encoding" true (String.length encoded > 0)
477
| Error e ->
478
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
479
480
(* ============= COSE Key Serialization Tests ============= *)
481
···
509
let cbor = hex_to_bytes rfc_256bit_key_hex in
510
match Cwt.Cose_key.of_cbor cbor with
511
| Ok key ->
512
-
Alcotest.(check bool) "key type is symmetric" true
513
(Cwt.Cose_key.kty key = Cwt.Cose_key.Symmetric);
514
-
Alcotest.(check (option string)) "kid" (Some "Symmetric256") (Cwt.Cose_key.kid key)
515
-
| Error e -> Alcotest.fail (Printf.sprintf "Failed to decode key: %s" (Cwt.error_to_string e))
516
517
(* ============= CWT Encoding Tests ============= *)
518
···
532
let encoded = Cwt.encode cwt in
533
(* COSE_Mac0 has tag 17 (0xd1) *)
534
Alcotest.(check bool) "non-empty" true (String.length encoded > 0);
535
-
Alcotest.(check (option string)) "iss preserved" (Some "roundtrip-issuer") (Cwt.Claims.iss (Cwt.claims cwt));
536
-
Alcotest.(check (option string)) "sub preserved" (Some "roundtrip-subject") (Cwt.Claims.sub (Cwt.claims cwt))
537
-
| Error e -> Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
538
539
let test_cwt_es256_encoding () =
540
let claims =
541
-
Cwt.Claims.empty
542
-
|> Cwt.Claims.set_iss "es256-issuer"
543
-
|> Cwt.Claims.build
544
in
545
-
let priv_key = Cwt.Cose_key.p256_priv ~x:rfc_p256_x ~y:rfc_p256_y ~d:rfc_p256_d in
546
match Cwt.create ~algorithm:Cwt.Algorithm.ES256 ~claims ~key:priv_key with
547
| Ok cwt ->
548
let encoded = Cwt.encode cwt in
549
(* COSE_Sign1 has tag 18 (0xd2) *)
550
-
Alcotest.(check int) "COSE_Sign1 tag" 0xd2 (Char.code (String.get encoded 0));
551
-
Alcotest.(check (option string)) "iss preserved" (Some "es256-issuer") (Cwt.Claims.iss (Cwt.claims cwt))
552
-
| Error e -> Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
553
554
let test_cwt_parse_roundtrip () =
555
(* Test that parse correctly round-trips a created CWT *)
···
565
let encoded = Cwt.encode cwt in
566
begin match Cwt.parse encoded with
567
| Ok parsed ->
568
-
Alcotest.(check (option string)) "iss" (Some "test-issuer") (Cwt.Claims.iss (Cwt.claims parsed));
569
-
Alcotest.(check (option string)) "sub" (Some "test-subject") (Cwt.Claims.sub (Cwt.claims parsed));
570
-
Alcotest.(check (option string)) "algorithm"
571
-
(Some "HMAC 256/256")
572
(Option.map Cwt.Algorithm.to_string (Cwt.algorithm parsed))
573
-
| Error e -> Alcotest.fail (Printf.sprintf "Parse failed: %s" (Cwt.error_to_string e))
574
end
575
-
| Error e -> Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
576
577
(* ============= RFC 8392 Test Vector Tests ============= *)
578
···
586
|> Cwt.Claims.set_iss "coap://as.example.com"
587
|> Cwt.Claims.set_sub "erikw"
588
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
589
-
|> Cwt.Claims.set_exp exp
590
-
|> Cwt.Claims.set_nbf nbf
591
|> Cwt.Claims.set_iat iat
592
|> Cwt.Claims.set_cti "\x0b\x71"
593
|> Cwt.Claims.build
···
595
let cbor = Cwt.Claims.to_cbor claims in
596
let expected = hex_to_bytes rfc_claims_hex in
597
(* Compare lengths first, then content *)
598
-
Alcotest.(check int) "length matches RFC" (String.length expected) (String.length cbor);
599
Alcotest.(check string) "CBOR matches RFC 8392 Appendix A.1" expected cbor
600
601
let test_rfc_claims_cbor_decoding () =
···
604
let cbor = hex_to_bytes rfc_claims_hex in
605
match Cwt.Claims.of_cbor cbor with
606
| Ok claims ->
607
-
Alcotest.(check (option string)) "iss" (Some "coap://as.example.com") (Cwt.Claims.iss claims);
608
-
Alcotest.(check (option string)) "sub" (Some "erikw") (Cwt.Claims.sub claims);
609
-
Alcotest.(check (list string)) "aud" ["coap://light.example.com"] (Cwt.Claims.aud claims);
610
-
Alcotest.(check (option string)) "cti" (Some "\x0b\x71") (Cwt.Claims.cti claims);
611
(* Check timestamps *)
612
begin match Cwt.Claims.exp claims with
613
| Some exp ->
614
let exp_float = Ptime.to_float_s exp in
615
-
Alcotest.(check bool) "exp timestamp" true (abs_float (exp_float -. 1444064944.) < 1.0)
616
| None -> Alcotest.fail "Expected exp claim"
617
end;
618
begin match Cwt.Claims.nbf claims with
619
| Some nbf ->
620
let nbf_float = Ptime.to_float_s nbf in
621
-
Alcotest.(check bool) "nbf timestamp" true (abs_float (nbf_float -. 1443944944.) < 1.0)
622
| None -> Alcotest.fail "Expected nbf claim"
623
end;
624
begin match Cwt.Claims.iat claims with
625
| Some iat ->
626
let iat_float = Ptime.to_float_s iat in
627
-
Alcotest.(check bool) "iat timestamp" true (abs_float (iat_float -. 1443944944.) < 1.0)
628
| None -> Alcotest.fail "Expected iat claim"
629
end
630
| Error (Cwt.Invalid_cbor msg) ->
···
644
match Cwt.parse cwt_bytes with
645
| Ok cwt ->
646
(* If parsing succeeds, verify the claims *)
647
-
Alcotest.(check (option string)) "iss" (Some "coap://as.example.com") (Cwt.Claims.iss (Cwt.claims cwt));
648
-
Alcotest.(check (option string)) "sub" (Some "erikw") (Cwt.Claims.sub (Cwt.claims cwt));
649
-
Alcotest.(check (option bool)) "alg is ES256" (Some true)
650
(Option.map (fun a -> a = Cwt.Algorithm.ES256) (Cwt.algorithm cwt))
651
| Error _ ->
652
(* Parse not yet implemented - that's expected *)
···
659
match Cwt.parse cwt_bytes with
660
| Ok cwt ->
661
(* If parsing succeeds, verify the claims *)
662
-
Alcotest.(check (option string)) "iss" (Some "coap://as.example.com") (Cwt.Claims.iss (Cwt.claims cwt));
663
-
Alcotest.(check (option string)) "sub" (Some "erikw") (Cwt.Claims.sub (Cwt.claims cwt));
664
-
Alcotest.(check (option bool)) "alg is HMAC_256_64" (Some true)
665
-
(Option.map (fun a -> a = Cwt.Algorithm.HMAC_256_64) (Cwt.algorithm cwt))
666
| Error _ ->
667
(* Parse not yet implemented - that's expected *)
668
()
···
673
let x = String.make 48 '\x01' in
674
let y = String.make 48 '\x02' in
675
let key = Cwt.Cose_key.p384_pub ~x ~y in
676
-
Alcotest.(check bool) "kty is Ec2" true (Cwt.Cose_key.kty key = Cwt.Cose_key.Ec2);
677
-
Alcotest.(check bool) "alg is ES384" true (Cwt.Cose_key.alg key = Some Cwt.Algorithm.ES384)
678
679
let test_cose_key_p521 () =
680
let x = String.make 66 '\x01' in
681
let y = String.make 66 '\x02' in
682
let key = Cwt.Cose_key.p521_pub ~x ~y in
683
-
Alcotest.(check bool) "kty is Ec2" true (Cwt.Cose_key.kty key = Cwt.Cose_key.Ec2);
684
-
Alcotest.(check bool) "alg is ES512" true (Cwt.Cose_key.alg key = Some Cwt.Algorithm.ES512)
685
686
(* ============= Algorithm Tests ============= *)
687
···
692
Alcotest.(check bool) "has ES384" true (List.mem Cwt.Algorithm.ES384 all);
693
Alcotest.(check bool) "has ES512" true (List.mem Cwt.Algorithm.ES512 all);
694
Alcotest.(check bool) "has EdDSA" true (List.mem Cwt.Algorithm.EdDSA all);
695
-
Alcotest.(check bool) "has HMAC_256" true (List.mem Cwt.Algorithm.HMAC_256 all);
696
-
Alcotest.(check bool) "has HMAC_384" true (List.mem Cwt.Algorithm.HMAC_384 all);
697
-
Alcotest.(check bool) "has HMAC_512" true (List.mem Cwt.Algorithm.HMAC_512 all);
698
-
Alcotest.(check bool) "has HMAC_256_64" true (List.mem Cwt.Algorithm.HMAC_256_64 all)
699
700
let test_algorithm_to_string () =
701
let open Cwt.Algorithm in
702
Alcotest.(check bool) "ES256 name" true (String.length (to_string ES256) > 0);
703
-
Alcotest.(check bool) "HMAC_256 name" true (String.length (to_string HMAC_256) > 0)
704
705
(* ============= Test Runner ============= *)
706
707
let () =
708
-
Alcotest.run "Cwt" [
709
-
"Algorithm", [
710
-
Alcotest.test_case "roundtrip" `Quick test_algorithm_roundtrip;
711
-
Alcotest.test_case "cose_values" `Quick test_algorithm_cose_values;
712
-
Alcotest.test_case "unknown" `Quick test_algorithm_unknown;
713
-
Alcotest.test_case "all_list" `Quick test_algorithm_all_list;
714
-
Alcotest.test_case "to_string" `Quick test_algorithm_to_string;
715
-
];
716
-
"COSE Key", [
717
-
Alcotest.test_case "symmetric" `Quick test_cose_key_symmetric;
718
-
Alcotest.test_case "ed25519" `Quick test_cose_key_ed25519;
719
-
Alcotest.test_case "p256" `Quick test_cose_key_p256;
720
-
Alcotest.test_case "p384" `Quick test_cose_key_p384;
721
-
Alcotest.test_case "p521" `Quick test_cose_key_p521;
722
-
Alcotest.test_case "with_kid" `Quick test_cose_key_with_kid;
723
-
];
724
-
"COSE Key Serialization", [
725
-
Alcotest.test_case "to_cbor_symmetric" `Quick test_cose_key_to_cbor_symmetric;
726
-
Alcotest.test_case "to_cbor_ed25519" `Quick test_cose_key_to_cbor_ed25519;
727
-
Alcotest.test_case "to_cbor_p256" `Quick test_cose_key_to_cbor_p256;
728
-
Alcotest.test_case "of_cbor" `Quick test_cose_key_of_cbor;
729
-
];
730
-
"Claims", [
731
-
Alcotest.test_case "builder" `Quick test_claims_builder;
732
-
Alcotest.test_case "timestamps" `Quick test_claims_with_timestamps;
733
-
Alcotest.test_case "audience_single" `Quick test_claims_audience_single;
734
-
Alcotest.test_case "audience_multiple" `Quick test_claims_audience_multiple;
735
-
Alcotest.test_case "cti" `Quick test_claims_cti;
736
-
Alcotest.test_case "to_cbor" `Quick test_claims_to_cbor;
737
-
];
738
-
"CWT Creation", [
739
-
Alcotest.test_case "hmac" `Quick test_create_hmac_cwt;
740
-
Alcotest.test_case "hmac_256_64" `Quick test_create_hmac_256_64_cwt;
741
-
Alcotest.test_case "hmac_384" `Quick test_create_hmac_384_cwt;
742
-
Alcotest.test_case "hmac_512" `Quick test_create_hmac_512_cwt;
743
-
Alcotest.test_case "es256" `Quick test_create_es256_cwt;
744
-
Alcotest.test_case "key_mismatch" `Quick test_create_key_mismatch;
745
-
];
746
-
"CWT Encoding", [
747
-
Alcotest.test_case "hmac" `Quick test_cwt_hmac_encoding;
748
-
Alcotest.test_case "es256" `Quick test_cwt_es256_encoding;
749
-
Alcotest.test_case "parse_roundtrip" `Quick test_cwt_parse_roundtrip;
750
-
];
751
-
"Claims Validation", [
752
-
Alcotest.test_case "expired" `Quick test_validate_expired_token;
753
-
Alcotest.test_case "not_yet_valid" `Quick test_validate_not_yet_valid_token;
754
-
Alcotest.test_case "with_leeway" `Quick test_validate_with_leeway;
755
-
Alcotest.test_case "issuer_match" `Quick test_validate_issuer_match;
756
-
Alcotest.test_case "issuer_mismatch" `Quick test_validate_issuer_mismatch;
757
-
Alcotest.test_case "audience_match" `Quick test_validate_audience_match;
758
-
Alcotest.test_case "audience_mismatch" `Quick test_validate_audience_mismatch;
759
-
];
760
-
"Helper Functions", [
761
-
Alcotest.test_case "is_expired" `Quick test_is_expired;
762
-
Alcotest.test_case "time_to_expiry" `Quick test_time_to_expiry;
763
-
];
764
-
"Error Types", [
765
-
Alcotest.test_case "to_string" `Quick test_error_to_string;
766
-
];
767
-
"RFC 8392 Test Vectors", [
768
-
Alcotest.test_case "claims_timestamps" `Quick test_rfc_claims_timestamps;
769
-
Alcotest.test_case "claims_cbor_encoding" `Quick test_rfc_claims_cbor_encoding;
770
-
Alcotest.test_case "claims_cbor_decoding" `Quick test_rfc_claims_cbor_decoding;
771
-
Alcotest.test_case "signed_cwt_parse" `Quick test_rfc_signed_cwt_parse;
772
-
Alcotest.test_case "maced_cwt_parse" `Quick test_rfc_maced_cwt_parse;
773
-
];
774
-
]
···
1
(** CWT Library Tests
2
3
+
Tests derived from RFC 8392 (CBOR Web Token) and RFC 9052/9053 (COSE)
4
+
specifications. *)
5
6
module Cwt = Jsonwt.Cwt
7
···
18
19
(* RFC 8392 Appendix A.1: Example CWT Claims Set *)
20
let rfc_claims_hex =
21
+
"a70175636f61703a2f2f61732e6578616d706c652e636f6d02656572696b7703"
22
+
^ "7818636f61703a2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0"
23
+
^ "051a5610d9f0061a5610d9f007420b71"
24
25
(* RFC 8392 Appendix A.2.2: 256-Bit Symmetric Key *)
26
let rfc_256bit_key_hex =
27
+
"a4205820403697de87af64611c1d32a05dab0fe1fcb715a86ab435f1ec99192d"
28
+
^ "795693880104024c53796d6d6574726963323536030a"
29
30
(* Just the raw key bytes for HMAC *)
31
let rfc_256bit_key_bytes =
32
+
hex_to_bytes
33
+
"403697de87af64611c1d32a05dab0fe1fcb715a86ab435f1ec99192d79569388"
34
35
(* RFC 8392 Appendix A.2.3: ECDSA P-256 Key *)
36
+
let rfc_p256_d =
37
+
hex_to_bytes
38
+
"6c1382765aec5358f117733d281c1c7bdc39884d04a45a1e6c67c858bc206c19"
39
+
40
+
let rfc_p256_x =
41
+
hex_to_bytes
42
+
"143329cce7868e416927599cf65a34f3ce2ffda55a7eca69ed8919a394d42f0f"
43
+
44
+
let rfc_p256_y =
45
+
hex_to_bytes
46
+
"60f7f1a780d8a783bfb7a2dd6b2796e8128dbbcef9d3d168db9529971a36e7b9"
47
48
(* RFC 8392 Appendix A.3: Signed CWT *)
49
let rfc_signed_cwt_hex =
50
+
"d28443a10126a104524173796d6d657472696345434453413235365850a70175"
51
+
^ "636f61703a2f2f61732e6578616d706c652e636f6d02656572696b77037818636f"
52
+
^ "61703a2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0051a5610d"
53
+
^ "9f0061a5610d9f007420b7158405427c1ff28d23fbad1f29c4c7c6a555e601d6f"
54
+
^ "a29f9179bc3d7438bacaca5acd08c8d4d4f96131680c429a01f85951ecee743a5"
55
+
^ "2b9b63632c57209120e1c9e30"
56
57
(* RFC 8392 Appendix A.4: MACed CWT with CWT tag *)
58
let rfc_maced_cwt_hex =
59
+
"d83dd18443a10104a1044c53796d6d65747269633235365850a70175636f6170"
60
+
^ "3a2f2f61732e6578616d706c652e636f6d02656572696b77037818636f61703a"
61
+
^ "2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0051a5610d9f006"
62
+
^ "1a5610d9f007420b7148093101ef6d789200"
63
64
(* ============= COSE Algorithm Tests ============= *)
65
66
let test_algorithm_roundtrip () =
67
let open Cwt.Algorithm in
68
+
let algs =
69
+
[ ES256; ES384; ES512; EdDSA; HMAC_256_64; HMAC_256; HMAC_384; HMAC_512 ]
70
+
in
71
+
List.iter
72
+
(fun alg ->
73
+
let cose_int = to_cose_int alg in
74
+
match of_cose_int cose_int with
75
+
| Ok alg' -> Alcotest.(check int) "roundtrip" cose_int (to_cose_int alg')
76
+
| Error e -> Alcotest.fail (Cwt.error_to_string e))
77
+
algs
78
79
let test_algorithm_cose_values () =
80
let open Cwt.Algorithm in
···
98
99
let test_cose_key_symmetric () =
100
let key = Cwt.Cose_key.symmetric "my-secret-key-32-bytes-long!!!!!" in
101
+
Alcotest.(check bool)
102
+
"kty is Symmetric" true
103
+
(Cwt.Cose_key.kty key = Cwt.Cose_key.Symmetric)
104
105
let test_cose_key_ed25519 () =
106
let pub = String.make 32 '\x00' in
107
let key = Cwt.Cose_key.ed25519_pub pub in
108
+
Alcotest.(check bool)
109
+
"kty is Okp" true
110
+
(Cwt.Cose_key.kty key = Cwt.Cose_key.Okp);
111
+
Alcotest.(check bool)
112
+
"alg is EdDSA" true
113
+
(Cwt.Cose_key.alg key = Some Cwt.Algorithm.EdDSA)
114
115
let test_cose_key_p256 () =
116
let x = String.make 32 '\x00' in
117
let y = String.make 32 '\x00' in
118
let key = Cwt.Cose_key.p256_pub ~x ~y in
119
+
Alcotest.(check bool)
120
+
"kty is Ec2" true
121
+
(Cwt.Cose_key.kty key = Cwt.Cose_key.Ec2);
122
+
Alcotest.(check bool)
123
+
"alg is ES256" true
124
+
(Cwt.Cose_key.alg key = Some Cwt.Algorithm.ES256)
125
126
let test_cose_key_with_kid () =
127
let key = Cwt.Cose_key.symmetric "secret" in
128
Alcotest.(check (option string)) "no kid" None (Cwt.Cose_key.kid key);
129
let key' = Cwt.Cose_key.with_kid "my-key-id" key in
130
+
Alcotest.(check (option string))
131
+
"has kid" (Some "my-key-id") (Cwt.Cose_key.kid key')
132
133
(* ============= Claims Tests ============= *)
134
···
139
|> Cwt.Claims.set_sub "test-subject"
140
|> Cwt.Claims.build
141
in
142
+
Alcotest.(check (option string))
143
+
"iss" (Some "test-issuer") (Cwt.Claims.iss claims);
144
+
Alcotest.(check (option string))
145
+
"sub" (Some "test-subject") (Cwt.Claims.sub claims)
146
147
let test_claims_with_timestamps () =
148
+
let now = Ptime.of_float_s 1443944944. |> Option.get in
149
+
(* RFC 8392 example iat *)
150
+
let exp = Ptime.of_float_s 1444064944. |> Option.get in
151
+
(* RFC 8392 example exp *)
152
let claims =
153
+
Cwt.Claims.empty |> Cwt.Claims.set_iat now |> Cwt.Claims.set_nbf now
154
+
|> Cwt.Claims.set_exp exp |> Cwt.Claims.build
155
in
156
+
Alcotest.(check (option bool))
157
+
"has exp" (Some true)
158
+
(Option.map (fun _ -> true) (Cwt.Claims.exp claims));
159
+
Alcotest.(check (option bool))
160
+
"has iat" (Some true)
161
+
(Option.map (fun _ -> true) (Cwt.Claims.iat claims));
162
+
Alcotest.(check (option bool))
163
+
"has nbf" (Some true)
164
+
(Option.map (fun _ -> true) (Cwt.Claims.nbf claims))
165
166
let test_claims_audience_single () =
167
let claims =
···
169
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
170
|> Cwt.Claims.build
171
in
172
+
Alcotest.(check (list string))
173
+
"aud"
174
+
[ "coap://light.example.com" ]
175
+
(Cwt.Claims.aud claims)
176
177
let test_claims_audience_multiple () =
178
let claims =
···
180
|> Cwt.Claims.set_aud [ "aud1"; "aud2"; "aud3" ]
181
|> Cwt.Claims.build
182
in
183
+
Alcotest.(check (list string))
184
+
"aud" [ "aud1"; "aud2"; "aud3" ] (Cwt.Claims.aud claims)
185
186
let test_claims_cti () =
187
let claims =
188
+
Cwt.Claims.empty |> Cwt.Claims.set_cti "\x0b\x71" |> Cwt.Claims.build
189
in
190
+
Alcotest.(check (option string))
191
+
"cti" (Some "\x0b\x71") (Cwt.Claims.cti claims)
192
193
let test_claims_to_cbor () =
194
(* Build claims like RFC 8392 example *)
···
200
|> Cwt.Claims.set_iss "coap://as.example.com"
201
|> Cwt.Claims.set_sub "erikw"
202
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
203
+
|> Cwt.Claims.set_exp exp |> Cwt.Claims.set_nbf nbf
204
|> Cwt.Claims.set_iat iat
205
|> Cwt.Claims.set_cti "\x0b\x71"
206
|> Cwt.Claims.build
···
223
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
224
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
225
| Ok cwt ->
226
+
Alcotest.(check (option string))
227
+
"iss" (Some "test-issuer")
228
+
(Cwt.Claims.iss (Cwt.claims cwt));
229
+
Alcotest.(check bool)
230
+
"has algorithm" true
231
+
(Option.is_some (Cwt.algorithm cwt));
232
let encoded = Cwt.encode cwt in
233
Alcotest.(check bool) "non-empty encoding" true (String.length encoded > 0)
234
| Error e ->
235
+
Alcotest.fail
236
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
237
238
let test_create_hmac_256_64_cwt () =
239
let claims =
240
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test-issuer" |> Cwt.Claims.build
241
in
242
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
243
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256_64 ~claims ~key with
244
| Ok cwt ->
245
+
Alcotest.(check bool)
246
+
"alg is HMAC_256_64" true
247
(Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_256_64)
248
| Error e ->
249
+
Alcotest.fail
250
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
251
252
let test_create_es256_cwt () =
253
let claims =
254
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test-issuer" |> Cwt.Claims.build
255
in
256
let key = Cwt.Cose_key.p256_priv ~x:rfc_p256_x ~y:rfc_p256_y ~d:rfc_p256_d in
257
match Cwt.create ~algorithm:Cwt.Algorithm.ES256 ~claims ~key with
258
| Ok cwt ->
259
+
Alcotest.(check bool)
260
+
"alg is ES256" true
261
+
(Cwt.algorithm cwt = Some Cwt.Algorithm.ES256);
262
let encoded = Cwt.encode cwt in
263
(* Should start with COSE_Sign1 tag (0xd2 = 18) *)
264
+
Alcotest.(check int)
265
+
"COSE_Sign1 tag" 0xd2
266
+
(Char.code (String.get encoded 0))
267
| Error e ->
268
+
Alcotest.fail
269
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
270
271
let test_create_key_mismatch () =
272
let claims =
273
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test" |> Cwt.Claims.build
274
in
275
(* Symmetric key with ES256 algorithm *)
276
let key = Cwt.Cose_key.symmetric "secret" in
277
match Cwt.create ~algorithm:Cwt.Algorithm.ES256 ~claims ~key with
278
| Error (Cwt.Key_type_mismatch _) -> ()
279
+
| Error e ->
280
+
Alcotest.fail
281
+
(Printf.sprintf "Expected Key_type_mismatch, got: %s"
282
+
(Cwt.error_to_string e))
283
| Ok _ -> Alcotest.fail "Expected key type mismatch error"
284
285
(* ============= Claims Validation Tests ============= *)
286
287
let test_validate_expired_token () =
288
let exp = Ptime.of_float_s 1300819380. |> Option.get in
289
+
let now = Ptime.of_float_s 1400000000. |> Option.get in
290
+
(* After exp *)
291
+
let claims = Cwt.Claims.empty |> Cwt.Claims.set_exp exp |> Cwt.Claims.build in
292
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
293
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
294
+
| Ok cwt -> begin
295
+
match Cwt.validate ~now cwt with
296
| Error Cwt.Token_expired -> ()
297
+
| Error e ->
298
+
Alcotest.fail
299
+
(Printf.sprintf "Expected Token_expired, got: %s"
300
+
(Cwt.error_to_string e))
301
| Ok () -> Alcotest.fail "Expected Token_expired error"
302
+
end
303
| Error e -> Alcotest.fail (Cwt.error_to_string e)
304
305
let test_validate_not_yet_valid_token () =
306
let nbf = Ptime.of_float_s 1500000000. |> Option.get in
307
+
let now = Ptime.of_float_s 1400000000. |> Option.get in
308
+
(* Before nbf *)
309
+
let claims = Cwt.Claims.empty |> Cwt.Claims.set_nbf nbf |> Cwt.Claims.build in
310
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
311
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
312
+
| Ok cwt -> begin
313
+
match Cwt.validate ~now cwt with
314
| Error Cwt.Token_not_yet_valid -> ()
315
+
| Error e ->
316
+
Alcotest.fail
317
+
(Printf.sprintf "Expected Token_not_yet_valid, got: %s"
318
+
(Cwt.error_to_string e))
319
| Ok () -> Alcotest.fail "Expected Token_not_yet_valid error"
320
+
end
321
| Error e -> Alcotest.fail (Cwt.error_to_string e)
322
323
let test_validate_with_leeway () =
324
let exp = Ptime.of_float_s 1300819380. |> Option.get in
325
+
let now = Ptime.of_float_s 1300819390. |> Option.get in
326
+
(* 10 seconds after exp *)
327
+
let leeway = Ptime.Span.of_int_s 60 in
328
+
(* 60 second leeway *)
329
+
let claims = Cwt.Claims.empty |> Cwt.Claims.set_exp exp |> Cwt.Claims.build in
330
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
331
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
332
+
| Ok cwt -> begin
333
+
match Cwt.validate ~now ~leeway cwt with
334
| Ok () -> ()
335
+
| Error e ->
336
+
Alcotest.fail
337
+
(Printf.sprintf "Expected validation to pass with leeway, got: %s"
338
+
(Cwt.error_to_string e))
339
+
end
340
| Error e -> Alcotest.fail (Cwt.error_to_string e)
341
342
let test_validate_issuer_match () =
343
let now = Ptime.of_float_s 1400000000. |> Option.get in
344
let claims =
345
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "expected-issuer" |> Cwt.Claims.build
346
in
347
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
348
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
349
+
| Ok cwt -> begin
350
+
match Cwt.validate ~now ~iss:"expected-issuer" cwt with
351
| Ok () -> ()
352
+
| Error e ->
353
+
Alcotest.fail
354
+
(Printf.sprintf "Expected validation to pass, got: %s"
355
+
(Cwt.error_to_string e))
356
+
end
357
| Error e -> Alcotest.fail (Cwt.error_to_string e)
358
359
let test_validate_issuer_mismatch () =
360
let now = Ptime.of_float_s 1400000000. |> Option.get in
361
let claims =
362
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "actual-issuer" |> Cwt.Claims.build
363
in
364
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
365
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
366
+
| Ok cwt -> begin
367
+
match Cwt.validate ~now ~iss:"expected-issuer" cwt with
368
| Error Cwt.Invalid_issuer -> ()
369
+
| Error e ->
370
+
Alcotest.fail
371
+
(Printf.sprintf "Expected Invalid_issuer, got: %s"
372
+
(Cwt.error_to_string e))
373
| Ok () -> Alcotest.fail "Expected Invalid_issuer error"
374
+
end
375
| Error e -> Alcotest.fail (Cwt.error_to_string e)
376
377
let test_validate_audience_match () =
···
383
in
384
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
385
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
386
+
| Ok cwt -> begin
387
+
match Cwt.validate ~now ~aud:"my-app" cwt with
388
| Ok () -> ()
389
+
| Error e ->
390
+
Alcotest.fail
391
+
(Printf.sprintf "Expected validation to pass, got: %s"
392
+
(Cwt.error_to_string e))
393
+
end
394
| Error e -> Alcotest.fail (Cwt.error_to_string e)
395
396
let test_validate_audience_mismatch () =
···
402
in
403
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
404
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
405
+
| Ok cwt -> begin
406
+
match Cwt.validate ~now ~aud:"my-app" cwt with
407
| Error Cwt.Invalid_audience -> ()
408
+
| Error e ->
409
+
Alcotest.fail
410
+
(Printf.sprintf "Expected Invalid_audience, got: %s"
411
+
(Cwt.error_to_string e))
412
| Ok () -> Alcotest.fail "Expected Invalid_audience error"
413
+
end
414
| Error e -> Alcotest.fail (Cwt.error_to_string e)
415
416
(* ============= Helper Function Tests ============= *)
417
418
let test_is_expired () =
419
let exp = Ptime.of_float_s 1300819380. |> Option.get in
420
+
let claims = Cwt.Claims.empty |> Cwt.Claims.set_exp exp |> Cwt.Claims.build in
421
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
422
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
423
| Ok cwt ->
424
let now_before = Ptime.of_float_s 1300819370. |> Option.get in
425
let now_after = Ptime.of_float_s 1300819390. |> Option.get in
426
+
Alcotest.(check bool)
427
+
"not expired before" false
428
+
(Cwt.is_expired ~now:now_before cwt);
429
+
Alcotest.(check bool)
430
+
"expired after" true
431
+
(Cwt.is_expired ~now:now_after cwt)
432
| Error e -> Alcotest.fail (Cwt.error_to_string e)
433
434
let test_time_to_expiry () =
435
let exp = Ptime.of_float_s 1300819380. |> Option.get in
436
+
let claims = Cwt.Claims.empty |> Cwt.Claims.set_exp exp |> Cwt.Claims.build in
437
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
438
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
439
| Ok cwt ->
···
442
| Some span ->
443
let seconds = Ptime.Span.to_float_s span |> int_of_float in
444
Alcotest.(check int) "time to expiry" 10 seconds
445
+
| None -> Alcotest.fail "Expected Some time to expiry"
446
end
447
| Error e -> Alcotest.fail (Cwt.error_to_string e)
448
449
(* ============= Error Type Tests ============= *)
450
451
let test_error_to_string () =
452
+
let errors =
453
+
[
454
+
(Cwt.Invalid_cbor "test", "Invalid CBOR: test");
455
+
(Cwt.Invalid_cose "test", "Invalid COSE: test");
456
+
(Cwt.Invalid_claims "test", "Invalid claims: test");
457
+
(Cwt.Token_expired, "Token expired");
458
+
(Cwt.Token_not_yet_valid, "Token not yet valid");
459
+
(Cwt.Signature_mismatch, "Signature mismatch");
460
+
]
461
+
in
462
+
List.iter
463
+
(fun (err, expected) ->
464
+
let actual = Cwt.error_to_string err in
465
+
Alcotest.(check string) "error string" expected actual)
466
+
errors
467
468
(* ============= RFC 8392 Test Vector References ============= *)
469
···
478
|> Cwt.Claims.set_iss "coap://as.example.com"
479
|> Cwt.Claims.set_sub "erikw"
480
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
481
+
|> Cwt.Claims.set_exp exp |> Cwt.Claims.set_nbf nbf
482
|> Cwt.Claims.set_iat iat
483
|> Cwt.Claims.set_cti "\x0b\x71"
484
|> Cwt.Claims.build
485
in
486
+
Alcotest.(check (option string))
487
+
"iss" (Some "coap://as.example.com") (Cwt.Claims.iss claims);
488
Alcotest.(check (option string)) "sub" (Some "erikw") (Cwt.Claims.sub claims);
489
+
Alcotest.(check (list string))
490
+
"aud"
491
+
[ "coap://light.example.com" ]
492
+
(Cwt.Claims.aud claims);
493
+
Alcotest.(check (option string))
494
+
"cti" (Some "\x0b\x71") (Cwt.Claims.cti claims)
495
496
(* ============= More Algorithm Coverage Tests ============= *)
497
498
let test_create_hmac_384_cwt () =
499
let claims =
500
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test-issuer" |> Cwt.Claims.build
501
in
502
(* Need 48-byte key for HMAC-384 *)
503
let key = Cwt.Cose_key.symmetric (String.make 48 'k') in
504
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_384 ~claims ~key with
505
| Ok cwt ->
506
+
Alcotest.(check bool)
507
+
"alg is HMAC_384" true
508
+
(Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_384);
509
let encoded = Cwt.encode cwt in
510
Alcotest.(check bool) "non-empty encoding" true (String.length encoded > 0)
511
| Error e ->
512
+
Alcotest.fail
513
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
514
515
let test_create_hmac_512_cwt () =
516
let claims =
517
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test-issuer" |> Cwt.Claims.build
518
in
519
(* Need 64-byte key for HMAC-512 *)
520
let key = Cwt.Cose_key.symmetric (String.make 64 'k') in
521
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_512 ~claims ~key with
522
| Ok cwt ->
523
+
Alcotest.(check bool)
524
+
"alg is HMAC_512" true
525
+
(Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_512);
526
let encoded = Cwt.encode cwt in
527
Alcotest.(check bool) "non-empty encoding" true (String.length encoded > 0)
528
| Error e ->
529
+
Alcotest.fail
530
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
531
532
(* ============= COSE Key Serialization Tests ============= *)
533
···
561
let cbor = hex_to_bytes rfc_256bit_key_hex in
562
match Cwt.Cose_key.of_cbor cbor with
563
| Ok key ->
564
+
Alcotest.(check bool)
565
+
"key type is symmetric" true
566
(Cwt.Cose_key.kty key = Cwt.Cose_key.Symmetric);
567
+
Alcotest.(check (option string))
568
+
"kid" (Some "Symmetric256") (Cwt.Cose_key.kid key)
569
+
| Error e ->
570
+
Alcotest.fail
571
+
(Printf.sprintf "Failed to decode key: %s" (Cwt.error_to_string e))
572
573
(* ============= CWT Encoding Tests ============= *)
574
···
588
let encoded = Cwt.encode cwt in
589
(* COSE_Mac0 has tag 17 (0xd1) *)
590
Alcotest.(check bool) "non-empty" true (String.length encoded > 0);
591
+
Alcotest.(check (option string))
592
+
"iss preserved" (Some "roundtrip-issuer")
593
+
(Cwt.Claims.iss (Cwt.claims cwt));
594
+
Alcotest.(check (option string))
595
+
"sub preserved" (Some "roundtrip-subject")
596
+
(Cwt.Claims.sub (Cwt.claims cwt))
597
+
| Error e ->
598
+
Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
599
600
let test_cwt_es256_encoding () =
601
let claims =
602
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "es256-issuer" |> Cwt.Claims.build
603
+
in
604
+
let priv_key =
605
+
Cwt.Cose_key.p256_priv ~x:rfc_p256_x ~y:rfc_p256_y ~d:rfc_p256_d
606
in
607
match Cwt.create ~algorithm:Cwt.Algorithm.ES256 ~claims ~key:priv_key with
608
| Ok cwt ->
609
let encoded = Cwt.encode cwt in
610
(* COSE_Sign1 has tag 18 (0xd2) *)
611
+
Alcotest.(check int)
612
+
"COSE_Sign1 tag" 0xd2
613
+
(Char.code (String.get encoded 0));
614
+
Alcotest.(check (option string))
615
+
"iss preserved" (Some "es256-issuer")
616
+
(Cwt.Claims.iss (Cwt.claims cwt))
617
+
| Error e ->
618
+
Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
619
620
let test_cwt_parse_roundtrip () =
621
(* Test that parse correctly round-trips a created CWT *)
···
631
let encoded = Cwt.encode cwt in
632
begin match Cwt.parse encoded with
633
| Ok parsed ->
634
+
Alcotest.(check (option string))
635
+
"iss" (Some "test-issuer")
636
+
(Cwt.Claims.iss (Cwt.claims parsed));
637
+
Alcotest.(check (option string))
638
+
"sub" (Some "test-subject")
639
+
(Cwt.Claims.sub (Cwt.claims parsed));
640
+
Alcotest.(check (option string))
641
+
"algorithm" (Some "HMAC 256/256")
642
(Option.map Cwt.Algorithm.to_string (Cwt.algorithm parsed))
643
+
| Error e ->
644
+
Alcotest.fail
645
+
(Printf.sprintf "Parse failed: %s" (Cwt.error_to_string e))
646
end
647
+
| Error e ->
648
+
Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
649
650
(* ============= RFC 8392 Test Vector Tests ============= *)
651
···
659
|> Cwt.Claims.set_iss "coap://as.example.com"
660
|> Cwt.Claims.set_sub "erikw"
661
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
662
+
|> Cwt.Claims.set_exp exp |> Cwt.Claims.set_nbf nbf
663
|> Cwt.Claims.set_iat iat
664
|> Cwt.Claims.set_cti "\x0b\x71"
665
|> Cwt.Claims.build
···
667
let cbor = Cwt.Claims.to_cbor claims in
668
let expected = hex_to_bytes rfc_claims_hex in
669
(* Compare lengths first, then content *)
670
+
Alcotest.(check int)
671
+
"length matches RFC" (String.length expected) (String.length cbor);
672
Alcotest.(check string) "CBOR matches RFC 8392 Appendix A.1" expected cbor
673
674
let test_rfc_claims_cbor_decoding () =
···
677
let cbor = hex_to_bytes rfc_claims_hex in
678
match Cwt.Claims.of_cbor cbor with
679
| Ok claims ->
680
+
Alcotest.(check (option string))
681
+
"iss" (Some "coap://as.example.com") (Cwt.Claims.iss claims);
682
+
Alcotest.(check (option string))
683
+
"sub" (Some "erikw") (Cwt.Claims.sub claims);
684
+
Alcotest.(check (list string))
685
+
"aud"
686
+
[ "coap://light.example.com" ]
687
+
(Cwt.Claims.aud claims);
688
+
Alcotest.(check (option string))
689
+
"cti" (Some "\x0b\x71") (Cwt.Claims.cti claims);
690
(* Check timestamps *)
691
begin match Cwt.Claims.exp claims with
692
| Some exp ->
693
let exp_float = Ptime.to_float_s exp in
694
+
Alcotest.(check bool)
695
+
"exp timestamp" true
696
+
(abs_float (exp_float -. 1444064944.) < 1.0)
697
| None -> Alcotest.fail "Expected exp claim"
698
end;
699
begin match Cwt.Claims.nbf claims with
700
| Some nbf ->
701
let nbf_float = Ptime.to_float_s nbf in
702
+
Alcotest.(check bool)
703
+
"nbf timestamp" true
704
+
(abs_float (nbf_float -. 1443944944.) < 1.0)
705
| None -> Alcotest.fail "Expected nbf claim"
706
end;
707
begin match Cwt.Claims.iat claims with
708
| Some iat ->
709
let iat_float = Ptime.to_float_s iat in
710
+
Alcotest.(check bool)
711
+
"iat timestamp" true
712
+
(abs_float (iat_float -. 1443944944.) < 1.0)
713
| None -> Alcotest.fail "Expected iat claim"
714
end
715
| Error (Cwt.Invalid_cbor msg) ->
···
729
match Cwt.parse cwt_bytes with
730
| Ok cwt ->
731
(* If parsing succeeds, verify the claims *)
732
+
Alcotest.(check (option string))
733
+
"iss" (Some "coap://as.example.com")
734
+
(Cwt.Claims.iss (Cwt.claims cwt));
735
+
Alcotest.(check (option string))
736
+
"sub" (Some "erikw")
737
+
(Cwt.Claims.sub (Cwt.claims cwt));
738
+
Alcotest.(check (option bool))
739
+
"alg is ES256" (Some true)
740
(Option.map (fun a -> a = Cwt.Algorithm.ES256) (Cwt.algorithm cwt))
741
| Error _ ->
742
(* Parse not yet implemented - that's expected *)
···
749
match Cwt.parse cwt_bytes with
750
| Ok cwt ->
751
(* If parsing succeeds, verify the claims *)
752
+
Alcotest.(check (option string))
753
+
"iss" (Some "coap://as.example.com")
754
+
(Cwt.Claims.iss (Cwt.claims cwt));
755
+
Alcotest.(check (option string))
756
+
"sub" (Some "erikw")
757
+
(Cwt.Claims.sub (Cwt.claims cwt));
758
+
Alcotest.(check (option bool))
759
+
"alg is HMAC_256_64" (Some true)
760
+
(Option.map
761
+
(fun a -> a = Cwt.Algorithm.HMAC_256_64)
762
+
(Cwt.algorithm cwt))
763
| Error _ ->
764
(* Parse not yet implemented - that's expected *)
765
()
···
770
let x = String.make 48 '\x01' in
771
let y = String.make 48 '\x02' in
772
let key = Cwt.Cose_key.p384_pub ~x ~y in
773
+
Alcotest.(check bool)
774
+
"kty is Ec2" true
775
+
(Cwt.Cose_key.kty key = Cwt.Cose_key.Ec2);
776
+
Alcotest.(check bool)
777
+
"alg is ES384" true
778
+
(Cwt.Cose_key.alg key = Some Cwt.Algorithm.ES384)
779
780
let test_cose_key_p521 () =
781
let x = String.make 66 '\x01' in
782
let y = String.make 66 '\x02' in
783
let key = Cwt.Cose_key.p521_pub ~x ~y in
784
+
Alcotest.(check bool)
785
+
"kty is Ec2" true
786
+
(Cwt.Cose_key.kty key = Cwt.Cose_key.Ec2);
787
+
Alcotest.(check bool)
788
+
"alg is ES512" true
789
+
(Cwt.Cose_key.alg key = Some Cwt.Algorithm.ES512)
790
791
(* ============= Algorithm Tests ============= *)
792
···
797
Alcotest.(check bool) "has ES384" true (List.mem Cwt.Algorithm.ES384 all);
798
Alcotest.(check bool) "has ES512" true (List.mem Cwt.Algorithm.ES512 all);
799
Alcotest.(check bool) "has EdDSA" true (List.mem Cwt.Algorithm.EdDSA all);
800
+
Alcotest.(check bool)
801
+
"has HMAC_256" true
802
+
(List.mem Cwt.Algorithm.HMAC_256 all);
803
+
Alcotest.(check bool)
804
+
"has HMAC_384" true
805
+
(List.mem Cwt.Algorithm.HMAC_384 all);
806
+
Alcotest.(check bool)
807
+
"has HMAC_512" true
808
+
(List.mem Cwt.Algorithm.HMAC_512 all);
809
+
Alcotest.(check bool)
810
+
"has HMAC_256_64" true
811
+
(List.mem Cwt.Algorithm.HMAC_256_64 all)
812
813
let test_algorithm_to_string () =
814
let open Cwt.Algorithm in
815
Alcotest.(check bool) "ES256 name" true (String.length (to_string ES256) > 0);
816
+
Alcotest.(check bool)
817
+
"HMAC_256 name" true
818
+
(String.length (to_string HMAC_256) > 0)
819
820
(* ============= Test Runner ============= *)
821
822
let () =
823
+
Alcotest.run "Cwt"
824
+
[
825
+
( "Algorithm",
826
+
[
827
+
Alcotest.test_case "roundtrip" `Quick test_algorithm_roundtrip;
828
+
Alcotest.test_case "cose_values" `Quick test_algorithm_cose_values;
829
+
Alcotest.test_case "unknown" `Quick test_algorithm_unknown;
830
+
Alcotest.test_case "all_list" `Quick test_algorithm_all_list;
831
+
Alcotest.test_case "to_string" `Quick test_algorithm_to_string;
832
+
] );
833
+
( "COSE Key",
834
+
[
835
+
Alcotest.test_case "symmetric" `Quick test_cose_key_symmetric;
836
+
Alcotest.test_case "ed25519" `Quick test_cose_key_ed25519;
837
+
Alcotest.test_case "p256" `Quick test_cose_key_p256;
838
+
Alcotest.test_case "p384" `Quick test_cose_key_p384;
839
+
Alcotest.test_case "p521" `Quick test_cose_key_p521;
840
+
Alcotest.test_case "with_kid" `Quick test_cose_key_with_kid;
841
+
] );
842
+
( "COSE Key Serialization",
843
+
[
844
+
Alcotest.test_case "to_cbor_symmetric" `Quick
845
+
test_cose_key_to_cbor_symmetric;
846
+
Alcotest.test_case "to_cbor_ed25519" `Quick
847
+
test_cose_key_to_cbor_ed25519;
848
+
Alcotest.test_case "to_cbor_p256" `Quick test_cose_key_to_cbor_p256;
849
+
Alcotest.test_case "of_cbor" `Quick test_cose_key_of_cbor;
850
+
] );
851
+
( "Claims",
852
+
[
853
+
Alcotest.test_case "builder" `Quick test_claims_builder;
854
+
Alcotest.test_case "timestamps" `Quick test_claims_with_timestamps;
855
+
Alcotest.test_case "audience_single" `Quick
856
+
test_claims_audience_single;
857
+
Alcotest.test_case "audience_multiple" `Quick
858
+
test_claims_audience_multiple;
859
+
Alcotest.test_case "cti" `Quick test_claims_cti;
860
+
Alcotest.test_case "to_cbor" `Quick test_claims_to_cbor;
861
+
] );
862
+
( "CWT Creation",
863
+
[
864
+
Alcotest.test_case "hmac" `Quick test_create_hmac_cwt;
865
+
Alcotest.test_case "hmac_256_64" `Quick test_create_hmac_256_64_cwt;
866
+
Alcotest.test_case "hmac_384" `Quick test_create_hmac_384_cwt;
867
+
Alcotest.test_case "hmac_512" `Quick test_create_hmac_512_cwt;
868
+
Alcotest.test_case "es256" `Quick test_create_es256_cwt;
869
+
Alcotest.test_case "key_mismatch" `Quick test_create_key_mismatch;
870
+
] );
871
+
( "CWT Encoding",
872
+
[
873
+
Alcotest.test_case "hmac" `Quick test_cwt_hmac_encoding;
874
+
Alcotest.test_case "es256" `Quick test_cwt_es256_encoding;
875
+
Alcotest.test_case "parse_roundtrip" `Quick test_cwt_parse_roundtrip;
876
+
] );
877
+
( "Claims Validation",
878
+
[
879
+
Alcotest.test_case "expired" `Quick test_validate_expired_token;
880
+
Alcotest.test_case "not_yet_valid" `Quick
881
+
test_validate_not_yet_valid_token;
882
+
Alcotest.test_case "with_leeway" `Quick test_validate_with_leeway;
883
+
Alcotest.test_case "issuer_match" `Quick test_validate_issuer_match;
884
+
Alcotest.test_case "issuer_mismatch" `Quick
885
+
test_validate_issuer_mismatch;
886
+
Alcotest.test_case "audience_match" `Quick
887
+
test_validate_audience_match;
888
+
Alcotest.test_case "audience_mismatch" `Quick
889
+
test_validate_audience_mismatch;
890
+
] );
891
+
( "Helper Functions",
892
+
[
893
+
Alcotest.test_case "is_expired" `Quick test_is_expired;
894
+
Alcotest.test_case "time_to_expiry" `Quick test_time_to_expiry;
895
+
] );
896
+
( "Error Types",
897
+
[ Alcotest.test_case "to_string" `Quick test_error_to_string ] );
898
+
( "RFC 8392 Test Vectors",
899
+
[
900
+
Alcotest.test_case "claims_timestamps" `Quick
901
+
test_rfc_claims_timestamps;
902
+
Alcotest.test_case "claims_cbor_encoding" `Quick
903
+
test_rfc_claims_cbor_encoding;
904
+
Alcotest.test_case "claims_cbor_decoding" `Quick
905
+
test_rfc_claims_cbor_decoding;
906
+
Alcotest.test_case "signed_cwt_parse" `Quick test_rfc_signed_cwt_parse;
907
+
Alcotest.test_case "maced_cwt_parse" `Quick test_rfc_maced_cwt_parse;
908
+
] );
909
+
]
+235
-152
ocaml-jsonwt/test/test_jsonwt.ml
+235
-152
ocaml-jsonwt/test/test_jsonwt.ml
···
1
(** JWT Library Tests
2
3
-
Comprehensive tests derived from RFC 7519 (JSON Web Token)
4
-
and RFC 7515 (JSON Web Signature) specifications. *)
5
6
(* RFC 7515 Appendix A.1 symmetric key for HS256 *)
7
let rfc_hs256_key_b64 =
···
9
10
(* RFC 7519 Section 3.1 example JWT (HS256) *)
11
let rfc_section3_1_token =
12
-
"eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9.\
13
-
eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ.\
14
-
dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"
15
16
(* RFC 7519 Section 6.1 unsecured JWT *)
17
let rfc_section6_1_token =
18
-
"eyJhbGciOiJub25lIn0.\
19
-
eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ.\
20
-
"
21
22
(* Helper to decode base64url to bytes *)
23
let b64url_decode s =
24
(* Pad to multiple of 4 *)
25
-
let pad = match String.length s mod 4 with
26
| 0 -> ""
27
| 2 -> "=="
28
| 3 -> "="
···
36
37
let test_algorithm_roundtrip () =
38
let open Jsonwt.Algorithm in
39
-
let algs = [ None; HS256; HS384; HS512; RS256; RS384; RS512; ES256; ES384; ES512; EdDSA ] in
40
-
List.iter (fun alg ->
41
-
let s = to_string alg in
42
-
match of_string s with
43
-
| Ok alg' ->
44
-
Alcotest.(check string) "roundtrip" s (to_string alg')
45
-
| Error e ->
46
-
Alcotest.fail (Jsonwt.error_to_string e)
47
-
) algs
48
49
let test_algorithm_unknown () =
50
match Jsonwt.Algorithm.of_string "UNKNOWN" with
···
74
|> Jsonwt.Claims.set_string "custom" "value"
75
|> Jsonwt.Claims.build
76
in
77
-
Alcotest.(check (option string)) "iss" (Some "test-issuer") (Jsonwt.Claims.iss claims);
78
-
Alcotest.(check (option string)) "sub" (Some "test-subject") (Jsonwt.Claims.sub claims);
79
-
Alcotest.(check (option string)) "custom" (Some "value") (Jsonwt.Claims.get_string "custom" claims)
80
81
let test_claims_with_timestamps () =
82
-
let now = Ptime.of_float_s 1609459200. |> Option.get in (* 2021-01-01 00:00:00 UTC *)
83
-
let exp = Ptime.of_float_s 1609545600. |> Option.get in (* 2021-01-02 00:00:00 UTC *)
84
let claims =
85
-
Jsonwt.Claims.empty
86
-
|> Jsonwt.Claims.set_iat now
87
-
|> Jsonwt.Claims.set_exp exp
88
-
|> Jsonwt.Claims.set_nbf now
89
|> Jsonwt.Claims.build
90
in
91
-
Alcotest.(check (option bool)) "has exp" (Some true) (Option.map (fun _ -> true) (Jsonwt.Claims.exp claims));
92
-
Alcotest.(check (option bool)) "has iat" (Some true) (Option.map (fun _ -> true) (Jsonwt.Claims.iat claims));
93
-
Alcotest.(check (option bool)) "has nbf" (Some true) (Option.map (fun _ -> true) (Jsonwt.Claims.nbf claims))
94
95
let test_claims_audience_single () =
96
let claims =
···
106
|> Jsonwt.Claims.set_aud [ "app1"; "app2"; "app3" ]
107
|> Jsonwt.Claims.build
108
in
109
-
Alcotest.(check (list string)) "aud" [ "app1"; "app2"; "app3" ] (Jsonwt.Claims.aud claims)
110
111
(* ============= Parse Tests ============= *)
112
···
125
let test_parse_invalid_base64 () =
126
match Jsonwt.parse "!!!.@@@.###" with
127
| Error (Jsonwt.Invalid_base64url _) -> ()
128
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_base64url, got %s" (Jsonwt.error_to_string e))
129
| Ok _ -> Alcotest.fail "Expected parse to fail with invalid base64"
130
131
(* ============= RFC 7519 Test Vectors ============= *)
···
134
let test_rfc_unsecured_jwt_parse () =
135
match Jsonwt.parse rfc_section6_1_token with
136
| Ok jwt ->
137
-
Alcotest.(check bool) "alg is none" true (jwt.header.alg = Jsonwt.Algorithm.None);
138
-
Alcotest.(check (option string)) "iss is joe" (Some "joe") (Jsonwt.Claims.iss jwt.claims);
139
Alcotest.(check string) "signature is empty" "" jwt.signature
140
| Error e ->
141
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
142
143
let test_rfc_unsecured_jwt_verify_rejected_by_default () =
144
match Jsonwt.parse rfc_section6_1_token with
145
| Ok jwt ->
146
-
let key = Jsonwt.Jwk.symmetric "" in (* dummy key *)
147
begin match Jsonwt.verify ~key jwt with
148
| Error Jsonwt.Unsecured_not_allowed -> ()
149
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Unsecured_not_allowed, got: %s" (Jsonwt.error_to_string e))
150
| Ok () -> Alcotest.fail "Unsecured JWT should be rejected by default"
151
end
152
| Error e ->
153
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
154
155
let test_rfc_unsecured_jwt_verify_allowed_with_opt_in () =
156
match Jsonwt.parse rfc_section6_1_token with
157
| Ok jwt ->
158
-
let key = Jsonwt.Jwk.symmetric "" in (* dummy key *)
159
begin match Jsonwt.verify ~key ~allow_none:true jwt with
160
| Ok () -> ()
161
-
| Error e -> Alcotest.fail (Printf.sprintf "Verification failed: %s" (Jsonwt.error_to_string e))
162
end
163
| Error e ->
164
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
165
166
(* RFC 7519 Section 3.1: HS256 JWT *)
167
let test_rfc_hs256_jwt_parse () =
168
match Jsonwt.parse rfc_section3_1_token with
169
| Ok jwt ->
170
-
Alcotest.(check bool) "alg is HS256" true (jwt.header.alg = Jsonwt.Algorithm.HS256);
171
Alcotest.(check (option string)) "typ is JWT" (Some "JWT") jwt.header.typ;
172
-
Alcotest.(check (option string)) "iss is joe" (Some "joe") (Jsonwt.Claims.iss jwt.claims)
173
| Error e ->
174
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
175
176
let test_rfc_hs256_jwt_verify () =
177
match Jsonwt.parse rfc_section3_1_token with
···
180
let key = Jsonwt.Jwk.symmetric key_bytes in
181
begin match Jsonwt.verify ~key jwt with
182
| Ok () -> ()
183
-
| Error e -> Alcotest.fail (Printf.sprintf "Verification failed: %s" (Jsonwt.error_to_string e))
184
end
185
| Error e ->
186
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
187
188
let test_rfc_hs256_jwt_verify_wrong_key () =
189
match Jsonwt.parse rfc_section3_1_token with
190
| Ok jwt ->
191
-
let wrong_key = Jsonwt.Jwk.symmetric "wrong-key-material-that-is-long-enough" in
192
begin match Jsonwt.verify ~key:wrong_key jwt with
193
| Error Jsonwt.Signature_mismatch -> ()
194
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Signature_mismatch, got: %s" (Jsonwt.error_to_string e))
195
| Ok () -> Alcotest.fail "Verification should fail with wrong key"
196
end
197
| Error e ->
198
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
199
200
(* ============= Claims Validation Tests ============= *)
201
202
let test_validate_expired_token () =
203
-
let exp = Ptime.of_float_s 1300819380. |> Option.get in (* RFC example exp *)
204
-
let now = Ptime.of_float_s 1400000000. |> Option.get in (* After exp *)
205
let claims =
206
-
Jsonwt.Claims.empty
207
-
|> Jsonwt.Claims.set_exp exp
208
-
|> Jsonwt.Claims.build
209
in
210
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
211
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
212
match Jsonwt.validate ~now jwt with
213
| Error Jsonwt.Token_expired -> ()
214
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Token_expired, got: %s" (Jsonwt.error_to_string e))
215
| Ok () -> Alcotest.fail "Expected Token_expired error"
216
217
let test_validate_not_yet_valid_token () =
218
let nbf = Ptime.of_float_s 1500000000. |> Option.get in
219
-
let now = Ptime.of_float_s 1400000000. |> Option.get in (* Before nbf *)
220
let claims =
221
-
Jsonwt.Claims.empty
222
-
|> Jsonwt.Claims.set_nbf nbf
223
-
|> Jsonwt.Claims.build
224
in
225
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
226
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
227
match Jsonwt.validate ~now jwt with
228
| Error Jsonwt.Token_not_yet_valid -> ()
229
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Token_not_yet_valid, got: %s" (Jsonwt.error_to_string e))
230
| Ok () -> Alcotest.fail "Expected Token_not_yet_valid error"
231
232
let test_validate_with_leeway () =
233
let exp = Ptime.of_float_s 1300819380. |> Option.get in
234
-
let now = Ptime.of_float_s 1300819390. |> Option.get in (* 10 seconds after exp *)
235
-
let leeway = Ptime.Span.of_int_s 60 in (* 60 second leeway *)
236
let claims =
237
-
Jsonwt.Claims.empty
238
-
|> Jsonwt.Claims.set_exp exp
239
-
|> Jsonwt.Claims.build
240
in
241
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
242
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
243
match Jsonwt.validate ~now ~leeway jwt with
244
| Ok () -> ()
245
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass with leeway, got: %s" (Jsonwt.error_to_string e))
246
247
let test_validate_issuer_match () =
248
let now = Ptime.of_float_s 1400000000. |> Option.get in
···
255
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
256
match Jsonwt.validate ~now ~iss:"expected-issuer" jwt with
257
| Ok () -> ()
258
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass, got: %s" (Jsonwt.error_to_string e))
259
260
let test_validate_issuer_mismatch () =
261
let now = Ptime.of_float_s 1400000000. |> Option.get in
···
268
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
269
match Jsonwt.validate ~now ~iss:"expected-issuer" jwt with
270
| Error Jsonwt.Invalid_issuer -> ()
271
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_issuer, got: %s" (Jsonwt.error_to_string e))
272
| Ok () -> Alcotest.fail "Expected Invalid_issuer error"
273
274
let test_validate_audience_match () =
···
282
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
283
match Jsonwt.validate ~now ~aud:"my-app" jwt with
284
| Ok () -> ()
285
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass, got: %s" (Jsonwt.error_to_string e))
286
287
let test_validate_audience_mismatch () =
288
let now = Ptime.of_float_s 1400000000. |> Option.get in
···
295
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
296
match Jsonwt.validate ~now ~aud:"my-app" jwt with
297
| Error Jsonwt.Invalid_audience -> ()
298
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_audience, got: %s" (Jsonwt.error_to_string e))
299
| Ok () -> Alcotest.fail "Expected Invalid_audience error"
300
301
(* ============= Algorithm Restriction Tests ============= *)
···
309
let allowed_algs = [ Jsonwt.Algorithm.HS384; Jsonwt.Algorithm.HS512 ] in
310
begin match Jsonwt.verify ~key ~allowed_algs jwt with
311
| Error (Jsonwt.Algorithm_not_allowed "HS256") -> ()
312
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Algorithm_not_allowed, got: %s" (Jsonwt.error_to_string e))
313
-
| Ok () -> Alcotest.fail "Verification should fail when algorithm is not allowed"
314
end
315
| Error e ->
316
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
317
318
(* ============= Helper Function Tests ============= *)
319
320
let test_is_expired () =
321
let exp = Ptime.of_float_s 1300819380. |> Option.get in
322
let claims =
323
-
Jsonwt.Claims.empty
324
-
|> Jsonwt.Claims.set_exp exp
325
-
|> Jsonwt.Claims.build
326
in
327
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
328
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
329
let now_before = Ptime.of_float_s 1300819370. |> Option.get in
330
let now_after = Ptime.of_float_s 1300819390. |> Option.get in
331
-
Alcotest.(check bool) "not expired before" false (Jsonwt.is_expired ~now:now_before jwt);
332
-
Alcotest.(check bool) "expired after" true (Jsonwt.is_expired ~now:now_after jwt)
333
334
let test_time_to_expiry () =
335
let exp = Ptime.of_float_s 1300819380. |> Option.get in
336
let claims =
337
-
Jsonwt.Claims.empty
338
-
|> Jsonwt.Claims.set_exp exp
339
-
|> Jsonwt.Claims.build
340
in
341
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
342
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
···
345
| Some span ->
346
let seconds = Ptime.Span.to_float_s span |> int_of_float in
347
Alcotest.(check int) "time to expiry" 10 seconds
348
-
| None ->
349
-
Alcotest.fail "Expected Some time to expiry"
350
351
let test_time_to_expiry_already_expired () =
352
let exp = Ptime.of_float_s 1300819380. |> Option.get in
353
let claims =
354
-
Jsonwt.Claims.empty
355
-
|> Jsonwt.Claims.set_exp exp
356
-
|> Jsonwt.Claims.build
357
in
358
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
359
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
···
365
(* ============= Error Type Tests ============= *)
366
367
let test_error_to_string () =
368
-
let errors = [
369
-
(Jsonwt.Invalid_json "test", "Invalid JSON: test");
370
-
(Jsonwt.Invalid_base64url "test", "Invalid base64url: test");
371
-
(Jsonwt.Invalid_structure "test", "Invalid structure: test");
372
-
(Jsonwt.Token_expired, "Token expired");
373
-
(Jsonwt.Token_not_yet_valid, "Token not yet valid");
374
-
(Jsonwt.Signature_mismatch, "Signature mismatch");
375
-
] in
376
-
List.iter (fun (err, expected) ->
377
-
let actual = Jsonwt.error_to_string err in
378
-
Alcotest.(check string) "error string" expected actual
379
-
) errors
380
381
(* ============= JWK Tests ============= *)
382
···
388
(* ============= Test Runner ============= *)
389
390
let () =
391
-
Alcotest.run "Jsonwt" [
392
-
"Algorithm", [
393
-
Alcotest.test_case "roundtrip" `Quick test_algorithm_roundtrip;
394
-
Alcotest.test_case "unknown" `Quick test_algorithm_unknown;
395
-
];
396
-
"Header", [
397
-
Alcotest.test_case "create" `Quick test_header_create;
398
-
Alcotest.test_case "with_kid" `Quick test_header_with_kid;
399
-
];
400
-
"Claims", [
401
-
Alcotest.test_case "builder" `Quick test_claims_builder;
402
-
Alcotest.test_case "timestamps" `Quick test_claims_with_timestamps;
403
-
Alcotest.test_case "audience_single" `Quick test_claims_audience_single;
404
-
Alcotest.test_case "audience_multiple" `Quick test_claims_audience_multiple;
405
-
];
406
-
"Parse", [
407
-
Alcotest.test_case "invalid" `Quick test_parse_invalid;
408
-
Alcotest.test_case "malformed" `Quick test_parse_malformed;
409
-
Alcotest.test_case "invalid_base64" `Quick test_parse_invalid_base64;
410
-
];
411
-
"RFC 7519 Section 6.1 - Unsecured JWT", [
412
-
Alcotest.test_case "parse" `Quick test_rfc_unsecured_jwt_parse;
413
-
Alcotest.test_case "rejected_by_default" `Quick test_rfc_unsecured_jwt_verify_rejected_by_default;
414
-
Alcotest.test_case "allowed_with_opt_in" `Quick test_rfc_unsecured_jwt_verify_allowed_with_opt_in;
415
-
];
416
-
"RFC 7519 Section 3.1 - HS256 JWT", [
417
-
Alcotest.test_case "parse" `Quick test_rfc_hs256_jwt_parse;
418
-
Alcotest.test_case "verify" `Quick test_rfc_hs256_jwt_verify;
419
-
Alcotest.test_case "verify_wrong_key" `Quick test_rfc_hs256_jwt_verify_wrong_key;
420
-
];
421
-
"Claims Validation", [
422
-
Alcotest.test_case "expired" `Quick test_validate_expired_token;
423
-
Alcotest.test_case "not_yet_valid" `Quick test_validate_not_yet_valid_token;
424
-
Alcotest.test_case "with_leeway" `Quick test_validate_with_leeway;
425
-
Alcotest.test_case "issuer_match" `Quick test_validate_issuer_match;
426
-
Alcotest.test_case "issuer_mismatch" `Quick test_validate_issuer_mismatch;
427
-
Alcotest.test_case "audience_match" `Quick test_validate_audience_match;
428
-
Alcotest.test_case "audience_mismatch" `Quick test_validate_audience_mismatch;
429
-
];
430
-
"Algorithm Restrictions", [
431
-
Alcotest.test_case "not_allowed" `Quick test_algorithm_not_allowed;
432
-
];
433
-
"Helper Functions", [
434
-
Alcotest.test_case "is_expired" `Quick test_is_expired;
435
-
Alcotest.test_case "time_to_expiry" `Quick test_time_to_expiry;
436
-
Alcotest.test_case "time_to_expiry_expired" `Quick test_time_to_expiry_already_expired;
437
-
];
438
-
"Error Types", [
439
-
Alcotest.test_case "to_string" `Quick test_error_to_string;
440
-
];
441
-
"JWK", [
442
-
Alcotest.test_case "symmetric" `Quick test_jwk_symmetric;
443
-
];
444
-
]
···
1
(** JWT Library Tests
2
3
+
Comprehensive tests derived from RFC 7519 (JSON Web Token) and RFC 7515
4
+
(JSON Web Signature) specifications. *)
5
6
(* RFC 7515 Appendix A.1 symmetric key for HS256 *)
7
let rfc_hs256_key_b64 =
···
9
10
(* RFC 7519 Section 3.1 example JWT (HS256) *)
11
let rfc_section3_1_token =
12
+
"eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9.eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ.dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"
13
14
(* RFC 7519 Section 6.1 unsecured JWT *)
15
let rfc_section6_1_token =
16
+
"eyJhbGciOiJub25lIn0.eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ."
17
18
(* Helper to decode base64url to bytes *)
19
let b64url_decode s =
20
(* Pad to multiple of 4 *)
21
+
let pad =
22
+
match String.length s mod 4 with
23
| 0 -> ""
24
| 2 -> "=="
25
| 3 -> "="
···
33
34
let test_algorithm_roundtrip () =
35
let open Jsonwt.Algorithm in
36
+
let algs =
37
+
[
38
+
None; HS256; HS384; HS512; RS256; RS384; RS512; ES256; ES384; ES512; EdDSA;
39
+
]
40
+
in
41
+
List.iter
42
+
(fun alg ->
43
+
let s = to_string alg in
44
+
match of_string s with
45
+
| Ok alg' -> Alcotest.(check string) "roundtrip" s (to_string alg')
46
+
| Error e -> Alcotest.fail (Jsonwt.error_to_string e))
47
+
algs
48
49
let test_algorithm_unknown () =
50
match Jsonwt.Algorithm.of_string "UNKNOWN" with
···
74
|> Jsonwt.Claims.set_string "custom" "value"
75
|> Jsonwt.Claims.build
76
in
77
+
Alcotest.(check (option string))
78
+
"iss" (Some "test-issuer") (Jsonwt.Claims.iss claims);
79
+
Alcotest.(check (option string))
80
+
"sub" (Some "test-subject") (Jsonwt.Claims.sub claims);
81
+
Alcotest.(check (option string))
82
+
"custom" (Some "value")
83
+
(Jsonwt.Claims.get_string "custom" claims)
84
85
let test_claims_with_timestamps () =
86
+
let now = Ptime.of_float_s 1609459200. |> Option.get in
87
+
(* 2021-01-01 00:00:00 UTC *)
88
+
let exp = Ptime.of_float_s 1609545600. |> Option.get in
89
+
(* 2021-01-02 00:00:00 UTC *)
90
let claims =
91
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_iat now
92
+
|> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.set_nbf now
93
|> Jsonwt.Claims.build
94
in
95
+
Alcotest.(check (option bool))
96
+
"has exp" (Some true)
97
+
(Option.map (fun _ -> true) (Jsonwt.Claims.exp claims));
98
+
Alcotest.(check (option bool))
99
+
"has iat" (Some true)
100
+
(Option.map (fun _ -> true) (Jsonwt.Claims.iat claims));
101
+
Alcotest.(check (option bool))
102
+
"has nbf" (Some true)
103
+
(Option.map (fun _ -> true) (Jsonwt.Claims.nbf claims))
104
105
let test_claims_audience_single () =
106
let claims =
···
116
|> Jsonwt.Claims.set_aud [ "app1"; "app2"; "app3" ]
117
|> Jsonwt.Claims.build
118
in
119
+
Alcotest.(check (list string))
120
+
"aud" [ "app1"; "app2"; "app3" ] (Jsonwt.Claims.aud claims)
121
122
(* ============= Parse Tests ============= *)
123
···
136
let test_parse_invalid_base64 () =
137
match Jsonwt.parse "!!!.@@@.###" with
138
| Error (Jsonwt.Invalid_base64url _) -> ()
139
+
| Error e ->
140
+
Alcotest.fail
141
+
(Printf.sprintf "Expected Invalid_base64url, got %s"
142
+
(Jsonwt.error_to_string e))
143
| Ok _ -> Alcotest.fail "Expected parse to fail with invalid base64"
144
145
(* ============= RFC 7519 Test Vectors ============= *)
···
148
let test_rfc_unsecured_jwt_parse () =
149
match Jsonwt.parse rfc_section6_1_token with
150
| Ok jwt ->
151
+
Alcotest.(check bool)
152
+
"alg is none" true
153
+
(jwt.header.alg = Jsonwt.Algorithm.None);
154
+
Alcotest.(check (option string))
155
+
"iss is joe" (Some "joe")
156
+
(Jsonwt.Claims.iss jwt.claims);
157
Alcotest.(check string) "signature is empty" "" jwt.signature
158
| Error e ->
159
+
Alcotest.fail
160
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
161
162
let test_rfc_unsecured_jwt_verify_rejected_by_default () =
163
match Jsonwt.parse rfc_section6_1_token with
164
| Ok jwt ->
165
+
let key = Jsonwt.Jwk.symmetric "" in
166
+
(* dummy key *)
167
begin match Jsonwt.verify ~key jwt with
168
| Error Jsonwt.Unsecured_not_allowed -> ()
169
+
| Error e ->
170
+
Alcotest.fail
171
+
(Printf.sprintf "Expected Unsecured_not_allowed, got: %s"
172
+
(Jsonwt.error_to_string e))
173
| Ok () -> Alcotest.fail "Unsecured JWT should be rejected by default"
174
end
175
| Error e ->
176
+
Alcotest.fail
177
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
178
179
let test_rfc_unsecured_jwt_verify_allowed_with_opt_in () =
180
match Jsonwt.parse rfc_section6_1_token with
181
| Ok jwt ->
182
+
let key = Jsonwt.Jwk.symmetric "" in
183
+
(* dummy key *)
184
begin match Jsonwt.verify ~key ~allow_none:true jwt with
185
| Ok () -> ()
186
+
| Error e ->
187
+
Alcotest.fail
188
+
(Printf.sprintf "Verification failed: %s" (Jsonwt.error_to_string e))
189
end
190
| Error e ->
191
+
Alcotest.fail
192
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
193
194
(* RFC 7519 Section 3.1: HS256 JWT *)
195
let test_rfc_hs256_jwt_parse () =
196
match Jsonwt.parse rfc_section3_1_token with
197
| Ok jwt ->
198
+
Alcotest.(check bool)
199
+
"alg is HS256" true
200
+
(jwt.header.alg = Jsonwt.Algorithm.HS256);
201
Alcotest.(check (option string)) "typ is JWT" (Some "JWT") jwt.header.typ;
202
+
Alcotest.(check (option string))
203
+
"iss is joe" (Some "joe")
204
+
(Jsonwt.Claims.iss jwt.claims)
205
| Error e ->
206
+
Alcotest.fail
207
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
208
209
let test_rfc_hs256_jwt_verify () =
210
match Jsonwt.parse rfc_section3_1_token with
···
213
let key = Jsonwt.Jwk.symmetric key_bytes in
214
begin match Jsonwt.verify ~key jwt with
215
| Ok () -> ()
216
+
| Error e ->
217
+
Alcotest.fail
218
+
(Printf.sprintf "Verification failed: %s" (Jsonwt.error_to_string e))
219
end
220
| Error e ->
221
+
Alcotest.fail
222
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
223
224
let test_rfc_hs256_jwt_verify_wrong_key () =
225
match Jsonwt.parse rfc_section3_1_token with
226
| Ok jwt ->
227
+
let wrong_key =
228
+
Jsonwt.Jwk.symmetric "wrong-key-material-that-is-long-enough"
229
+
in
230
begin match Jsonwt.verify ~key:wrong_key jwt with
231
| Error Jsonwt.Signature_mismatch -> ()
232
+
| Error e ->
233
+
Alcotest.fail
234
+
(Printf.sprintf "Expected Signature_mismatch, got: %s"
235
+
(Jsonwt.error_to_string e))
236
| Ok () -> Alcotest.fail "Verification should fail with wrong key"
237
end
238
| Error e ->
239
+
Alcotest.fail
240
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
241
242
(* ============= Claims Validation Tests ============= *)
243
244
let test_validate_expired_token () =
245
+
let exp = Ptime.of_float_s 1300819380. |> Option.get in
246
+
(* RFC example exp *)
247
+
let now = Ptime.of_float_s 1400000000. |> Option.get in
248
+
(* After exp *)
249
let claims =
250
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
251
in
252
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
253
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
254
match Jsonwt.validate ~now jwt with
255
| Error Jsonwt.Token_expired -> ()
256
+
| Error e ->
257
+
Alcotest.fail
258
+
(Printf.sprintf "Expected Token_expired, got: %s"
259
+
(Jsonwt.error_to_string e))
260
| Ok () -> Alcotest.fail "Expected Token_expired error"
261
262
let test_validate_not_yet_valid_token () =
263
let nbf = Ptime.of_float_s 1500000000. |> Option.get in
264
+
let now = Ptime.of_float_s 1400000000. |> Option.get in
265
+
(* Before nbf *)
266
let claims =
267
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_nbf nbf |> Jsonwt.Claims.build
268
in
269
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
270
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
271
match Jsonwt.validate ~now jwt with
272
| Error Jsonwt.Token_not_yet_valid -> ()
273
+
| Error e ->
274
+
Alcotest.fail
275
+
(Printf.sprintf "Expected Token_not_yet_valid, got: %s"
276
+
(Jsonwt.error_to_string e))
277
| Ok () -> Alcotest.fail "Expected Token_not_yet_valid error"
278
279
let test_validate_with_leeway () =
280
let exp = Ptime.of_float_s 1300819380. |> Option.get in
281
+
let now = Ptime.of_float_s 1300819390. |> Option.get in
282
+
(* 10 seconds after exp *)
283
+
let leeway = Ptime.Span.of_int_s 60 in
284
+
(* 60 second leeway *)
285
let claims =
286
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
287
in
288
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
289
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
290
match Jsonwt.validate ~now ~leeway jwt with
291
| Ok () -> ()
292
+
| Error e ->
293
+
Alcotest.fail
294
+
(Printf.sprintf "Expected validation to pass with leeway, got: %s"
295
+
(Jsonwt.error_to_string e))
296
297
let test_validate_issuer_match () =
298
let now = Ptime.of_float_s 1400000000. |> Option.get in
···
305
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
306
match Jsonwt.validate ~now ~iss:"expected-issuer" jwt with
307
| Ok () -> ()
308
+
| Error e ->
309
+
Alcotest.fail
310
+
(Printf.sprintf "Expected validation to pass, got: %s"
311
+
(Jsonwt.error_to_string e))
312
313
let test_validate_issuer_mismatch () =
314
let now = Ptime.of_float_s 1400000000. |> Option.get in
···
321
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
322
match Jsonwt.validate ~now ~iss:"expected-issuer" jwt with
323
| Error Jsonwt.Invalid_issuer -> ()
324
+
| Error e ->
325
+
Alcotest.fail
326
+
(Printf.sprintf "Expected Invalid_issuer, got: %s"
327
+
(Jsonwt.error_to_string e))
328
| Ok () -> Alcotest.fail "Expected Invalid_issuer error"
329
330
let test_validate_audience_match () =
···
338
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
339
match Jsonwt.validate ~now ~aud:"my-app" jwt with
340
| Ok () -> ()
341
+
| Error e ->
342
+
Alcotest.fail
343
+
(Printf.sprintf "Expected validation to pass, got: %s"
344
+
(Jsonwt.error_to_string e))
345
346
let test_validate_audience_mismatch () =
347
let now = Ptime.of_float_s 1400000000. |> Option.get in
···
354
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
355
match Jsonwt.validate ~now ~aud:"my-app" jwt with
356
| Error Jsonwt.Invalid_audience -> ()
357
+
| Error e ->
358
+
Alcotest.fail
359
+
(Printf.sprintf "Expected Invalid_audience, got: %s"
360
+
(Jsonwt.error_to_string e))
361
| Ok () -> Alcotest.fail "Expected Invalid_audience error"
362
363
(* ============= Algorithm Restriction Tests ============= *)
···
371
let allowed_algs = [ Jsonwt.Algorithm.HS384; Jsonwt.Algorithm.HS512 ] in
372
begin match Jsonwt.verify ~key ~allowed_algs jwt with
373
| Error (Jsonwt.Algorithm_not_allowed "HS256") -> ()
374
+
| Error e ->
375
+
Alcotest.fail
376
+
(Printf.sprintf "Expected Algorithm_not_allowed, got: %s"
377
+
(Jsonwt.error_to_string e))
378
+
| Ok () ->
379
+
Alcotest.fail "Verification should fail when algorithm is not allowed"
380
end
381
| Error e ->
382
+
Alcotest.fail
383
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
384
385
(* ============= Helper Function Tests ============= *)
386
387
let test_is_expired () =
388
let exp = Ptime.of_float_s 1300819380. |> Option.get in
389
let claims =
390
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
391
in
392
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
393
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
394
let now_before = Ptime.of_float_s 1300819370. |> Option.get in
395
let now_after = Ptime.of_float_s 1300819390. |> Option.get in
396
+
Alcotest.(check bool)
397
+
"not expired before" false
398
+
(Jsonwt.is_expired ~now:now_before jwt);
399
+
Alcotest.(check bool)
400
+
"expired after" true
401
+
(Jsonwt.is_expired ~now:now_after jwt)
402
403
let test_time_to_expiry () =
404
let exp = Ptime.of_float_s 1300819380. |> Option.get in
405
let claims =
406
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
407
in
408
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
409
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
···
412
| Some span ->
413
let seconds = Ptime.Span.to_float_s span |> int_of_float in
414
Alcotest.(check int) "time to expiry" 10 seconds
415
+
| None -> Alcotest.fail "Expected Some time to expiry"
416
417
let test_time_to_expiry_already_expired () =
418
let exp = Ptime.of_float_s 1300819380. |> Option.get in
419
let claims =
420
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
421
in
422
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
423
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
···
429
(* ============= Error Type Tests ============= *)
430
431
let test_error_to_string () =
432
+
let errors =
433
+
[
434
+
(Jsonwt.Invalid_json "test", "Invalid JSON: test");
435
+
(Jsonwt.Invalid_base64url "test", "Invalid base64url: test");
436
+
(Jsonwt.Invalid_structure "test", "Invalid structure: test");
437
+
(Jsonwt.Token_expired, "Token expired");
438
+
(Jsonwt.Token_not_yet_valid, "Token not yet valid");
439
+
(Jsonwt.Signature_mismatch, "Signature mismatch");
440
+
]
441
+
in
442
+
List.iter
443
+
(fun (err, expected) ->
444
+
let actual = Jsonwt.error_to_string err in
445
+
Alcotest.(check string) "error string" expected actual)
446
+
errors
447
448
(* ============= JWK Tests ============= *)
449
···
455
(* ============= Test Runner ============= *)
456
457
let () =
458
+
Alcotest.run "Jsonwt"
459
+
[
460
+
( "Algorithm",
461
+
[
462
+
Alcotest.test_case "roundtrip" `Quick test_algorithm_roundtrip;
463
+
Alcotest.test_case "unknown" `Quick test_algorithm_unknown;
464
+
] );
465
+
( "Header",
466
+
[
467
+
Alcotest.test_case "create" `Quick test_header_create;
468
+
Alcotest.test_case "with_kid" `Quick test_header_with_kid;
469
+
] );
470
+
( "Claims",
471
+
[
472
+
Alcotest.test_case "builder" `Quick test_claims_builder;
473
+
Alcotest.test_case "timestamps" `Quick test_claims_with_timestamps;
474
+
Alcotest.test_case "audience_single" `Quick
475
+
test_claims_audience_single;
476
+
Alcotest.test_case "audience_multiple" `Quick
477
+
test_claims_audience_multiple;
478
+
] );
479
+
( "Parse",
480
+
[
481
+
Alcotest.test_case "invalid" `Quick test_parse_invalid;
482
+
Alcotest.test_case "malformed" `Quick test_parse_malformed;
483
+
Alcotest.test_case "invalid_base64" `Quick test_parse_invalid_base64;
484
+
] );
485
+
( "RFC 7519 Section 6.1 - Unsecured JWT",
486
+
[
487
+
Alcotest.test_case "parse" `Quick test_rfc_unsecured_jwt_parse;
488
+
Alcotest.test_case "rejected_by_default" `Quick
489
+
test_rfc_unsecured_jwt_verify_rejected_by_default;
490
+
Alcotest.test_case "allowed_with_opt_in" `Quick
491
+
test_rfc_unsecured_jwt_verify_allowed_with_opt_in;
492
+
] );
493
+
( "RFC 7519 Section 3.1 - HS256 JWT",
494
+
[
495
+
Alcotest.test_case "parse" `Quick test_rfc_hs256_jwt_parse;
496
+
Alcotest.test_case "verify" `Quick test_rfc_hs256_jwt_verify;
497
+
Alcotest.test_case "verify_wrong_key" `Quick
498
+
test_rfc_hs256_jwt_verify_wrong_key;
499
+
] );
500
+
( "Claims Validation",
501
+
[
502
+
Alcotest.test_case "expired" `Quick test_validate_expired_token;
503
+
Alcotest.test_case "not_yet_valid" `Quick
504
+
test_validate_not_yet_valid_token;
505
+
Alcotest.test_case "with_leeway" `Quick test_validate_with_leeway;
506
+
Alcotest.test_case "issuer_match" `Quick test_validate_issuer_match;
507
+
Alcotest.test_case "issuer_mismatch" `Quick
508
+
test_validate_issuer_mismatch;
509
+
Alcotest.test_case "audience_match" `Quick
510
+
test_validate_audience_match;
511
+
Alcotest.test_case "audience_mismatch" `Quick
512
+
test_validate_audience_mismatch;
513
+
] );
514
+
( "Algorithm Restrictions",
515
+
[ Alcotest.test_case "not_allowed" `Quick test_algorithm_not_allowed ]
516
+
);
517
+
( "Helper Functions",
518
+
[
519
+
Alcotest.test_case "is_expired" `Quick test_is_expired;
520
+
Alcotest.test_case "time_to_expiry" `Quick test_time_to_expiry;
521
+
Alcotest.test_case "time_to_expiry_expired" `Quick
522
+
test_time_to_expiry_already_expired;
523
+
] );
524
+
( "Error Types",
525
+
[ Alcotest.test_case "to_string" `Quick test_error_to_string ] );
526
+
("JWK", [ Alcotest.test_case "symmetric" `Quick test_jwk_symmetric ]);
527
+
]