My aggregated monorepo of OCaml code, automaintained
Squashed 'ocaml-jsonwt/' changes from 9141e657..f105e906
f105e906 Fix dune-project URLs to point to upstream repos
c8b987b1 Merge commit '8c19843f614d6665dadddb55791cf938e01b3d43'
4c425954 Update dune-project files
ddb40327 jsonwt: Update homepage to gazagnaire.org fork
c763228f jsonwt: Standardize .ocamlformat
2c922fdb Add untracked directories
c50984c7 ocaml-atp: Apply ocamlformat and disable for generated lexicons
git-subtree-dir: ocaml-jsonwt
git-subtree-split: f105e9065ddf3ed85527cb783e8f1e0f4783008b
+2123
-1497
+15
fuzz/dune
+15
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
fuzz/fuzz_jsonwt.ml
+95
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
lib/cwt.ml
+383
-308
lib/cwt.ml
···
33
33
| Invalid_audience -> Format.fprintf ppf "Invalid audience"
34
34
| Key_type_mismatch s -> Format.fprintf ppf "Key type mismatch: %s" s
35
35
36
-
let error_to_string e =
37
-
Format.asprintf "%a" pp_error e
36
+
let error_to_string e = Format.asprintf "%a" pp_error e
38
37
39
38
(* Cbort codec helpers *)
40
39
41
-
let cbort_error_to_error e =
42
-
Invalid_cbor (Cbort.Error.to_string e)
40
+
let cbort_error_to_error e = Invalid_cbor (Cbort.Error.to_string e)
43
41
44
42
(* COSE Algorithms - RFC 9053 *)
45
43
···
85
83
| HMAC_384 -> "HMAC 384/384"
86
84
| HMAC_512 -> "HMAC 512/512"
87
85
88
-
let all = [ES256; ES384; ES512; EdDSA; HMAC_256_64; HMAC_256; HMAC_384; HMAC_512]
86
+
let all =
87
+
[ ES256; ES384; ES512; EdDSA; HMAC_256_64; HMAC_256; HMAC_384; HMAC_512 ]
89
88
end
90
89
91
90
(* COSE Key - RFC 9052 Section 7 *)
92
91
93
92
module Cose_key = struct
94
-
type kty =
95
-
| Okp
96
-
| Ec2
97
-
| Symmetric
93
+
type kty = Okp | Ec2 | Symmetric
98
94
99
95
(* COSE key labels *)
100
96
let label_kty = 1
···
104
100
let label_x = -2
105
101
let label_y = -3
106
102
let label_d = -4
107
-
let label_k = -1 (* for symmetric *)
103
+
let label_k = -1 (* for symmetric *)
108
104
109
105
(* COSE key type values *)
110
106
let kty_okp = 1
···
134
130
alg : Algorithm.t option;
135
131
}
136
132
137
-
let symmetric k =
138
-
{ key_data = Symmetric_key { k }; kid = None; alg = None }
133
+
let symmetric k = { key_data = Symmetric_key { k }; kid = None; alg = None }
139
134
140
135
let ed25519_pub x =
141
136
{ key_data = Ed25519_pub { x }; kid = None; alg = Some Algorithm.EdDSA }
142
137
143
138
let ed25519_priv ~pub ~priv =
144
-
{ key_data = Ed25519_priv { x = pub; d = priv }; kid = None; alg = Some Algorithm.EdDSA }
139
+
{
140
+
key_data = Ed25519_priv { x = pub; d = priv };
141
+
kid = None;
142
+
alg = Some Algorithm.EdDSA;
143
+
}
145
144
146
145
let p256_pub ~x ~y =
147
146
{ key_data = P256_pub { x; y }; kid = None; alg = Some Algorithm.ES256 }
···
165
164
match t.key_data with
166
165
| Symmetric_key _ -> Symmetric
167
166
| Ed25519_pub _ | Ed25519_priv _ -> Okp
168
-
| P256_pub _ | P256_priv _ | P384_pub _ | P384_priv _ | P521_pub _ | P521_priv _ -> Ec2
167
+
| P256_pub _ | P256_priv _ | P384_pub _ | P384_priv _ | P521_pub _
168
+
| P521_priv _ ->
169
+
Ec2
169
170
170
171
let kid t = t.kid
171
172
let alg t = t.alg
172
-
173
173
let with_kid id t = { t with kid = Some id }
174
174
let with_alg a t = { t with alg = Some a }
175
175
···
201
201
let kty_val = get_int_value (find_int label_kty) in
202
202
let crv_val = get_int_value (find_int label_crv) in
203
203
let kid = find_kid label_kid in
204
-
let alg = match get_int_value (find_int label_alg) with
204
+
let alg =
205
+
match get_int_value (find_int label_alg) with
205
206
| None -> None
206
-
| Some n -> (match Algorithm.of_cose_int n with Ok a -> Some a | Error _ -> None)
207
+
| Some n -> (
208
+
match Algorithm.of_cose_int n with
209
+
| Ok a -> Some a
210
+
| Error _ -> None)
207
211
in
208
212
let x = find_bytes label_x in
209
213
let y = find_bytes label_y in
210
214
let d = find_bytes label_d in
211
215
let k = find_bytes label_k in
212
-
let key_data = match kty_val, crv_val, x, y, d, k with
216
+
let key_data =
217
+
match (kty_val, crv_val, x, y, d, k) with
213
218
| Some 4, _, _, _, _, Some k -> Ok (Symmetric_key { k })
214
219
| Some 1, Some 6, Some x, _, None, _ -> Ok (Ed25519_pub { x })
215
220
| Some 1, Some 6, Some x, _, Some d, _ -> Ok (Ed25519_priv { x; d })
216
221
| 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 })
222
+
| Some 2, Some 1, Some x, Some y, Some d, _ ->
223
+
Ok (P256_priv { x; y; d })
218
224
| 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 })
225
+
| Some 2, Some 2, Some x, Some y, Some d, _ ->
226
+
Ok (P384_priv { x; y; d })
220
227
| 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")
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")
223
232
in
224
233
Result.map (fun key_data -> { key_data; kid; alg }) key_data
225
234
···
231
240
232
241
(* kty - always present *)
233
242
(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);
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);
237
246
238
247
(* kid (optional) *)
239
248
Option.iter (fun kid -> add_bytes label_kid kid) t.kid;
···
243
252
244
253
(* Key-type specific parameters *)
245
254
(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);
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
290
291
291
Cbort.encode_string Cbort.any (Cbort.Cbor.Map (List.rev !pairs))
292
292
end
···
303
303
let key_iat = 6
304
304
let key_cti = 7
305
305
306
-
type claim_key =
307
-
| Int_key of int
308
-
| String_key of string
306
+
type claim_key = Int_key of int | String_key of string
309
307
310
308
type t = {
311
309
iss : string option;
···
327
325
let cti t = t.cti
328
326
329
327
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
328
+
List.find_map
329
+
(function Int_key k, v when k = key -> Some v | _ -> None)
330
+
t.custom
334
331
335
332
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
333
+
List.find_map
334
+
(function String_key k, v when k = key -> Some v | _ -> None)
335
+
t.custom
340
336
341
337
type builder = t
342
338
343
-
let empty = {
344
-
iss = None; sub = None; aud = []; exp = None;
345
-
nbf = None; iat = None; cti = None; custom = []
346
-
}
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
+
}
347
350
348
351
let set_iss v t = { t with iss = Some v }
349
352
let set_sub v t = { t with sub = Some v }
···
352
355
let set_nbf v t = { t with nbf = Some v }
353
356
let set_iat v t = { t with iat = Some v }
354
357
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 }
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
+
357
365
let build t = t
358
366
359
367
(* Standard claim keys *)
360
-
let standard_keys = [key_iss; key_sub; key_aud; key_exp; key_nbf; key_iat; key_cti]
368
+
let standard_keys =
369
+
[ key_iss; key_sub; key_aud; key_exp; key_nbf; key_iat; key_cti ]
361
370
362
371
(* Helper to convert claim_key to CBOR *)
363
372
let claim_key_to_cbor = function
···
367
376
(* Helper to find value by integer key in CBOR map *)
368
377
let find_int_key key pairs =
369
378
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
379
+
List.find_map
380
+
(fun (k, v) -> if Cbort.Cbor.equal k target then Some v else None)
381
+
pairs
373
382
374
383
(* Helper to extract string from CBOR *)
375
-
let cbor_to_string = function
376
-
| Cbort.Cbor.Text s -> Some s
377
-
| _ -> None
384
+
let cbor_to_string = function Cbort.Cbor.Text s -> Some s | _ -> None
378
385
379
386
(* Helper to extract bytes from CBOR *)
380
-
let cbor_to_bytes = function
381
-
| Cbort.Cbor.Bytes s -> Some s
382
-
| _ -> None
387
+
let cbor_to_bytes = function Cbort.Cbor.Bytes s -> Some s | _ -> None
383
388
384
389
(* Helper to extract ptime from CBOR integer *)
385
390
let cbor_to_ptime = function
386
-
| Cbort.Cbor.Int z ->
387
-
Ptime.of_float_s (Z.to_float z)
391
+
| Cbort.Cbor.Int z -> Ptime.of_float_s (Z.to_float z)
388
392
| _ -> None
389
393
390
394
(* Helper to extract audience (string or array of strings) *)
391
395
let cbor_to_aud = function
392
-
| Cbort.Cbor.Text s -> Some [s]
396
+
| Cbort.Cbor.Text s -> Some [ s ]
393
397
| Cbort.Cbor.Array items ->
394
398
let strings = List.filter_map cbor_to_string items in
395
-
if List.length strings = List.length items then Some strings
396
-
else None
399
+
if List.length strings = List.length items then Some strings else None
397
400
| _ -> None
398
401
399
402
(* Decode claims from CBOR map pairs *)
400
403
let decode_from_pairs pairs =
401
404
let iss = Option.bind (find_int_key key_iss pairs) cbor_to_string in
402
405
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
406
+
let aud =
407
+
Option.value ~default:[]
408
+
(Option.bind (find_int_key key_aud pairs) cbor_to_aud)
409
+
in
404
410
let exp = Option.bind (find_int_key key_exp pairs) cbor_to_ptime in
405
411
let nbf = Option.bind (find_int_key key_nbf pairs) cbor_to_ptime in
406
412
let iat = Option.bind (find_int_key key_iat pairs) cbor_to_ptime in
407
413
let cti = Option.bind (find_int_key key_cti pairs) cbor_to_bytes in
408
414
(* 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
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
418
426
{ iss; sub; aud; exp; nbf; iat; cti; custom }
419
427
420
428
(* Encode claims to CBOR map pairs *)
···
426
434
Option.iter (fun v -> add_int key_iss (Text v)) t.iss;
427
435
Option.iter (fun v -> add_int key_sub (Text v)) t.sub;
428
436
(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;
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;
441
449
Option.iter (fun v -> add_int key_cti (Bytes v)) t.cti;
442
450
(* Custom claims *)
443
-
List.iter (fun (k, v) ->
444
-
pairs := (claim_key_to_cbor k, v) :: !pairs
445
-
) t.custom;
451
+
List.iter
452
+
(fun (k, v) -> pairs := (claim_key_to_cbor k, v) :: !pairs)
453
+
t.custom;
446
454
List.rev !pairs
447
455
448
456
let claims_not_map_error = "claims must be a CBOR map"
···
451
459
let codec : t Cbort.t =
452
460
Cbort.conv
453
461
(fun cbor ->
454
-
match cbor with
455
-
| Cbort.Cbor.Map pairs -> Ok (decode_from_pairs pairs)
456
-
| _ -> Error claims_not_map_error)
462
+
match cbor with
463
+
| Cbort.Cbor.Map pairs -> Ok (decode_from_pairs pairs)
464
+
| _ -> Error claims_not_map_error)
457
465
(fun t -> Cbort.Cbor.Map (encode_to_pairs t))
458
466
Cbort.any
459
467
···
463
471
| Error e ->
464
472
(* Distinguish CBOR parse errors from claims structure errors *)
465
473
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)
474
+
if msg = claims_not_map_error then Error (Invalid_claims msg)
475
+
else Error (Invalid_cbor msg)
470
476
471
477
let to_cbor t = Cbort.encode_string codec t
472
478
end
···
485
491
claims : Claims.t;
486
492
algorithm : Algorithm.t option;
487
493
kid : string option;
488
-
protected_header : string; (* CBOR-encoded protected header *)
489
-
signature : string; (* Signature or MAC tag *)
490
-
raw : string; (* Original CBOR bytes *)
494
+
protected_header : string; (* CBOR-encoded protected header *)
495
+
signature : string; (* Signature or MAC tag *)
496
+
raw : string; (* Original CBOR bytes *)
491
497
}
492
498
493
499
let claims t = t.claims
···
498
504
(** Extract kid from header - can be Text or Bytes per RFC 9052 *)
499
505
let extract_kid_from_header pairs =
500
506
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
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
509
516
510
517
(** Decode protected header to extract algorithm and kid *)
511
518
let decode_protected_header bytes =
···
513
520
| Error _ -> (None, None)
514
521
| Ok (Cbort.Cbor.Map pairs) ->
515
522
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)
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)
527
536
in
528
537
let kid = extract_kid_from_header pairs in
529
538
(algorithm, kid)
···
538
547
let parse bytes =
539
548
match Cbort.decode_string Cbort.any bytes with
540
549
| Error e -> Error (cbort_error_to_error e)
541
-
| Ok cbor ->
550
+
| Ok cbor -> (
542
551
(* 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 *)
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 *)
546
556
| Cbort.Cbor.Array _ as arr -> Some arr (* Untagged *)
547
557
| _ -> None
548
558
in
549
559
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]) ->
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 ]) -> (
552
565
(* Extract byte strings *)
553
-
let protected_header = match protected_bstr with
554
-
| Cbort.Cbor.Bytes s -> Some s
555
-
| _ -> None
566
+
let protected_header =
567
+
match protected_bstr with Cbort.Cbor.Bytes s -> Some s | _ -> None
556
568
in
557
-
let signature = match sig_bstr with
558
-
| Cbort.Cbor.Bytes s -> Some s
559
-
| _ -> None
569
+
let signature =
570
+
match sig_bstr with Cbort.Cbor.Bytes s -> Some s | _ -> None
560
571
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"))
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"))
583
606
| Some (Cbort.Cbor.Array _) ->
584
607
Error (Invalid_cose "COSE structure must have exactly 4 elements")
585
-
| Some _ ->
586
-
Error (Invalid_cose "expected COSE array structure")
608
+
| Some _ -> Error (Invalid_cose "expected COSE array structure"))
587
609
588
610
(* Cryptographic operations *)
589
611
···
614
636
| Error _ -> Error (Key_type_mismatch "Invalid P-256 private key")
615
637
| Ok priv ->
616
638
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
639
+
let r, s = Mirage_crypto_ec.P256.Dsa.sign ~key:priv hash in
618
640
let pad32 s =
619
641
let len = String.length s in
620
642
if len >= 32 then String.sub s (len - 32) 32
···
627
649
| Error _ -> Error (Key_type_mismatch "Invalid P-384 private key")
628
650
| Ok priv ->
629
651
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
652
+
let r, s = Mirage_crypto_ec.P384.Dsa.sign ~key:priv hash in
631
653
let pad48 s =
632
654
let len = String.length s in
633
655
if len >= 48 then String.sub s (len - 48) 48
···
640
662
| Error _ -> Error (Key_type_mismatch "Invalid P-521 private key")
641
663
| Ok priv ->
642
664
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
665
+
let r, s = Mirage_crypto_ec.P521.Dsa.sign ~key:priv hash in
644
666
let pad66 s =
645
667
let len = String.length s in
646
668
if len >= 66 then String.sub s (len - 66) 66
···
656
678
(** Build Sig_structure or MAC_structure for COSE operations *)
657
679
let build_sig_structure ~context_string ~protected_header ~payload =
658
680
let open Cbort.Cbor in
659
-
Array [
660
-
Text context_string;
661
-
Bytes protected_header;
662
-
Bytes ""; (* external_aad = empty *)
663
-
Bytes payload;
664
-
]
681
+
Array
682
+
[
683
+
Text context_string;
684
+
Bytes protected_header;
685
+
Bytes "";
686
+
(* external_aad = empty *)
687
+
Bytes payload;
688
+
]
665
689
|> Cbort.encode_string Cbort.any
666
690
667
691
(** Expected signature/MAC length for each algorithm *)
668
692
let expected_sig_length = function
669
-
| Algorithm.ES256 -> 64 (* 32 + 32 *)
670
-
| Algorithm.ES384 -> 96 (* 48 + 48 *)
671
-
| Algorithm.ES512 -> 132 (* 66 + 66 *)
693
+
| Algorithm.ES256 -> 64 (* 32 + 32 *)
694
+
| Algorithm.ES384 -> 96 (* 48 + 48 *)
695
+
| Algorithm.ES512 -> 132 (* 66 + 66 *)
672
696
| Algorithm.EdDSA -> 64
673
697
| Algorithm.HMAC_256_64 -> 8
674
698
| Algorithm.HMAC_256 -> 32
···
677
701
678
702
let verify ~key ?allowed_algs t =
679
703
(* Check algorithm is allowed *)
680
-
let alg = match t.algorithm with
704
+
let alg =
705
+
match t.algorithm with
681
706
| None -> Error (Invalid_cose "No algorithm in protected header")
682
707
| Some a -> Ok a
683
708
in
684
709
match alg with
685
710
| Error e -> Error e
686
711
| Ok alg ->
687
-
let allowed = match allowed_algs with
688
-
| None -> Algorithm.all
689
-
| Some l -> l
712
+
let allowed =
713
+
match allowed_algs with None -> Algorithm.all | Some l -> l
690
714
in
691
715
if not (List.mem alg allowed) then
692
716
Error (Algorithm_not_allowed (Algorithm.to_string alg))
···
695
719
let expected_len = expected_sig_length alg in
696
720
let actual_len = String.length t.signature in
697
721
if actual_len <> expected_len then
698
-
Error (Invalid_cose (Printf.sprintf
699
-
"signature length mismatch: expected %d, got %d" expected_len actual_len))
722
+
Error
723
+
(Invalid_cose
724
+
(Printf.sprintf "signature length mismatch: expected %d, got %d"
725
+
expected_len actual_len))
700
726
else
701
727
(* 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"
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"
705
733
| _ -> "Signature1"
706
734
in
707
735
let payload = Claims.to_cbor t.claims in
708
-
let sig_structure = build_sig_structure
709
-
~context_string ~protected_header:t.protected_header ~payload
736
+
let sig_structure =
737
+
build_sig_structure ~context_string
738
+
~protected_header:t.protected_header ~payload
710
739
in
711
740
(* 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 } ->
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 } ) ->
715
746
if hmac_verify alg k sig_structure t.signature then Ok ()
716
747
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"))
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"))
754
814
| _ ->
755
-
Error (Key_type_mismatch
756
-
(Printf.sprintf "Key type doesn't match algorithm %s"
757
-
(Algorithm.to_string alg)))
815
+
Error
816
+
(Key_type_mismatch
817
+
(Printf.sprintf "Key type doesn't match algorithm %s"
818
+
(Algorithm.to_string alg)))
758
819
in
759
820
verify_result
760
821
···
763
824
(* Check exp *)
764
825
let check_exp () =
765
826
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 ())
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 ())
770
831
| None -> Ok ()
771
832
in
772
833
(* Check nbf *)
773
834
let check_nbf () =
774
835
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 ())
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 ())
779
841
| None -> Ok ()
780
842
in
781
843
(* Check iss *)
782
844
let check_iss () =
783
845
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)
846
+
| Some expected_iss -> (
847
+
match t.claims.iss with
848
+
| Some actual_iss when actual_iss = expected_iss -> Ok ()
849
+
| _ -> Error Invalid_issuer)
788
850
| None -> Ok ()
789
851
in
790
852
(* Check aud *)
···
797
859
in
798
860
match check_exp () with
799
861
| Error _ as e -> e
800
-
| Ok () ->
862
+
| Ok () -> (
801
863
match check_nbf () with
802
864
| Error _ as e -> e
803
-
| Ok () ->
804
-
match check_iss () with
805
-
| Error _ as e -> e
806
-
| Ok () -> check_aud ()
865
+
| Ok () -> (
866
+
match check_iss () with Error _ as e -> e | Ok () -> check_aud ()))
807
867
808
868
let verify_and_validate ~key ~now ?allowed_algs ?iss ?aud ?leeway t =
809
869
match verify ~key ?allowed_algs t with
···
813
873
(** Encode protected header as CBOR map *)
814
874
let encode_protected_header algorithm =
815
875
let open Cbort.Cbor in
816
-
Map [
817
-
(Int (Z.of_int header_alg), Int (Z.of_int (Algorithm.to_cose_int algorithm)));
818
-
]
876
+
Map
877
+
[
878
+
( Int (Z.of_int header_alg),
879
+
Int (Z.of_int (Algorithm.to_cose_int algorithm)) );
880
+
]
819
881
|> Cbort.encode_string Cbort.any
820
882
821
883
(** Encode COSE_Sign1 or COSE_Mac0 structure *)
822
884
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
-
])
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
+
] )
829
895
|> Cbort.encode_string Cbort.any
830
896
831
897
let create ~algorithm ~claims ~key =
···
833
899
let protected_header = encode_protected_header algorithm in
834
900
835
901
(* 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"
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"
839
907
| _ -> "Signature1"
840
908
in
841
909
let payload = Claims.to_cbor claims in
842
-
let to_be_signed = build_sig_structure ~context_string ~protected_header ~payload in
910
+
let to_be_signed =
911
+
build_sig_structure ~context_string ~protected_header ~payload
912
+
in
843
913
844
914
(* 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 } ->
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 } ) ->
848
920
hmac_sign algorithm k to_be_signed
849
921
| Algorithm.EdDSA, Cose_key.Ed25519_priv { d; _ } ->
850
922
ed25519_sign ~priv:d to_be_signed
···
854
926
p384_sign ~priv:d to_be_signed
855
927
| Algorithm.ES512, Cose_key.P521_priv { d; _ } ->
856
928
p521_sign ~priv:d to_be_signed
857
-
| _ ->
858
-
Error (Key_type_mismatch "Key type doesn't match algorithm")
929
+
| _ -> Error (Key_type_mismatch "Key type doesn't match algorithm")
859
930
in
860
931
861
932
match signature_result with
862
933
| Error e -> Error e
863
934
| Ok signature ->
864
935
(* 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
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
868
941
| _ -> cose_sign1_tag
869
942
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
-
}
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
+
}
879
955
880
956
let encode t = t.raw
881
957
882
958
let is_expired ~now ?leeway t =
883
959
match t.claims.exp with
884
960
| None -> false
885
-
| Some exp ->
961
+
| Some exp -> (
886
962
let leeway = Option.value leeway ~default:Ptime.Span.zero in
887
963
match Ptime.add_span exp leeway with
888
964
| Some exp' -> Ptime.is_later now ~than:exp'
889
-
| None -> true
965
+
| None -> true)
890
966
891
967
let time_to_expiry ~now t =
892
968
match t.claims.exp with
893
969
| None -> None
894
970
| Some exp ->
895
971
let diff = Ptime.diff exp now in
896
-
if Ptime.Span.compare diff Ptime.Span.zero <= 0 then None
897
-
else Some diff
972
+
if Ptime.Span.compare diff Ptime.Span.zero <= 0 then None else Some diff
+124
-106
lib/cwt.mli
+124
-106
lib/cwt.mli
···
9
9
{{:https://datatracker.ietf.org/doc/html/rfc8392}RFC 8392}.
10
10
11
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
12
+
environments where compact binary representation is important. CWTs use COSE
13
+
({{:https://datatracker.ietf.org/doc/html/rfc9052}RFC 9052}) for
14
14
cryptographic protection.
15
15
16
16
{2 Quick Start}
17
17
18
18
{[
19
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)
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)
25
29
26
30
(* Create a symmetric key *)
27
-
let key = Cwt.Cose_key.symmetric (Bytes.of_string "my-secret-key-32-bytes-long!!!!!")
31
+
let key =
32
+
Cwt.Cose_key.symmetric
33
+
(Bytes.of_string "my-secret-key-32-bytes-long!!!!!")
28
34
29
35
(* Create and encode the CWT *)
30
-
let cwt = Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key |> Result.get_ok
36
+
let cwt =
37
+
Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key
38
+
|> Result.get_ok
39
+
31
40
let encoded = Cwt.encode cwt
32
41
33
42
(* Parse and verify *)
···
36
45
]}
37
46
38
47
{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)}} *)
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) *)
44
56
45
57
(** {1 Error Handling} *)
46
58
47
59
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 *)
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 *)
56
64
| Algorithm_not_allowed of string
57
65
(** Algorithm rejected by allowed_algs policy *)
58
-
| Signature_mismatch
59
-
(** Signature/MAC verification failed *)
66
+
| Signature_mismatch (** Signature/MAC verification failed *)
60
67
| Token_expired
61
68
(** exp claim validation failed per
62
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.4}RFC 8392 Section 3.1.4} *)
69
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.4}RFC
70
+
8392 Section 3.1.4} *)
63
71
| Token_not_yet_valid
64
72
(** nbf claim validation failed per
65
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.5}RFC 8392 Section 3.1.5} *)
73
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.5}RFC
74
+
8392 Section 3.1.5} *)
66
75
| Invalid_issuer
67
76
(** iss claim mismatch per
68
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.1}RFC 8392 Section 3.1.1} *)
77
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.1}RFC
78
+
8392 Section 3.1.1} *)
69
79
| Invalid_audience
70
80
(** 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 *)
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 *)
74
84
75
85
val pp_error : Format.formatter -> error -> unit
76
86
(** Pretty-print an error. *)
···
83
93
Cryptographic algorithms for COSE as specified in
84
94
{{:https://datatracker.ietf.org/doc/html/rfc9053}RFC 9053}.
85
95
86
-
Each algorithm has a registered integer identifier in the IANA
87
-
COSE Algorithms registry. *)
96
+
Each algorithm has a registered integer identifier in the IANA COSE
97
+
Algorithms registry. *)
88
98
89
99
module Algorithm : sig
90
100
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 *)
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 *)
95
105
| 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 *)
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 *)
99
109
100
110
val to_cose_int : t -> int
101
111
(** Convert to COSE algorithm identifier (negative for signatures). *)
···
112
122
113
123
(** {1 COSE Key}
114
124
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}. *)
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}. *)
118
128
119
129
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}. *)
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}. *)
123
133
type kty =
124
-
| Okp (** Octet Key Pair (kty = 1), used for EdDSA *)
125
-
| Ec2 (** Elliptic Curve with x,y coordinates (kty = 2) *)
134
+
| Okp (** Octet Key Pair (kty = 1), used for EdDSA *)
135
+
| Ec2 (** Elliptic Curve with x,y coordinates (kty = 2) *)
126
136
| Symmetric (** Symmetric key (kty = 4) *)
127
137
138
+
type t
128
139
(** A COSE key.
129
140
130
141
Supported key types and curves:
···
133
144
- P-384 (NIST, crv = 2) for ES384
134
145
- P-521 (NIST, crv = 3) for ES512
135
146
- Ed25519 (crv = 6) for EdDSA *)
136
-
type t
137
147
138
148
(** {2 Constructors} *)
139
149
140
150
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.). *)
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.). *)
144
154
145
155
val ed25519_pub : string -> t
146
-
(** [ed25519_pub pub] creates an Ed25519 public key from the 32-byte
147
-
public key value. *)
156
+
(** [ed25519_pub pub] creates an Ed25519 public key from the 32-byte public
157
+
key value. *)
148
158
149
159
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. *)
160
+
(** [ed25519_priv ~pub ~priv] creates an Ed25519 private key. [pub] is the
161
+
32-byte public key, [priv] is the 32-byte seed. *)
152
162
153
163
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). *)
164
+
(** [p256_pub ~x ~y] creates a P-256 public key from the x and y coordinates
165
+
(each 32 bytes). *)
156
166
157
167
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. *)
168
+
(** [p256_priv ~x ~y ~d] creates a P-256 private key. [d] is the 32-byte
169
+
private key value. *)
160
170
161
171
val p384_pub : x:string -> y:string -> t
162
-
(** [p384_pub ~x ~y] creates a P-384 public key (coordinates are 48 bytes each). *)
172
+
(** [p384_pub ~x ~y] creates a P-384 public key (coordinates are 48 bytes
173
+
each). *)
163
174
164
175
val p384_priv : x:string -> y:string -> d:string -> t
165
176
(** [p384_priv ~x ~y ~d] creates a P-384 private key. *)
166
177
167
178
val p521_pub : x:string -> y:string -> t
168
-
(** [p521_pub ~x ~y] creates a P-521 public key (coordinates are 66 bytes each). *)
179
+
(** [p521_pub ~x ~y] creates a P-521 public key (coordinates are 66 bytes
180
+
each). *)
169
181
170
182
val p521_priv : x:string -> y:string -> d:string -> t
171
183
(** [p521_priv ~x ~y ~d] creates a P-521 private key. *)
···
198
210
199
211
(** {1 CWT Claims}
200
212
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}.
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}.
203
216
204
217
{2 Claim Key Mapping}
205
218
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 | *)
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 | *)
215
223
216
224
module Claims : sig
217
225
type t
218
226
219
227
(** {2 Registered Claim Names}
220
228
221
-
See {{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1}RFC 8392 Section 3.1}. *)
229
+
See
230
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1}RFC 8392
231
+
Section 3.1}. *)
222
232
223
233
val iss : t -> string option
224
234
(** Issuer claim (key 1) per
225
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.1}Section 3.1.1}. *)
235
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.1}Section
236
+
3.1.1}. *)
226
237
227
238
val sub : t -> string option
228
239
(** Subject claim (key 2) per
229
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.2}Section 3.1.2}. *)
240
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.2}Section
241
+
3.1.2}. *)
230
242
231
243
val aud : t -> string list
232
244
(** 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. *)
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. *)
235
248
236
249
val exp : t -> Ptime.t option
237
250
(** Expiration time claim (key 4) per
238
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.4}Section 3.1.4}. *)
251
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.4}Section
252
+
3.1.4}. *)
239
253
240
254
val nbf : t -> Ptime.t option
241
255
(** Not Before claim (key 5) per
242
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.5}Section 3.1.5}. *)
256
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.5}Section
257
+
3.1.5}. *)
243
258
244
259
val iat : t -> Ptime.t option
245
260
(** Issued At claim (key 6) per
246
-
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.6}Section 3.1.6}. *)
261
+
{{:https://datatracker.ietf.org/doc/html/rfc8392#section-3.1.6}Section
262
+
3.1.6}. *)
247
263
248
264
val cti : t -> string option
249
265
(** 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. *)
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. *)
252
269
253
270
(** {2 Custom Claims}
254
271
255
272
CWT supports both integer and text string keys for custom claims. *)
256
273
257
274
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]. *)
275
+
(** [get_int_key key claims] returns the CBOR value of custom claim with
276
+
integer key [key]. *)
260
277
261
278
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]. *)
279
+
(** [get_string_key key claims] returns the CBOR value of custom claim with
280
+
string key [key]. *)
264
281
265
282
(** {2 Construction} *)
266
283
···
314
331
(** {1 CWT Token} *)
315
332
316
333
type t
317
-
(** A parsed CWT token (COSE_Sign1 or COSE_Mac0 structure).
318
-
Note: COSE_Encrypt0 is not currently supported. *)
334
+
(** A parsed CWT token (COSE_Sign1 or COSE_Mac0 structure). Note: COSE_Encrypt0
335
+
is not currently supported. *)
319
336
320
337
(** {2 Parsing}
321
338
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}. *)
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}. *)
324
343
325
344
val parse : string -> (t, error) result
326
345
(** [parse cwt_bytes] parses a CWT from CBOR bytes.
327
346
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. *)
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. *)
331
350
332
351
(** {2 Accessors} *)
333
352
···
348
367
Verify cryptographic protection and validate claims. *)
349
368
350
369
val verify :
351
-
key:Cose_key.t ->
352
-
?allowed_algs:Algorithm.t list ->
353
-
t ->
354
-
(unit, error) result
370
+
key:Cose_key.t -> ?allowed_algs:Algorithm.t list -> t -> (unit, error) result
355
371
(** [verify ~key ?allowed_algs t] verifies the COSE signature or MAC.
356
372
357
373
@param key The key to verify with (must match algorithm)
···
380
396
?leeway:Ptime.Span.t ->
381
397
t ->
382
398
(unit, error) result
383
-
(** [verify_and_validate ~key ~now ...] verifies signature and validates claims. *)
399
+
(** [verify_and_validate ~key ~now ...] verifies signature and validates claims.
400
+
*)
384
401
385
402
(** {2 Creation}
386
403
···
393
410
(t, error) result
394
411
(** [create ~algorithm ~claims ~key] creates and signs a new CWT.
395
412
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).
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).
398
416
399
417
The [key] must be appropriate for the algorithm:
400
418
- HMAC algorithms: symmetric key
···
404
422
- EdDSA: Ed25519 private key *)
405
423
406
424
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). *)
425
+
(** [encode t] returns the CBOR serialization of the CWT. The result is a tagged
426
+
COSE structure (COSE_Sign1 or COSE_Mac0). *)
409
427
410
428
(** {1 Utilities} *)
411
429
412
430
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. *)
431
+
(** [is_expired ~now ?leeway t] checks if the token has expired. Returns false
432
+
if no exp claim present. *)
415
433
416
434
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. *)
435
+
(** [time_to_expiry ~now t] returns time until expiration, or [None] if no
436
+
expiration claim or already expired. *)
+299
-239
lib/jsonwt.ml
+299
-239
lib/jsonwt.ml
···
39
39
| Unsecured_not_allowed -> Format.fprintf fmt "Unsecured JWT not allowed"
40
40
| Nesting_too_deep -> Format.fprintf fmt "Nested JWT too deep"
41
41
42
-
let error_to_string e =
43
-
Format.asprintf "%a" pp_error e
42
+
let error_to_string e = Format.asprintf "%a" pp_error e
44
43
45
44
(* Base64url encoding/decoding per RFC 7515 Appendix C *)
46
45
let base64url_encode s =
···
64
63
let scheme = String.sub s 0 i in
65
64
(* Check scheme is alphanumeric with +.- allowed after first char *)
66
65
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
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
74
77
in
75
78
if valid_scheme then Ok s
76
79
else Error (Invalid_uri (Printf.sprintf "Invalid URI scheme in: %s" s))
77
80
| _ -> Error (Invalid_uri (Printf.sprintf "Invalid URI: %s" s))
78
-
else
79
-
Ok s
81
+
else Ok s
80
82
81
83
(* Algorithm module *)
82
84
module Algorithm = struct
···
120
122
| "EdDSA" -> Ok EdDSA
121
123
| s -> Error (Unsupported_algorithm s)
122
124
123
-
let all = [ HS256; HS384; HS512; RS256; RS384; RS512; ES256; ES384; ES512; EdDSA ]
125
+
let all =
126
+
[ HS256; HS384; HS512; RS256; RS384; RS512; ES256; ES384; ES512; EdDSA ]
127
+
124
128
let all_with_none = None :: all
125
129
end
126
130
127
131
(* JWK module *)
128
132
module Jwk = struct
129
133
type kty = Oct | Rsa | Ec | Okp
130
-
131
134
type crv = P256 | P384 | P521 | Ed25519
132
135
133
136
type key_data =
···
164
167
{ key_data = Ed25519_pub { x }; kid = None; alg = Some Algorithm.EdDSA }
165
168
166
169
let ed25519_priv ~pub ~priv =
167
-
{ key_data = Ed25519_priv { x = pub; d = priv }; kid = None; alg = Some Algorithm.EdDSA }
170
+
{
171
+
key_data = Ed25519_priv { x = pub; d = priv };
172
+
kid = None;
173
+
alg = Some Algorithm.EdDSA;
174
+
}
168
175
169
176
let p256_pub ~x ~y =
170
177
{ key_data = P256_pub { x; y }; kid = None; alg = Some Algorithm.ES256 }
···
188
195
{ key_data = Rsa_pub { n; e }; kid = None; alg = Some Algorithm.RS256 }
189
196
190
197
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 }
198
+
{
199
+
key_data = Rsa_priv { n; e; d; p; q; dp; dq; qi };
200
+
kid = None;
201
+
alg = Some Algorithm.RS256;
202
+
}
192
203
193
204
let kty t =
194
205
match t.key_data with
195
206
| Symmetric _ -> Oct
196
207
| Ed25519_pub _ | Ed25519_priv _ -> Okp
197
-
| P256_pub _ | P256_priv _ | P384_pub _ | P384_priv _ | P521_pub _ | P521_priv _ -> Ec
208
+
| P256_pub _ | P256_priv _ | P384_pub _ | P384_priv _ | P521_pub _
209
+
| P521_priv _ ->
210
+
Ec
198
211
| Rsa_pub _ | Rsa_priv _ -> Rsa
199
212
200
213
let kid t = t.kid
201
214
let alg t = t.alg
202
-
203
215
let with_kid id t = { t with kid = Some id }
204
216
let with_alg a t = { t with alg = Some a }
205
217
206
218
(* Helper to extract string from Jsont.json object members *)
207
219
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
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
215
226
216
227
let get_json_string_req members name =
217
228
match get_json_string members name with
218
229
| Some s -> Ok s
219
-
| None -> Error (Invalid_json (Printf.sprintf "missing required field: %s" name))
230
+
| None ->
231
+
Error (Invalid_json (Printf.sprintf "missing required field: %s" name))
220
232
221
233
let of_json s =
222
234
(* Parse the JSON to determine key type first *)
223
235
match Jsont_bytesrw.decode_string Jsont.json s with
224
236
| Error e -> Error (Invalid_json e)
225
237
| Ok (Jsont.Null _) -> Error (Invalid_json "null is not a valid JWK")
226
-
| Ok (Jsont.Object (members, _)) ->
238
+
| Ok (Jsont.Object (members, _)) -> (
227
239
let ( let* ) = Result.bind in
228
240
let* kty_s = get_json_string_req members "kty" in
229
241
let kid = get_json_string members "kid" in
230
242
let alg_opt =
231
243
match get_json_string members "alg" with
232
244
| None -> Ok None
233
-
| Some s ->
245
+
| Some s -> (
234
246
match Algorithm.of_string s with
235
247
| Ok a -> Ok (Some a)
236
-
| Error _ -> Ok None (* ignore unknown alg in JWK *)
248
+
| Error _ -> Ok None (* ignore unknown alg in JWK *))
237
249
in
238
250
let* alg = alg_opt in
239
-
(match kty_s with
251
+
match kty_s with
240
252
| "oct" ->
241
253
let* k_b64 = get_json_string_req members "k" in
242
254
let* k = base64url_decode k_b64 in
243
255
Ok { key_data = Symmetric { k }; kid; alg }
244
-
| "OKP" ->
256
+
| "OKP" -> (
245
257
let* crv = get_json_string_req members "crv" in
246
258
if crv <> "Ed25519" then
247
259
Error (Invalid_json (Printf.sprintf "unsupported curve: %s" crv))
248
260
else
249
261
let* x_b64 = get_json_string_req members "x" in
250
262
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" ->
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" -> (
257
269
let* crv = get_json_string_req members "crv" in
258
270
let* x_b64 = get_json_string_req members "x" in
259
271
let* y_b64 = get_json_string_req members "y" in
···
264
276
let* d_b64 = get_json_string_req members "d" in
265
277
base64url_decode d_b64
266
278
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" ->
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" -> (
288
299
let* n_b64 = get_json_string_req members "n" in
289
300
let* e_b64 = get_json_string_req members "e" in
290
301
let* n = base64url_decode n_b64 in
291
302
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)))
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
+
)
308
325
| Ok _ -> Error (Invalid_json "JWK must be a JSON object")
309
326
310
327
(* Helper to create JSON members *)
···
320
337
in
321
338
let members = [] in
322
339
let members = add_opt "kid" t.kid members in
323
-
let members = add_opt "alg" (Option.map Algorithm.to_string t.alg) members in
340
+
let members =
341
+
add_opt "alg" (Option.map Algorithm.to_string t.alg) members
342
+
in
324
343
let members =
325
344
match t.key_data with
326
345
| Symmetric { k } ->
327
-
json_mem "kty" (json_string "oct") ::
328
-
json_mem "k" (json_string (base64url_encode k)) :: members
346
+
json_mem "kty" (json_string "oct")
347
+
:: json_mem "k" (json_string (base64url_encode k))
348
+
:: members
329
349
| 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
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
333
354
| 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
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
338
360
| 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
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
343
366
| 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
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
349
373
| 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
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
354
379
| 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
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
360
386
| 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
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
365
392
| 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
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
371
399
| 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
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
375
404
| 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
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
385
415
in
386
-
match Jsont_bytesrw.encode_string Jsont.json (Jsont.Object (members, meta)) with
416
+
match
417
+
Jsont_bytesrw.encode_string Jsont.json (Jsont.Object (members, meta))
418
+
with
387
419
| Ok s -> s
388
420
| Error _ -> "{}" (* Should not happen *)
389
421
end
···
406
438
407
439
(* Helper to extract string from Jsont.json object members *)
408
440
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
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
416
447
417
448
let of_json s =
418
449
match Jsont_bytesrw.decode_string Jsont.json s with
419
450
| Error e -> Error (Invalid_json e)
420
451
| Ok (Jsont.Null _) -> Error (Invalid_header "null is not a valid header")
421
-
| Ok (Jsont.Object (members, _)) ->
452
+
| Ok (Jsont.Object (members, _)) -> (
422
453
let ( let* ) = Result.bind in
423
454
let alg_s = get_json_string members "alg" in
424
-
(match alg_s with
455
+
match alg_s with
425
456
| None -> Error (Invalid_header "missing required 'alg' field")
426
457
| Some alg_str ->
427
458
let* alg = Algorithm.of_string alg_str in
···
436
467
let json_mem name value = ((name, meta), value)
437
468
438
469
let to_json h =
439
-
let members = [ json_mem "alg" (json_string (Algorithm.to_string h.alg)) ] in
470
+
let members =
471
+
[ json_mem "alg" (json_string (Algorithm.to_string h.alg)) ]
472
+
in
440
473
let add_opt name v_opt acc =
441
474
match v_opt with
442
475
| None -> acc
···
445
478
let members = add_opt "typ" h.typ members in
446
479
let members = add_opt "kid" h.kid members in
447
480
let members = add_opt "cty" h.cty members in
448
-
match Jsont_bytesrw.encode_string Jsont.json (Jsont.Object (List.rev members, meta)) with
481
+
match
482
+
Jsont_bytesrw.encode_string Jsont.json
483
+
(Jsont.Object (List.rev members, meta))
484
+
with
449
485
| Ok s -> s
450
486
| Error _ -> "{}"
451
487
end
···
470
506
let nbf t = t.nbf
471
507
let iat t = t.iat
472
508
let jti t = t.jti
473
-
474
509
let get name t = List.assoc_opt name t.custom
475
510
476
511
let get_string name t =
477
-
match get name t with
478
-
| Some (Jsont.String (s, _)) -> Some s
479
-
| _ -> None
512
+
match get name t with Some (Jsont.String (s, _)) -> Some s | _ -> None
480
513
481
514
let get_int name t =
482
515
match get name t with
483
-
| Some (Jsont.Number (n, _)) -> (try Some (int_of_float n) with _ -> None)
516
+
| Some (Jsont.Number (n, _)) -> (
517
+
try Some (int_of_float n) with _ -> None)
484
518
| _ -> None
485
519
486
520
let get_bool name t =
487
-
match get name t with
488
-
| Some (Jsont.Bool (b, _)) -> Some b
489
-
| _ -> None
521
+
match get name t with Some (Jsont.Bool (b, _)) -> Some b | _ -> None
490
522
491
523
let meta = Jsont.Meta.none
492
524
let json_string s = Jsont.String (s, meta)
···
496
528
497
529
type builder = t
498
530
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
-
}
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
+
}
509
542
510
543
let set_iss v t = { t with iss = Some v }
511
544
let set_sub v t = { t with sub = Some v }
···
524
557
let span = Ptime.Span.of_float_s n in
525
558
Option.bind span (fun s -> Ptime.of_span s)
526
559
527
-
let numeric_date_of_ptime t =
528
-
Ptime.to_span t |> Ptime.Span.to_float_s
560
+
let numeric_date_of_ptime t = Ptime.to_span t |> Ptime.Span.to_float_s
529
561
530
562
(* Helper to extract values from Jsont.json object members *)
531
563
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
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
539
570
540
571
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
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
548
578
549
579
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:[]
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:[]
562
594
563
595
let of_json ?(strict = true) s =
564
596
match Jsont_bytesrw.decode_string Jsont.json s with
565
597
| Error e -> Error (Invalid_json e)
566
-
| Ok (Jsont.Null _) -> Error (Invalid_claims "null is not a valid claims set")
598
+
| Ok (Jsont.Null _) ->
599
+
Error (Invalid_claims "null is not a valid claims set")
567
600
| Ok (Jsont.Object (members, _)) ->
568
601
let ( let* ) = Result.bind in
569
602
(* Check for duplicates in strict mode *)
···
594
627
let* _ = validate_string_or_uri s in
595
628
Ok (Some s)
596
629
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
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
600
639
let jti = get_json_string members "jti" in
601
640
let aud = get_json_aud members in
602
641
(* Collect custom claims (everything not registered) *)
603
642
let registered = [ "iss"; "sub"; "aud"; "exp"; "nbf"; "iat"; "jti" ] in
604
643
let custom =
605
-
List.filter_map (fun ((n, _), v) ->
606
-
if List.mem n registered then None
607
-
else Some (n, v)
608
-
) members
644
+
List.filter_map
645
+
(fun ((n, _), v) ->
646
+
if List.mem n registered then None else Some (n, v))
647
+
members
609
648
in
610
649
Ok { iss; sub; aud; exp; nbf; iat; jti; custom }
611
650
| Ok _ -> Error (Invalid_claims "claims must be a JSON object")
···
637
676
let members = add_time "iat" t.iat members in
638
677
let members = add_string "jti" t.jti members in
639
678
let members =
640
-
List.fold_left (fun acc (name, value) ->
641
-
json_mem name value :: acc
642
-
) members t.custom
679
+
List.fold_left
680
+
(fun acc (name, value) -> json_mem name value :: acc)
681
+
members t.custom
643
682
in
644
-
match Jsont_bytesrw.encode_string Jsont.json (Jsont.Object (List.rev members, meta)) with
683
+
match
684
+
Jsont_bytesrw.encode_string Jsont.json
685
+
(Jsont.Object (List.rev members, meta))
686
+
with
645
687
| Ok s -> s
646
688
| Error _ -> "{}"
647
689
end
···
658
700
let claims t = t.claims
659
701
let signature t = t.signature
660
702
let raw t = t.raw
661
-
662
703
let is_nested t = Header.is_nested t.header
663
704
664
705
(* Parsing *)
···
688
729
let parse_nested ?(strict = true) ?(max_depth = 5) token =
689
730
let ( let* ) = Result.bind in
690
731
let rec loop depth acc tok =
691
-
if depth > max_depth then
692
-
Error Nesting_too_deep
732
+
if depth > max_depth then Error Nesting_too_deep
693
733
else
694
734
let* jwt = parse ~strict tok in
695
735
let acc = jwt :: acc in
···
700
740
let* inner_token = base64url_decode payload_b64 in
701
741
loop (depth + 1) acc inner_token
702
742
| _ -> Ok (List.rev acc)
703
-
else
704
-
Ok (List.rev acc)
743
+
else Ok (List.rev acc)
705
744
in
706
745
loop 1 [] token
707
746
···
710
749
let hmac_sha256 ~key data =
711
750
let key = Cstruct.of_string key in
712
751
let data = Cstruct.of_string data in
713
-
Digestif.SHA256.hmac_string ~key:(Cstruct.to_string key) (Cstruct.to_string data)
752
+
Digestif.SHA256.hmac_string ~key:(Cstruct.to_string key)
753
+
(Cstruct.to_string data)
714
754
|> Digestif.SHA256.to_raw_string
715
755
716
756
let hmac_sha384 ~key data =
717
757
let key = Cstruct.of_string key in
718
758
let data = Cstruct.of_string data in
719
-
Digestif.SHA384.hmac_string ~key:(Cstruct.to_string key) (Cstruct.to_string data)
759
+
Digestif.SHA384.hmac_string ~key:(Cstruct.to_string key)
760
+
(Cstruct.to_string data)
720
761
|> Digestif.SHA384.to_raw_string
721
762
722
763
let hmac_sha512 ~key data =
723
764
let key = Cstruct.of_string key in
724
765
let data = Cstruct.of_string data in
725
-
Digestif.SHA512.hmac_string ~key:(Cstruct.to_string key) (Cstruct.to_string data)
766
+
Digestif.SHA512.hmac_string ~key:(Cstruct.to_string key)
767
+
(Cstruct.to_string data)
726
768
|> Digestif.SHA512.to_raw_string
727
769
728
770
(* EdDSA signing using mirage-crypto-ec *)
···
737
779
match Mirage_crypto_ec.Ed25519.pub_of_octets pub with
738
780
| Error _ -> Error (Key_type_mismatch "Invalid Ed25519 public key")
739
781
| Ok pub ->
740
-
let valid = Mirage_crypto_ec.Ed25519.verify ~key:pub signature ~msg:data in
782
+
let valid =
783
+
Mirage_crypto_ec.Ed25519.verify ~key:pub signature ~msg:data
784
+
in
741
785
if valid then Ok () else Error Signature_mismatch
742
786
743
787
(* P-256 ECDSA *)
···
745
789
match Mirage_crypto_ec.P256.Dsa.priv_of_octets priv with
746
790
| Error _ -> Error (Key_type_mismatch "Invalid P-256 private key")
747
791
| 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
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
750
796
(* JWS uses raw R||S format, each 32 bytes for P-256 *)
751
797
(* Pad to 32 bytes each *)
752
798
let pad32 s =
···
757
803
Ok (pad32 r ^ pad32 s)
758
804
759
805
let p256_verify ~pub ~signature data =
760
-
if String.length signature <> 64 then
761
-
Error Signature_mismatch
806
+
if String.length signature <> 64 then Error Signature_mismatch
762
807
else
763
808
let r = String.sub signature 0 32 in
764
809
let s = String.sub signature 32 32 in
765
810
match Mirage_crypto_ec.P256.Dsa.pub_of_octets pub with
766
811
| Error _ -> Error (Key_type_mismatch "Invalid P-256 public key")
767
812
| Ok pub ->
768
-
let hash = Digestif.SHA256.digest_string data |> Digestif.SHA256.to_raw_string in
813
+
let hash =
814
+
Digestif.SHA256.digest_string data |> Digestif.SHA256.to_raw_string
815
+
in
769
816
let valid = Mirage_crypto_ec.P256.Dsa.verify ~key:pub (r, s) hash in
770
817
if valid then Ok () else Error Signature_mismatch
771
818
···
774
821
match Mirage_crypto_ec.P384.Dsa.priv_of_octets priv with
775
822
| Error _ -> Error (Key_type_mismatch "Invalid P-384 private key")
776
823
| 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
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
779
828
let pad48 s =
780
829
let len = String.length s in
781
830
if len >= 48 then String.sub s (len - 48) 48
···
784
833
Ok (pad48 r ^ pad48 s)
785
834
786
835
let p384_verify ~pub ~signature data =
787
-
if String.length signature <> 96 then
788
-
Error Signature_mismatch
836
+
if String.length signature <> 96 then Error Signature_mismatch
789
837
else
790
838
let r = String.sub signature 0 48 in
791
839
let s = String.sub signature 48 48 in
792
840
match Mirage_crypto_ec.P384.Dsa.pub_of_octets pub with
793
841
| Error _ -> Error (Key_type_mismatch "Invalid P-384 public key")
794
842
| Ok pub ->
795
-
let hash = Digestif.SHA384.digest_string data |> Digestif.SHA384.to_raw_string in
843
+
let hash =
844
+
Digestif.SHA384.digest_string data |> Digestif.SHA384.to_raw_string
845
+
in
796
846
let valid = Mirage_crypto_ec.P384.Dsa.verify ~key:pub (r, s) hash in
797
847
if valid then Ok () else Error Signature_mismatch
798
848
···
801
851
match Mirage_crypto_ec.P521.Dsa.priv_of_octets priv with
802
852
| Error _ -> Error (Key_type_mismatch "Invalid P-521 private key")
803
853
| 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
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
806
858
let pad66 s =
807
859
let len = String.length s in
808
860
if len >= 66 then String.sub s (len - 66) 66
···
811
863
Ok (pad66 r ^ pad66 s)
812
864
813
865
let p521_verify ~pub ~signature data =
814
-
if String.length signature <> 132 then
815
-
Error Signature_mismatch
866
+
if String.length signature <> 132 then Error Signature_mismatch
816
867
else
817
868
let r = String.sub signature 0 66 in
818
869
let s = String.sub signature 66 66 in
819
870
match Mirage_crypto_ec.P521.Dsa.pub_of_octets pub with
820
871
| Error _ -> Error (Key_type_mismatch "Invalid P-521 public key")
821
872
| Ok pub ->
822
-
let hash = Digestif.SHA512.digest_string data |> Digestif.SHA512.to_raw_string in
873
+
let hash =
874
+
Digestif.SHA512.digest_string data |> Digestif.SHA512.to_raw_string
875
+
in
823
876
let valid = Mirage_crypto_ec.P521.Dsa.verify ~key:pub (r, s) hash in
824
877
if valid then Ok () else Error Signature_mismatch
825
878
···
847
900
let* () =
848
901
if alg = Algorithm.None then
849
902
(* For alg:none, only allow_none flag matters *)
850
-
if allow_none then Ok ()
851
-
else Error Unsecured_not_allowed
903
+
if allow_none then Ok () else Error Unsecured_not_allowed
852
904
else if List.mem alg allowed_algs then Ok ()
853
905
else Error (Algorithm_not_allowed alg_str)
854
906
in
855
907
let input = signing_input t.raw in
856
-
match alg, key.Jwk.key_data with
908
+
match (alg, key.Jwk.key_data) with
857
909
| Algorithm.None, _ ->
858
910
(* Unsecured JWT - signature must be empty *)
859
-
if t.signature = "" then Ok ()
860
-
else Error Signature_mismatch
911
+
if t.signature = "" then Ok () else Error Signature_mismatch
861
912
| Algorithm.HS256, Jwk.Symmetric { k } ->
862
913
let expected = Sign.hmac_sha256 ~key:k input in
863
914
if Eqaf.equal expected t.signature then Ok ()
···
875
926
| Algorithm.EdDSA, Jwk.Ed25519_priv { x; d = _ } ->
876
927
Sign.ed25519_verify ~pub:x ~signature:t.signature input
877
928
| Algorithm.ES256, Jwk.P256_pub { x; y } ->
878
-
let pub = x ^ y in (* Uncompressed point *)
929
+
let pub = x ^ y in
930
+
(* Uncompressed point *)
879
931
Sign.p256_verify ~pub ~signature:t.signature input
880
932
| Algorithm.ES256, Jwk.P256_priv { x; y; d = _ } ->
881
933
let pub = x ^ y in
···
899
951
| Algorithm.RS512, Jwk.Rsa_pub _ ->
900
952
Error (Key_type_mismatch "RSA verification not yet implemented")
901
953
| alg, _ ->
902
-
Error (Key_type_mismatch
903
-
(Printf.sprintf "Key type doesn't match algorithm %s" (Algorithm.to_string alg)))
954
+
Error
955
+
(Key_type_mismatch
956
+
(Printf.sprintf "Key type doesn't match algorithm %s"
957
+
(Algorithm.to_string alg)))
904
958
905
959
(* Claims validation *)
906
960
let validate ~now ?iss ?aud ?(leeway = Ptime.Span.zero) t =
···
911
965
match Claims.exp claims with
912
966
| None -> Ok ()
913
967
| 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
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
917
972
else Ok ()
918
973
in
919
974
(* Check nbf claim *)
···
921
976
match Claims.nbf claims with
922
977
| None -> Ok ()
923
978
| Some nbf_time ->
924
-
let nbf_with_leeway = Ptime.sub_span nbf_time leeway |> Option.value ~default:nbf_time in
979
+
let nbf_with_leeway =
980
+
Ptime.sub_span nbf_time leeway |> Option.value ~default:nbf_time
981
+
in
925
982
if Ptime.is_earlier now ~than:nbf_with_leeway then
926
983
Error Token_not_yet_valid
927
984
else Ok ()
···
930
987
let* () =
931
988
match iss with
932
989
| None -> Ok ()
933
-
| Some expected_iss ->
990
+
| Some expected_iss -> (
934
991
match Claims.iss claims with
935
992
| None -> Error Invalid_issuer
936
993
| Some actual_iss ->
937
994
if String.equal expected_iss actual_iss then Ok ()
938
-
else Error Invalid_issuer
995
+
else Error Invalid_issuer)
939
996
in
940
997
(* Check aud claim *)
941
998
let* () =
···
948
1005
in
949
1006
Ok ()
950
1007
951
-
let verify_and_validate ~key ~now ?allow_none ?allowed_algs ?iss ?aud ?leeway t =
1008
+
let verify_and_validate ~key ~now ?allow_none ?allowed_algs ?iss ?aud ?leeway t
1009
+
=
952
1010
let ( let* ) = Result.bind in
953
1011
let* () = verify ~key ?allow_none ?allowed_algs t in
954
1012
validate ~now ?iss ?aud ?leeway t
···
962
1020
let payload_b64 = base64url_encode claims_json in
963
1021
let signing_input = header_b64 ^ "." ^ payload_b64 in
964
1022
let* signature =
965
-
match header.Header.alg, key.Jwk.key_data with
1023
+
match (header.Header.alg, key.Jwk.key_data) with
966
1024
| Algorithm.None, _ -> Ok ""
967
1025
| Algorithm.HS256, Jwk.Symmetric { k } ->
968
1026
Ok (Sign.hmac_sha256 ~key:k signing_input)
···
979
1037
| Algorithm.ES512, Jwk.P521_priv { x = _; y = _; d } ->
980
1038
Sign.p521_sign ~priv:d signing_input
981
1039
| alg, _ ->
982
-
Error (Key_type_mismatch
983
-
(Printf.sprintf "Cannot sign with algorithm %s and given key"
984
-
(Algorithm.to_string alg)))
1040
+
Error
1041
+
(Key_type_mismatch
1042
+
(Printf.sprintf "Cannot sign with algorithm %s and given key"
1043
+
(Algorithm.to_string alg)))
985
1044
in
986
1045
let sig_b64 = base64url_encode signature in
987
1046
let raw = signing_input ^ "." ^ sig_b64 in
···
994
1053
match Claims.exp t.claims with
995
1054
| None -> false
996
1055
| Some exp_time ->
997
-
let exp_with_leeway = Ptime.add_span exp_time leeway |> Option.value ~default:exp_time in
1056
+
let exp_with_leeway =
1057
+
Ptime.add_span exp_time leeway |> Option.value ~default:exp_time
1058
+
in
998
1059
Ptime.is_later now ~than:exp_with_leeway
999
1060
1000
1061
let time_to_expiry ~now t =
···
1002
1063
| None -> None
1003
1064
| Some exp_time ->
1004
1065
let diff = Ptime.diff exp_time now in
1005
-
if Ptime.Span.compare diff Ptime.Span.zero <= 0 then None
1006
-
else Some diff
1066
+
if Ptime.Span.compare diff Ptime.Span.zero <= 0 then None else Some diff
1007
1067
1008
-
(** CBOR Web Token (CWT) support *)
1009
1068
module Cwt = Cwt
1069
+
(** CBOR Web Token (CWT) support *)
+177
-115
lib/jsonwt.mli
+177
-115
lib/jsonwt.mli
···
9
9
{{:https://datatracker.ietf.org/doc/html/rfc7519}RFC 7519}.
10
10
11
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
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
15
Code (MAC).
16
16
17
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)}} *)
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) *)
23
26
24
27
(** {1 Error Handling} *)
25
28
26
29
type error =
27
-
| Invalid_json of string
28
-
(** JSON parsing failed *)
29
-
| Invalid_base64url of string
30
-
(** Base64url decoding failed *)
30
+
| Invalid_json of string (** JSON parsing failed *)
31
+
| Invalid_base64url of string (** Base64url decoding failed *)
31
32
| Invalid_structure of string
32
33
(** 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 *)
34
+
| Invalid_header of string (** Header validation failed *)
35
+
| Invalid_claims of string (** Claims validation failed *)
37
36
| Invalid_uri of string
38
37
(** StringOrURI validation failed per
39
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-2}RFC 7519 Section 2} *)
38
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-2}RFC 7519
39
+
Section 2} *)
40
40
| Duplicate_claim of string
41
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 *)
42
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4}RFC 7519
43
+
Section 4} *)
44
+
| Unsupported_algorithm of string (** Unknown algorithm identifier *)
45
45
| Algorithm_not_allowed of string
46
46
(** Algorithm rejected by allowed_algs policy *)
47
-
| Signature_mismatch
48
-
(** Signature verification failed *)
47
+
| Signature_mismatch (** Signature verification failed *)
49
48
| Token_expired
50
49
(** exp claim validation failed per
51
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.4}RFC 7519 Section 4.1.4} *)
50
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.4}RFC
51
+
7519 Section 4.1.4} *)
52
52
| Token_not_yet_valid
53
53
(** nbf claim validation failed per
54
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.5}RFC 7519 Section 4.1.5} *)
54
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.5}RFC
55
+
7519 Section 4.1.5} *)
55
56
| Invalid_issuer
56
57
(** iss claim mismatch per
57
-
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.1}RFC 7519 Section 4.1.1} *)
58
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.1}RFC
59
+
7519 Section 4.1.1} *)
58
60
| Invalid_audience
59
61
(** 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 *)
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 *)
63
65
| Unsecured_not_allowed
64
66
(** 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 *)
67
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-6}RFC 7519
68
+
Section 6} *)
69
+
| Nesting_too_deep (** Nested JWT exceeds max_depth *)
68
70
69
71
val pp_error : Format.formatter -> error -> unit
70
72
(** Pretty-print an error. *)
···
74
76
75
77
(** {1 Algorithms}
76
78
77
-
Signature and MAC algorithms for JWT.
78
-
See {{:https://datatracker.ietf.org/doc/html/rfc7518#section-3}RFC 7518 Section 3}. *)
79
+
Signature and MAC algorithms for JWT. See
80
+
{{:https://datatracker.ietf.org/doc/html/rfc7518#section-3}RFC 7518 Section
81
+
3}. *)
79
82
80
83
module Algorithm : sig
81
84
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} *)
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} *)
86
93
| HS384 (** HMAC using SHA-384 *)
87
94
| 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} *)
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} *)
90
99
| RS384 (** RSASSA-PKCS1-v1_5 using SHA-384 *)
91
100
| 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} *)
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} *)
94
105
| ES384 (** ECDSA using P-384 and SHA-384 *)
95
106
| ES512 (** ECDSA using P-521 and SHA-512 *)
96
-
| EdDSA (** EdDSA using Ed25519 per
97
-
{{:https://datatracker.ietf.org/doc/html/rfc8037}RFC 8037} *)
107
+
| EdDSA
108
+
(** EdDSA using Ed25519 per
109
+
{{:https://datatracker.ietf.org/doc/html/rfc8037}RFC 8037} *)
98
110
99
111
val to_string : t -> string
100
112
(** Convert algorithm to JWA identifier string. *)
···
111
123
112
124
(** {1 JSON Web Key}
113
125
114
-
Key representation for JWT signature verification.
115
-
See {{:https://datatracker.ietf.org/doc/html/rfc7517}RFC 7517}. *)
126
+
Key representation for JWT signature verification. See
127
+
{{:https://datatracker.ietf.org/doc/html/rfc7517}RFC 7517}. *)
116
128
117
129
module Jwk : sig
118
-
119
-
(** Key type per {{:https://datatracker.ietf.org/doc/html/rfc7517#section-4.1}RFC 7517 Section 4.1}. *)
130
+
(** Key type per
131
+
{{:https://datatracker.ietf.org/doc/html/rfc7517#section-4.1}RFC 7517
132
+
Section 4.1}. *)
120
133
type kty =
121
134
| Oct (** Octet sequence (symmetric key) *)
122
135
| Rsa (** RSA key *)
123
-
| Ec (** Elliptic Curve key *)
136
+
| Ec (** Elliptic Curve key *)
124
137
| Okp (** Octet Key Pair (Ed25519, X25519) *)
125
138
126
-
(** Elliptic curve identifiers per {{:https://datatracker.ietf.org/doc/html/rfc7518#section-6.2.1.1}RFC 7518 Section 6.2.1.1}. *)
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}. *)
127
142
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} *)
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} *)
132
149
150
+
type t
133
151
(** A JSON Web Key. *)
134
-
type t
135
152
136
153
(** {2 Constructors} *)
137
154
138
155
val symmetric : string -> t
139
-
(** [symmetric k] creates a symmetric key from raw bytes.
140
-
Used for HMAC algorithms (HS256, HS384, HS512). *)
156
+
(** [symmetric k] creates a symmetric key from raw bytes. Used for HMAC
157
+
algorithms (HS256, HS384, HS512). *)
141
158
142
159
val ed25519_pub : string -> t
143
-
(** [ed25519_pub pub] creates an Ed25519 public key from 32-byte public key. *)
160
+
(** [ed25519_pub pub] creates an Ed25519 public key from 32-byte public key.
161
+
*)
144
162
145
163
val ed25519_priv : pub:string -> priv:string -> t
146
164
(** [ed25519_priv ~pub ~priv] creates an Ed25519 private key. *)
···
167
185
(** [rsa_pub ~n ~e] creates an RSA public key from modulus and exponent. *)
168
186
169
187
val rsa_priv :
170
-
n:string -> e:string -> d:string -> p:string -> q:string ->
171
-
dp:string -> dq:string -> qi:string -> t
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
172
197
(** [rsa_priv ~n ~e ~d ~p ~q ~dp ~dq ~qi] creates an RSA private key. *)
173
198
174
199
(** {2 Accessors} *)
···
199
224
200
225
(** {1 JOSE Header}
201
226
202
-
The JOSE (JSON Object Signing and Encryption) Header.
203
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-5}RFC 7519 Section 5}. *)
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}. *)
204
230
205
231
module Header : sig
206
232
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} *)
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} *)
210
238
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} *)
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} *)
213
243
}
214
244
215
245
val make : ?typ:string -> ?kid:string -> ?cty:string -> Algorithm.t -> t
···
228
258
229
259
(** {1 Claims}
230
260
231
-
JWT Claims Set.
232
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4}RFC 7519 Section 4}. *)
261
+
JWT Claims Set. See
262
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4}RFC 7519 Section
263
+
4}. *)
233
264
234
265
module Claims : sig
235
266
type t
236
267
237
268
(** {2 Registered Claim Names}
238
269
239
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1}RFC 7519 Section 4.1}. *)
270
+
See
271
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1}RFC 7519
272
+
Section 4.1}. *)
240
273
241
274
val iss : t -> string option
242
-
(** Issuer claim per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.1}Section 4.1.1}. *)
275
+
(** Issuer claim per
276
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.1}Section
277
+
4.1.1}. *)
243
278
244
279
val sub : t -> string option
245
-
(** Subject claim per {{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.2}Section 4.1.2}. *)
280
+
(** Subject claim per
281
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.2}Section
282
+
4.1.2}. *)
246
283
247
284
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. *)
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. *)
250
289
251
290
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}. *)
291
+
(** Expiration time claim per
292
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.4}Section
293
+
4.1.4}. *)
253
294
254
295
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}. *)
296
+
(** Not Before claim per
297
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.5}Section
298
+
4.1.5}. *)
256
299
257
300
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}. *)
301
+
(** Issued At claim per
302
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.6}Section
303
+
4.1.6}. *)
259
304
260
305
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}. *)
306
+
(** JWT ID claim per
307
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-4.1.7}Section
308
+
4.1.7}. *)
262
309
263
310
(** {2 Custom Claims}
264
311
265
312
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}. *)
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}. *)
268
315
269
316
val get : string -> t -> Jsont.json option
270
317
(** [get name claims] returns the value of custom claim [name]. *)
271
318
272
319
val get_string : string -> t -> string option
273
-
(** [get_string name claims] returns the string value of custom claim [name]. *)
320
+
(** [get_string name claims] returns the string value of custom claim [name].
321
+
*)
274
322
275
323
val get_int : string -> t -> int option
276
324
(** [get_int name claims] returns the integer value of custom claim [name]. *)
277
325
278
326
val get_bool : string -> t -> bool option
279
-
(** [get_bool name claims] returns the boolean value of custom claim [name]. *)
327
+
(** [get_bool name claims] returns the boolean value of custom claim [name].
328
+
*)
280
329
281
330
(** {2 Construction} *)
282
331
···
326
375
327
376
val of_json : ?strict:bool -> string -> (t, error) result
328
377
(** [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. *)
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. *)
332
382
333
383
val to_json : t -> string
334
384
(** Serialize claims to JSON string. *)
···
337
387
(** {1 JWT Token} *)
338
388
339
389
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 *)
390
+
header : Header.t; (** JOSE header *)
391
+
claims : Claims.t; (** Claims set *)
392
+
signature : string; (** Raw signature bytes *)
393
+
raw : string; (** Original compact serialization *)
344
394
}
345
395
(** A parsed JWT token. *)
346
396
347
397
(** {2 Parsing}
348
398
349
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519 Section 7.2}. *)
399
+
See
400
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519
401
+
Section 7.2}. *)
350
402
351
403
val parse : ?strict:bool -> string -> (t, error) result
352
404
(** [parse ?strict token_string] parses a JWT from its compact serialization.
353
405
354
-
This parses the token structure but does NOT verify the signature.
355
-
Use {!verify} to validate the signature after parsing.
406
+
This parses the token structure but does NOT verify the signature. Use
407
+
{!verify} to validate the signature after parsing.
356
408
357
409
@param strict If true (default), reject duplicate claim names. *)
358
410
···
362
414
363
415
(** {2 Nested JWTs}
364
416
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}. *)
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
+
*)
367
422
368
423
val parse_nested :
369
-
?strict:bool ->
370
-
?max_depth:int ->
371
-
string ->
372
-
(t list, error) result
424
+
?strict:bool -> ?max_depth:int -> string -> (t list, error) result
373
425
(** [parse_nested ?strict ?max_depth token] parses a potentially nested JWT.
374
426
Returns a list of JWTs from outermost to innermost.
375
427
@param max_depth Maximum nesting depth (default 5). *)
376
428
377
429
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. *)
430
+
(** [is_nested t] returns true if the JWT has [cty: "JWT"] header, indicating it
431
+
contains a nested JWT. *)
380
432
381
433
(** {2 Accessors} *)
382
434
···
394
446
395
447
(** {2 Verification}
396
448
397
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519 Section 7.2}. *)
449
+
See
450
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.2}RFC 7519
451
+
Section 7.2}. *)
398
452
399
453
val verify :
400
454
key:Jwk.t ->
···
405
459
(** [verify ~key ?allow_none ?allowed_algs t] verifies the JWT signature.
406
460
407
461
@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]. *)
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]. *)
413
470
414
471
val validate :
415
472
now:Ptime.t ->
···
435
492
?leeway:Ptime.Span.t ->
436
493
t ->
437
494
(unit, error) result
438
-
(** [verify_and_validate ~key ~now ...] verifies signature and validates claims. *)
495
+
(** [verify_and_validate ~key ~now ...] verifies signature and validates claims.
496
+
*)
439
497
440
498
(** {2 Creation}
441
499
442
-
See {{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.1}RFC 7519 Section 7.1}. *)
500
+
See
501
+
{{:https://datatracker.ietf.org/doc/html/rfc7519#section-7.1}RFC 7519
502
+
Section 7.1}. *)
443
503
444
-
val create : header:Header.t -> claims:Claims.t -> key:Jwk.t -> (t, error) result
504
+
val create :
505
+
header:Header.t -> claims:Claims.t -> key:Jwk.t -> (t, error) result
445
506
(** [create ~header ~claims ~key] creates and signs a new JWT.
446
507
447
-
The [key] must be appropriate for the algorithm specified in [header].
448
-
For [alg:none], pass any key (it will be ignored). *)
508
+
The [key] must be appropriate for the algorithm specified in [header]. For
509
+
[alg:none], pass any key (it will be ignored). *)
449
510
450
511
val encode : t -> string
451
512
(** [encode t] returns the compact serialization of the JWT. *)
···
453
514
(** {1 Utilities} *)
454
515
455
516
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. *)
517
+
(** [is_expired ~now ?leeway t] checks if the token has expired. Returns false
518
+
if no exp claim present. *)
458
519
459
520
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. *)
521
+
(** [time_to_expiry ~now t] returns time until expiration, or [None] if no
522
+
expiration claim or already expired. *)
462
523
463
524
(** {1 Base64url Utilities}
464
525
···
466
527
467
528
val base64url_encode : string -> string
468
529
(** Base64url encode without padding per
469
-
{{:https://datatracker.ietf.org/doc/html/rfc7515#appendix-C}RFC 7515 Appendix C}. *)
530
+
{{:https://datatracker.ietf.org/doc/html/rfc7515#appendix-C}RFC 7515
531
+
Appendix C}. *)
470
532
471
533
val base64url_decode : string -> (string, error) result
472
534
(** Base64url decode, handling missing padding. *)
+379
-296
test/test_cbor.ml
+379
-296
test/test_cbor.ml
···
1
1
(** CBOR Encoding Tests
2
2
3
-
Tests derived from RFC 8949 Appendix A (Examples of Encoded CBOR Data Items). *)
3
+
Tests derived from RFC 8949 Appendix A (Examples of Encoded CBOR Data
4
+
Items). *)
4
5
5
6
(* Helper to encode to hex string *)
6
7
let encode_to_hex f =
···
10
11
f enc;
11
12
Cbort.Rw.flush_encoder enc;
12
13
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))))
14
+
String.concat ""
15
+
(List.init (String.length bytes) (fun i ->
16
+
Printf.sprintf "%02x" (Char.code (String.get bytes i))))
15
17
16
18
(* Helper to convert hex string to bytes for comparison *)
17
19
let hex_to_bytes hex =
···
63
65
Alcotest.(check string) "1000000" "1a000f4240" hex
64
66
65
67
let test_uint_1000000000000 () =
66
-
let hex = encode_to_hex (fun enc -> Cbort.Rw.write_int64 enc 1000000000000L) in
68
+
let hex =
69
+
encode_to_hex (fun enc -> Cbort.Rw.write_int64 enc 1000000000000L)
70
+
in
67
71
Alcotest.(check string) "1000000000000" "1b000000e8d4a51000" hex
68
72
69
73
(* ============= Negative Integer Tests ============= *)
···
172
176
173
177
let test_text_utf8_emoji () =
174
178
(* 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
179
+
let hex =
180
+
encode_to_hex (fun enc -> Cbort.Rw.write_text enc "\xf0\x90\x85\x91")
181
+
in
176
182
Alcotest.(check string) "𐅑" "64f0908591" hex
177
183
178
184
(* ============= Byte String Tests ============= *)
179
185
180
186
let test_bytes_empty () =
181
-
let hex = encode_to_hex (fun enc ->
182
-
Cbort.Rw.write_bytes_header enc 0) in
187
+
let hex = encode_to_hex (fun enc -> Cbort.Rw.write_bytes_header enc 0) in
183
188
Alcotest.(check string) "empty bytes" "40" hex
184
189
185
190
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
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
189
196
Alcotest.(check string) "h'01020304'" "4401020304" hex
190
197
191
198
(* ============= Array Tests ============= *)
···
195
202
Alcotest.(check string) "[]" "80" hex
196
203
197
204
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
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
203
212
Alcotest.(check string) "[1, 2, 3]" "83010203" hex
204
213
205
214
let test_array_nested () =
206
215
(* [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
+
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
216
227
Alcotest.(check string) "[1, [2, 3], [4, 5]]" "8301820203820405" hex
217
228
218
229
let test_array_25_items () =
219
230
(* [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
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
225
238
(* 0x98 0x19 = array with 1-byte length (25) *)
226
-
Alcotest.(check string) "[1..25]" "98190102030405060708090a0b0c0d0e0f101112131415161718181819" hex
239
+
Alcotest.(check string)
240
+
"[1..25]" "98190102030405060708090a0b0c0d0e0f101112131415161718181819" hex
227
241
228
242
(* ============= Map Tests ============= *)
229
243
···
233
247
234
248
let test_map_int_keys () =
235
249
(* {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
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
242
258
Alcotest.(check string) "{1: 2, 3: 4}" "a201020304" hex
243
259
244
260
let test_map_string_keys () =
245
261
(* {"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
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
254
272
Alcotest.(check string) "{\"a\": 1, \"b\": [2, 3]}" "a26161016162820203" hex
255
273
256
274
let test_mixed_array_map () =
257
275
(* ["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
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
264
284
Alcotest.(check string) "[\"a\", {\"b\": \"c\"}]" "826161a161626163" hex
265
285
266
286
let test_map_5_pairs () =
267
287
(* {"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
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
276
304
277
305
(* ============= Tag Tests ============= *)
278
306
279
307
let test_tag_epoch_timestamp () =
280
308
(* 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
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
284
314
Alcotest.(check string) "1(1363896240)" "c11a514b67b0" hex
285
315
286
316
(* ============= Major Type Constants Test ============= *)
···
313
343
(* Round-trip tests using Cbort.encode_string and Cbort.decode_string *)
314
344
315
345
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
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
323
354
324
355
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
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
332
365
333
366
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]
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 ]
340
375
341
376
let test_codec_null_roundtrip () =
342
377
let encoded = Cbort.encode_string Cbort.null () in
···
345
380
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
346
381
347
382
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
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
357
393
358
394
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
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
366
406
367
407
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
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
375
416
376
417
let test_codec_array_roundtrip () =
377
-
let values = [[]; [1]; [1;2;3]; List.init 25 (fun i -> i)] in
418
+
let values = [ []; [ 1 ]; [ 1; 2; 3 ]; List.init 25 (fun i -> i) ] in
378
419
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
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
385
427
386
428
let test_codec_nested_array () =
387
429
let nested = Cbort.array (Cbort.array Cbort.int) in
388
-
let v = [[1;2]; [3;4;5]; []] in
430
+
let v = [ [ 1; 2 ]; [ 3; 4; 5 ]; [] ] in
389
431
let encoded = Cbort.encode_string nested v in
390
432
match Cbort.decode_string nested encoded with
391
433
| Ok decoded -> Alcotest.(check (list (list int))) "nested array" v decoded
···
393
435
394
436
let test_codec_string_map_roundtrip () =
395
437
let map = Cbort.string_map Cbort.int in
396
-
let v = [("a", 1); ("b", 2); ("c", 3)] in
438
+
let v = [ ("a", 1); ("b", 2); ("c", 3) ] in
397
439
let encoded = Cbort.encode_string map v in
398
440
match Cbort.decode_string map encoded with
399
441
| Ok decoded ->
400
442
(* Maps may reorder, so sort before comparing *)
401
443
let sort = List.sort compare in
402
-
Alcotest.(check (list (pair string int))) "string map" (sort v) (sort decoded)
444
+
Alcotest.(check (list (pair string int)))
445
+
"string map" (sort v) (sort decoded)
403
446
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
404
447
405
448
let test_codec_int_map_roundtrip () =
406
449
let map = Cbort.int_map Cbort.string in
407
-
let v = [(1, "one"); (2, "two"); (3, "three")] in
450
+
let v = [ (1, "one"); (2, "two"); (3, "three") ] in
408
451
let encoded = Cbort.encode_string map v in
409
452
match Cbort.decode_string map encoded with
410
453
| Ok decoded ->
411
454
let sort = List.sort compare in
412
-
Alcotest.(check (list (pair int string))) "int map" (sort v) (sort decoded)
455
+
Alcotest.(check (list (pair int string)))
456
+
"int map" (sort v) (sort decoded)
413
457
| Error e -> Alcotest.fail (Cbort.Error.to_string e)
414
458
415
459
let test_codec_tuple2 () =
···
426
470
let encoded = Cbort.encode_string codec v in
427
471
match Cbort.decode_string codec encoded with
428
472
| Ok decoded ->
429
-
let (a, b, c) = decoded in
473
+
let a, b, c = decoded in
430
474
Alcotest.(check int) "tuple3.0" 42 a;
431
475
Alcotest.(check string) "tuple3.1" "hello" b;
432
476
Alcotest.(check bool) "tuple3.2" true c
···
438
482
let v1 = Some 42 in
439
483
let encoded1 = Cbort.encode_string codec v1 in
440
484
(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));
485
+
| Ok decoded -> Alcotest.(check (option int)) "nullable some" v1 decoded
486
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e));
443
487
(* Test None *)
444
488
let v2 = None in
445
489
let encoded2 = Cbort.encode_string codec v2 in
···
452
496
type person = { name : string; age : int; email : string option }
453
497
454
498
let person_codec =
455
-
Cbort.Obj.finish @@
499
+
Cbort.Obj.finish
500
+
@@
456
501
let open Cbort.Obj in
457
502
let* name = mem "name" (fun p -> p.name) Cbort.string in
458
503
let* age = mem "age" (fun p -> p.age) Cbort.int in
···
484
529
(* CWT-style claims with integer keys per RFC 8392:
485
530
1=iss, 2=sub, 3=aud, 4=exp, 5=nbf, 6=iat, 7=cti *)
486
531
type cwt_claims = {
487
-
iss : string option; (* key 1 *)
488
-
sub : string option; (* key 2 *)
489
-
exp : int64 option; (* key 4 *)
532
+
iss : string option; (* key 1 *)
533
+
sub : string option; (* key 2 *)
534
+
exp : int64 option; (* key 4 *)
490
535
}
491
536
492
537
let cwt_claims_codec =
493
-
Cbort.Obj_int.finish @@
538
+
Cbort.Obj_int.finish
539
+
@@
494
540
let open Cbort.Obj_int in
495
541
let* iss = mem_opt 1 (fun c -> c.iss) Cbort.string in
496
542
let* sub = mem_opt 2 (fun c -> c.sub) Cbort.string in
···
498
544
return { iss; sub; exp }
499
545
500
546
let test_obj_int_codec () =
501
-
let v = { iss = Some "https://example.com"; sub = Some "user123"; exp = Some 1700000000L } in
547
+
let v =
548
+
{
549
+
iss = Some "https://example.com";
550
+
sub = Some "user123";
551
+
exp = Some 1700000000L;
552
+
}
553
+
in
502
554
let encoded = Cbort.encode_string cwt_claims_codec v in
503
555
match Cbort.decode_string cwt_claims_codec encoded with
504
556
| Ok decoded ->
···
525
577
let v = 1363896240L in
526
578
let encoded = Cbort.encode_string epoch_codec v in
527
579
(* 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
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
530
585
Alcotest.(check string) "epoch tag hex" "c11a514b67b0" hex;
531
586
match Cbort.decode_string epoch_codec encoded with
532
587
| Ok decoded -> Alcotest.(check int64) "epoch value" v decoded
···
539
594
(* Encode with tag *)
540
595
let encoded = Cbort.encode_string uri_codec v in
541
596
(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));
597
+
| Ok decoded -> Alcotest.(check string) "uri tagged" v decoded
598
+
| Error e -> Alcotest.fail (Cbort.Error.to_string e));
544
599
(* Decode without tag should also work *)
545
600
let plain = Cbort.encode_string Cbort.string v in
546
601
match Cbort.decode_string uri_codec plain with
···
551
606
552
607
let test_decode_rfc_integers () =
553
608
(* 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
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
576
635
577
636
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
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
592
657
593
658
let test_decode_rfc_arrays () =
594
659
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
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
605
669
606
670
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
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
617
680
618
681
let test_decode_rfc_null () =
619
682
let bytes = hex_to_bytes "f6" in
···
625
688
626
689
let test_decode_type_mismatch () =
627
690
(* Try to decode an integer as a string *)
628
-
let bytes = hex_to_bytes "01" in (* integer 1 *)
691
+
let bytes = hex_to_bytes "01" in
692
+
(* integer 1 *)
629
693
match Cbort.decode_string Cbort.string bytes with
630
694
| Ok _ -> Alcotest.fail "Expected type mismatch error"
631
695
| Error e ->
632
696
let msg = Cbort.Error.to_string e in
633
-
Alcotest.(check bool) "error contains type info" true (String.length msg > 0)
697
+
Alcotest.(check bool)
698
+
"error contains type info" true
699
+
(String.length msg > 0)
634
700
635
701
let test_decode_truncated () =
636
702
(* Truncated integer (header says 4 bytes follow but only 2 provided) *)
···
642
708
(* ============= Test Runner ============= *)
643
709
644
710
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
-
]
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
test/test_cwt.ml
+415
-280
test/test_cwt.ml
···
1
1
(** CWT Library Tests
2
2
3
-
Tests derived from RFC 8392 (CBOR Web Token) and
4
-
RFC 9052/9053 (COSE) specifications. *)
3
+
Tests derived from RFC 8392 (CBOR Web Token) and RFC 9052/9053 (COSE)
4
+
specifications. *)
5
5
6
6
module Cwt = Jsonwt.Cwt
7
7
···
18
18
19
19
(* RFC 8392 Appendix A.1: Example CWT Claims Set *)
20
20
let rfc_claims_hex =
21
-
"a70175636f61703a2f2f61732e6578616d706c652e636f6d02656572696b7703" ^
22
-
"7818636f61703a2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0" ^
23
-
"051a5610d9f0061a5610d9f007420b71"
21
+
"a70175636f61703a2f2f61732e6578616d706c652e636f6d02656572696b7703"
22
+
^ "7818636f61703a2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0"
23
+
^ "051a5610d9f0061a5610d9f007420b71"
24
24
25
25
(* RFC 8392 Appendix A.2.2: 256-Bit Symmetric Key *)
26
26
let rfc_256bit_key_hex =
27
-
"a4205820403697de87af64611c1d32a05dab0fe1fcb715a86ab435f1ec99192d" ^
28
-
"795693880104024c53796d6d6574726963323536030a"
27
+
"a4205820403697de87af64611c1d32a05dab0fe1fcb715a86ab435f1ec99192d"
28
+
^ "795693880104024c53796d6d6574726963323536030a"
29
29
30
30
(* Just the raw key bytes for HMAC *)
31
31
let rfc_256bit_key_bytes =
32
-
hex_to_bytes "403697de87af64611c1d32a05dab0fe1fcb715a86ab435f1ec99192d79569388"
32
+
hex_to_bytes
33
+
"403697de87af64611c1d32a05dab0fe1fcb715a86ab435f1ec99192d79569388"
33
34
34
35
(* 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"
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"
38
47
39
48
(* RFC 8392 Appendix A.3: Signed CWT *)
40
49
let rfc_signed_cwt_hex =
41
-
"d28443a10126a104524173796d6d657472696345434453413235365850a70175" ^
42
-
"636f61703a2f2f61732e6578616d706c652e636f6d02656572696b77037818636f" ^
43
-
"61703a2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0051a5610d" ^
44
-
"9f0061a5610d9f007420b7158405427c1ff28d23fbad1f29c4c7c6a555e601d6f" ^
45
-
"a29f9179bc3d7438bacaca5acd08c8d4d4f96131680c429a01f85951ecee743a5" ^
46
-
"2b9b63632c57209120e1c9e30"
50
+
"d28443a10126a104524173796d6d657472696345434453413235365850a70175"
51
+
^ "636f61703a2f2f61732e6578616d706c652e636f6d02656572696b77037818636f"
52
+
^ "61703a2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0051a5610d"
53
+
^ "9f0061a5610d9f007420b7158405427c1ff28d23fbad1f29c4c7c6a555e601d6f"
54
+
^ "a29f9179bc3d7438bacaca5acd08c8d4d4f96131680c429a01f85951ecee743a5"
55
+
^ "2b9b63632c57209120e1c9e30"
47
56
48
57
(* RFC 8392 Appendix A.4: MACed CWT with CWT tag *)
49
58
let rfc_maced_cwt_hex =
50
-
"d83dd18443a10104a1044c53796d6d65747269633235365850a70175636f6170" ^
51
-
"3a2f2f61732e6578616d706c652e636f6d02656572696b77037818636f61703a" ^
52
-
"2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0051a5610d9f006" ^
53
-
"1a5610d9f007420b7148093101ef6d789200"
59
+
"d83dd18443a10104a1044c53796d6d65747269633235365850a70175636f6170"
60
+
^ "3a2f2f61732e6578616d706c652e636f6d02656572696b77037818636f61703a"
61
+
^ "2f2f6c696768742e6578616d706c652e636f6d041a5612aeb0051a5610d9f006"
62
+
^ "1a5610d9f007420b7148093101ef6d789200"
54
63
55
64
(* ============= COSE Algorithm Tests ============= *)
56
65
57
66
let test_algorithm_roundtrip () =
58
67
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
+
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
68
78
69
79
let test_algorithm_cose_values () =
70
80
let open Cwt.Algorithm in
···
88
98
89
99
let test_cose_key_symmetric () =
90
100
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)
101
+
Alcotest.(check bool)
102
+
"kty is Symmetric" true
103
+
(Cwt.Cose_key.kty key = Cwt.Cose_key.Symmetric)
92
104
93
105
let test_cose_key_ed25519 () =
94
106
let pub = String.make 32 '\x00' in
95
107
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)
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)
98
114
99
115
let test_cose_key_p256 () =
100
116
let x = String.make 32 '\x00' in
101
117
let y = String.make 32 '\x00' in
102
118
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)
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)
105
125
106
126
let test_cose_key_with_kid () =
107
127
let key = Cwt.Cose_key.symmetric "secret" in
108
128
Alcotest.(check (option string)) "no kid" None (Cwt.Cose_key.kid key);
109
129
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')
130
+
Alcotest.(check (option string))
131
+
"has kid" (Some "my-key-id") (Cwt.Cose_key.kid key')
111
132
112
133
(* ============= Claims Tests ============= *)
113
134
···
118
139
|> Cwt.Claims.set_sub "test-subject"
119
140
|> Cwt.Claims.build
120
141
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)
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)
123
146
124
147
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 *)
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 *)
127
152
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
153
+
Cwt.Claims.empty |> Cwt.Claims.set_iat now |> Cwt.Claims.set_nbf now
154
+
|> Cwt.Claims.set_exp exp |> Cwt.Claims.build
133
155
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))
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))
137
165
138
166
let test_claims_audience_single () =
139
167
let claims =
···
141
169
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
142
170
|> Cwt.Claims.build
143
171
in
144
-
Alcotest.(check (list string)) "aud" [ "coap://light.example.com" ] (Cwt.Claims.aud claims)
172
+
Alcotest.(check (list string))
173
+
"aud"
174
+
[ "coap://light.example.com" ]
175
+
(Cwt.Claims.aud claims)
145
176
146
177
let test_claims_audience_multiple () =
147
178
let claims =
···
149
180
|> Cwt.Claims.set_aud [ "aud1"; "aud2"; "aud3" ]
150
181
|> Cwt.Claims.build
151
182
in
152
-
Alcotest.(check (list string)) "aud" [ "aud1"; "aud2"; "aud3" ] (Cwt.Claims.aud claims)
183
+
Alcotest.(check (list string))
184
+
"aud" [ "aud1"; "aud2"; "aud3" ] (Cwt.Claims.aud claims)
153
185
154
186
let test_claims_cti () =
155
187
let claims =
156
-
Cwt.Claims.empty
157
-
|> Cwt.Claims.set_cti "\x0b\x71"
158
-
|> Cwt.Claims.build
188
+
Cwt.Claims.empty |> Cwt.Claims.set_cti "\x0b\x71" |> Cwt.Claims.build
159
189
in
160
-
Alcotest.(check (option string)) "cti" (Some "\x0b\x71") (Cwt.Claims.cti claims)
190
+
Alcotest.(check (option string))
191
+
"cti" (Some "\x0b\x71") (Cwt.Claims.cti claims)
161
192
162
193
let test_claims_to_cbor () =
163
194
(* Build claims like RFC 8392 example *)
···
169
200
|> Cwt.Claims.set_iss "coap://as.example.com"
170
201
|> Cwt.Claims.set_sub "erikw"
171
202
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
172
-
|> Cwt.Claims.set_exp exp
173
-
|> Cwt.Claims.set_nbf nbf
203
+
|> Cwt.Claims.set_exp exp |> Cwt.Claims.set_nbf nbf
174
204
|> Cwt.Claims.set_iat iat
175
205
|> Cwt.Claims.set_cti "\x0b\x71"
176
206
|> Cwt.Claims.build
···
193
223
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
194
224
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
195
225
| 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));
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));
198
232
let encoded = Cwt.encode cwt in
199
233
Alcotest.(check bool) "non-empty encoding" true (String.length encoded > 0)
200
234
| Error e ->
201
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
235
+
Alcotest.fail
236
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
202
237
203
238
let test_create_hmac_256_64_cwt () =
204
239
let claims =
205
-
Cwt.Claims.empty
206
-
|> Cwt.Claims.set_iss "test-issuer"
207
-
|> Cwt.Claims.build
240
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test-issuer" |> Cwt.Claims.build
208
241
in
209
242
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
210
243
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256_64 ~claims ~key with
211
244
| Ok cwt ->
212
-
Alcotest.(check bool) "alg is HMAC_256_64" true
245
+
Alcotest.(check bool)
246
+
"alg is HMAC_256_64" true
213
247
(Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_256_64)
214
248
| Error e ->
215
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
249
+
Alcotest.fail
250
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
216
251
217
252
let test_create_es256_cwt () =
218
253
let claims =
219
-
Cwt.Claims.empty
220
-
|> Cwt.Claims.set_iss "test-issuer"
221
-
|> Cwt.Claims.build
254
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test-issuer" |> Cwt.Claims.build
222
255
in
223
256
let key = Cwt.Cose_key.p256_priv ~x:rfc_p256_x ~y:rfc_p256_y ~d:rfc_p256_d in
224
257
match Cwt.create ~algorithm:Cwt.Algorithm.ES256 ~claims ~key with
225
258
| Ok cwt ->
226
-
Alcotest.(check bool) "alg is ES256" true (Cwt.algorithm cwt = Some Cwt.Algorithm.ES256);
259
+
Alcotest.(check bool)
260
+
"alg is ES256" true
261
+
(Cwt.algorithm cwt = Some Cwt.Algorithm.ES256);
227
262
let encoded = Cwt.encode cwt in
228
263
(* Should start with COSE_Sign1 tag (0xd2 = 18) *)
229
-
Alcotest.(check int) "COSE_Sign1 tag" 0xd2 (Char.code (String.get encoded 0))
264
+
Alcotest.(check int)
265
+
"COSE_Sign1 tag" 0xd2
266
+
(Char.code (String.get encoded 0))
230
267
| Error e ->
231
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
268
+
Alcotest.fail
269
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
232
270
233
271
let test_create_key_mismatch () =
234
272
let claims =
235
-
Cwt.Claims.empty
236
-
|> Cwt.Claims.set_iss "test"
237
-
|> Cwt.Claims.build
273
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test" |> Cwt.Claims.build
238
274
in
239
275
(* Symmetric key with ES256 algorithm *)
240
276
let key = Cwt.Cose_key.symmetric "secret" in
241
277
match Cwt.create ~algorithm:Cwt.Algorithm.ES256 ~claims ~key with
242
278
| Error (Cwt.Key_type_mismatch _) -> ()
243
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Key_type_mismatch, got: %s" (Cwt.error_to_string e))
279
+
| Error e ->
280
+
Alcotest.fail
281
+
(Printf.sprintf "Expected Key_type_mismatch, got: %s"
282
+
(Cwt.error_to_string e))
244
283
| Ok _ -> Alcotest.fail "Expected key type mismatch error"
245
284
246
285
(* ============= Claims Validation Tests ============= *)
247
286
248
287
let test_validate_expired_token () =
249
288
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
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
256
292
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
257
293
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
258
-
| Ok cwt ->
259
-
begin match Cwt.validate ~now cwt with
294
+
| Ok cwt -> begin
295
+
match Cwt.validate ~now cwt with
260
296
| Error Cwt.Token_expired -> ()
261
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Token_expired, got: %s" (Cwt.error_to_string e))
297
+
| Error e ->
298
+
Alcotest.fail
299
+
(Printf.sprintf "Expected Token_expired, got: %s"
300
+
(Cwt.error_to_string e))
262
301
| Ok () -> Alcotest.fail "Expected Token_expired error"
263
-
end
302
+
end
264
303
| Error e -> Alcotest.fail (Cwt.error_to_string e)
265
304
266
305
let test_validate_not_yet_valid_token () =
267
306
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
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
274
310
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
275
311
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
276
-
| Ok cwt ->
277
-
begin match Cwt.validate ~now cwt with
312
+
| Ok cwt -> begin
313
+
match Cwt.validate ~now cwt with
278
314
| 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))
315
+
| Error e ->
316
+
Alcotest.fail
317
+
(Printf.sprintf "Expected Token_not_yet_valid, got: %s"
318
+
(Cwt.error_to_string e))
280
319
| Ok () -> Alcotest.fail "Expected Token_not_yet_valid error"
281
-
end
320
+
end
282
321
| Error e -> Alcotest.fail (Cwt.error_to_string e)
283
322
284
323
let test_validate_with_leeway () =
285
324
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
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
293
330
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
294
331
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
295
-
| Ok cwt ->
296
-
begin match Cwt.validate ~now ~leeway cwt with
332
+
| Ok cwt -> begin
333
+
match Cwt.validate ~now ~leeway cwt with
297
334
| Ok () -> ()
298
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass with leeway, got: %s" (Cwt.error_to_string e))
299
-
end
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
300
340
| Error e -> Alcotest.fail (Cwt.error_to_string e)
301
341
302
342
let test_validate_issuer_match () =
303
343
let now = Ptime.of_float_s 1400000000. |> Option.get in
304
344
let claims =
305
-
Cwt.Claims.empty
306
-
|> Cwt.Claims.set_iss "expected-issuer"
307
-
|> Cwt.Claims.build
345
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "expected-issuer" |> Cwt.Claims.build
308
346
in
309
347
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
310
348
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
349
+
| Ok cwt -> begin
350
+
match Cwt.validate ~now ~iss:"expected-issuer" cwt with
313
351
| Ok () -> ()
314
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass, got: %s" (Cwt.error_to_string e))
315
-
end
352
+
| Error e ->
353
+
Alcotest.fail
354
+
(Printf.sprintf "Expected validation to pass, got: %s"
355
+
(Cwt.error_to_string e))
356
+
end
316
357
| Error e -> Alcotest.fail (Cwt.error_to_string e)
317
358
318
359
let test_validate_issuer_mismatch () =
319
360
let now = Ptime.of_float_s 1400000000. |> Option.get in
320
361
let claims =
321
-
Cwt.Claims.empty
322
-
|> Cwt.Claims.set_iss "actual-issuer"
323
-
|> Cwt.Claims.build
362
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "actual-issuer" |> Cwt.Claims.build
324
363
in
325
364
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
326
365
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
366
+
| Ok cwt -> begin
367
+
match Cwt.validate ~now ~iss:"expected-issuer" cwt with
329
368
| Error Cwt.Invalid_issuer -> ()
330
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_issuer, got: %s" (Cwt.error_to_string e))
369
+
| Error e ->
370
+
Alcotest.fail
371
+
(Printf.sprintf "Expected Invalid_issuer, got: %s"
372
+
(Cwt.error_to_string e))
331
373
| Ok () -> Alcotest.fail "Expected Invalid_issuer error"
332
-
end
374
+
end
333
375
| Error e -> Alcotest.fail (Cwt.error_to_string e)
334
376
335
377
let test_validate_audience_match () =
···
341
383
in
342
384
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
343
385
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
386
+
| Ok cwt -> begin
387
+
match Cwt.validate ~now ~aud:"my-app" cwt with
346
388
| Ok () -> ()
347
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass, got: %s" (Cwt.error_to_string e))
348
-
end
389
+
| Error e ->
390
+
Alcotest.fail
391
+
(Printf.sprintf "Expected validation to pass, got: %s"
392
+
(Cwt.error_to_string e))
393
+
end
349
394
| Error e -> Alcotest.fail (Cwt.error_to_string e)
350
395
351
396
let test_validate_audience_mismatch () =
···
357
402
in
358
403
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
359
404
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
405
+
| Ok cwt -> begin
406
+
match Cwt.validate ~now ~aud:"my-app" cwt with
362
407
| Error Cwt.Invalid_audience -> ()
363
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_audience, got: %s" (Cwt.error_to_string e))
408
+
| Error e ->
409
+
Alcotest.fail
410
+
(Printf.sprintf "Expected Invalid_audience, got: %s"
411
+
(Cwt.error_to_string e))
364
412
| Ok () -> Alcotest.fail "Expected Invalid_audience error"
365
-
end
413
+
end
366
414
| Error e -> Alcotest.fail (Cwt.error_to_string e)
367
415
368
416
(* ============= Helper Function Tests ============= *)
369
417
370
418
let test_is_expired () =
371
419
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
420
+
let claims = Cwt.Claims.empty |> Cwt.Claims.set_exp exp |> Cwt.Claims.build in
377
421
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
378
422
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
379
423
| Ok cwt ->
380
424
let now_before = Ptime.of_float_s 1300819370. |> Option.get in
381
425
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)
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)
384
432
| Error e -> Alcotest.fail (Cwt.error_to_string e)
385
433
386
434
let test_time_to_expiry () =
387
435
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
436
+
let claims = Cwt.Claims.empty |> Cwt.Claims.set_exp exp |> Cwt.Claims.build in
393
437
let key = Cwt.Cose_key.symmetric rfc_256bit_key_bytes in
394
438
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_256 ~claims ~key with
395
439
| Ok cwt ->
···
398
442
| Some span ->
399
443
let seconds = Ptime.Span.to_float_s span |> int_of_float in
400
444
Alcotest.(check int) "time to expiry" 10 seconds
401
-
| None ->
402
-
Alcotest.fail "Expected Some time to expiry"
445
+
| None -> Alcotest.fail "Expected Some time to expiry"
403
446
end
404
447
| Error e -> Alcotest.fail (Cwt.error_to_string e)
405
448
406
449
(* ============= Error Type Tests ============= *)
407
450
408
451
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
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
421
467
422
468
(* ============= RFC 8392 Test Vector References ============= *)
423
469
···
432
478
|> Cwt.Claims.set_iss "coap://as.example.com"
433
479
|> Cwt.Claims.set_sub "erikw"
434
480
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
435
-
|> Cwt.Claims.set_exp exp
436
-
|> Cwt.Claims.set_nbf nbf
481
+
|> Cwt.Claims.set_exp exp |> Cwt.Claims.set_nbf nbf
437
482
|> Cwt.Claims.set_iat iat
438
483
|> Cwt.Claims.set_cti "\x0b\x71"
439
484
|> Cwt.Claims.build
440
485
in
441
-
Alcotest.(check (option string)) "iss" (Some "coap://as.example.com") (Cwt.Claims.iss claims);
486
+
Alcotest.(check (option string))
487
+
"iss" (Some "coap://as.example.com") (Cwt.Claims.iss claims);
442
488
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)
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)
445
495
446
496
(* ============= More Algorithm Coverage Tests ============= *)
447
497
448
498
let test_create_hmac_384_cwt () =
449
499
let claims =
450
-
Cwt.Claims.empty
451
-
|> Cwt.Claims.set_iss "test-issuer"
452
-
|> Cwt.Claims.build
500
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test-issuer" |> Cwt.Claims.build
453
501
in
454
502
(* Need 48-byte key for HMAC-384 *)
455
503
let key = Cwt.Cose_key.symmetric (String.make 48 'k') in
456
504
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_384 ~claims ~key with
457
505
| Ok cwt ->
458
-
Alcotest.(check bool) "alg is HMAC_384" true (Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_384);
506
+
Alcotest.(check bool)
507
+
"alg is HMAC_384" true
508
+
(Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_384);
459
509
let encoded = Cwt.encode cwt in
460
510
Alcotest.(check bool) "non-empty encoding" true (String.length encoded > 0)
461
511
| Error e ->
462
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
512
+
Alcotest.fail
513
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
463
514
464
515
let test_create_hmac_512_cwt () =
465
516
let claims =
466
-
Cwt.Claims.empty
467
-
|> Cwt.Claims.set_iss "test-issuer"
468
-
|> Cwt.Claims.build
517
+
Cwt.Claims.empty |> Cwt.Claims.set_iss "test-issuer" |> Cwt.Claims.build
469
518
in
470
519
(* Need 64-byte key for HMAC-512 *)
471
520
let key = Cwt.Cose_key.symmetric (String.make 64 'k') in
472
521
match Cwt.create ~algorithm:Cwt.Algorithm.HMAC_512 ~claims ~key with
473
522
| Ok cwt ->
474
-
Alcotest.(check bool) "alg is HMAC_512" true (Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_512);
523
+
Alcotest.(check bool)
524
+
"alg is HMAC_512" true
525
+
(Cwt.algorithm cwt = Some Cwt.Algorithm.HMAC_512);
475
526
let encoded = Cwt.encode cwt in
476
527
Alcotest.(check bool) "non-empty encoding" true (String.length encoded > 0)
477
528
| Error e ->
478
-
Alcotest.fail (Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
529
+
Alcotest.fail
530
+
(Printf.sprintf "CWT creation failed: %s" (Cwt.error_to_string e))
479
531
480
532
(* ============= COSE Key Serialization Tests ============= *)
481
533
···
509
561
let cbor = hex_to_bytes rfc_256bit_key_hex in
510
562
match Cwt.Cose_key.of_cbor cbor with
511
563
| Ok key ->
512
-
Alcotest.(check bool) "key type is symmetric" true
564
+
Alcotest.(check bool)
565
+
"key type is symmetric" true
513
566
(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))
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))
516
572
517
573
(* ============= CWT Encoding Tests ============= *)
518
574
···
532
588
let encoded = Cwt.encode cwt in
533
589
(* COSE_Mac0 has tag 17 (0xd1) *)
534
590
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))
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))
538
599
539
600
let test_cwt_es256_encoding () =
540
601
let claims =
541
-
Cwt.Claims.empty
542
-
|> Cwt.Claims.set_iss "es256-issuer"
543
-
|> Cwt.Claims.build
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
544
606
in
545
-
let priv_key = Cwt.Cose_key.p256_priv ~x:rfc_p256_x ~y:rfc_p256_y ~d:rfc_p256_d in
546
607
match Cwt.create ~algorithm:Cwt.Algorithm.ES256 ~claims ~key:priv_key with
547
608
| Ok cwt ->
548
609
let encoded = Cwt.encode cwt in
549
610
(* 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))
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))
553
619
554
620
let test_cwt_parse_roundtrip () =
555
621
(* Test that parse correctly round-trips a created CWT *)
···
565
631
let encoded = Cwt.encode cwt in
566
632
begin match Cwt.parse encoded with
567
633
| 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")
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")
572
642
(Option.map Cwt.Algorithm.to_string (Cwt.algorithm parsed))
573
-
| Error e -> Alcotest.fail (Printf.sprintf "Parse failed: %s" (Cwt.error_to_string e))
643
+
| Error e ->
644
+
Alcotest.fail
645
+
(Printf.sprintf "Parse failed: %s" (Cwt.error_to_string e))
574
646
end
575
-
| Error e -> Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
647
+
| Error e ->
648
+
Alcotest.fail (Printf.sprintf "Create failed: %s" (Cwt.error_to_string e))
576
649
577
650
(* ============= RFC 8392 Test Vector Tests ============= *)
578
651
···
586
659
|> Cwt.Claims.set_iss "coap://as.example.com"
587
660
|> Cwt.Claims.set_sub "erikw"
588
661
|> Cwt.Claims.set_aud [ "coap://light.example.com" ]
589
-
|> Cwt.Claims.set_exp exp
590
-
|> Cwt.Claims.set_nbf nbf
662
+
|> Cwt.Claims.set_exp exp |> Cwt.Claims.set_nbf nbf
591
663
|> Cwt.Claims.set_iat iat
592
664
|> Cwt.Claims.set_cti "\x0b\x71"
593
665
|> Cwt.Claims.build
···
595
667
let cbor = Cwt.Claims.to_cbor claims in
596
668
let expected = hex_to_bytes rfc_claims_hex in
597
669
(* Compare lengths first, then content *)
598
-
Alcotest.(check int) "length matches RFC" (String.length expected) (String.length cbor);
670
+
Alcotest.(check int)
671
+
"length matches RFC" (String.length expected) (String.length cbor);
599
672
Alcotest.(check string) "CBOR matches RFC 8392 Appendix A.1" expected cbor
600
673
601
674
let test_rfc_claims_cbor_decoding () =
···
604
677
let cbor = hex_to_bytes rfc_claims_hex in
605
678
match Cwt.Claims.of_cbor cbor with
606
679
| 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);
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);
611
690
(* Check timestamps *)
612
691
begin match Cwt.Claims.exp claims with
613
692
| Some exp ->
614
693
let exp_float = Ptime.to_float_s exp in
615
-
Alcotest.(check bool) "exp timestamp" true (abs_float (exp_float -. 1444064944.) < 1.0)
694
+
Alcotest.(check bool)
695
+
"exp timestamp" true
696
+
(abs_float (exp_float -. 1444064944.) < 1.0)
616
697
| None -> Alcotest.fail "Expected exp claim"
617
698
end;
618
699
begin match Cwt.Claims.nbf claims with
619
700
| Some nbf ->
620
701
let nbf_float = Ptime.to_float_s nbf in
621
-
Alcotest.(check bool) "nbf timestamp" true (abs_float (nbf_float -. 1443944944.) < 1.0)
702
+
Alcotest.(check bool)
703
+
"nbf timestamp" true
704
+
(abs_float (nbf_float -. 1443944944.) < 1.0)
622
705
| None -> Alcotest.fail "Expected nbf claim"
623
706
end;
624
707
begin match Cwt.Claims.iat claims with
625
708
| Some iat ->
626
709
let iat_float = Ptime.to_float_s iat in
627
-
Alcotest.(check bool) "iat timestamp" true (abs_float (iat_float -. 1443944944.) < 1.0)
710
+
Alcotest.(check bool)
711
+
"iat timestamp" true
712
+
(abs_float (iat_float -. 1443944944.) < 1.0)
628
713
| None -> Alcotest.fail "Expected iat claim"
629
714
end
630
715
| Error (Cwt.Invalid_cbor msg) ->
···
644
729
match Cwt.parse cwt_bytes with
645
730
| Ok cwt ->
646
731
(* 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)
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)
650
740
(Option.map (fun a -> a = Cwt.Algorithm.ES256) (Cwt.algorithm cwt))
651
741
| Error _ ->
652
742
(* Parse not yet implemented - that's expected *)
···
659
749
match Cwt.parse cwt_bytes with
660
750
| Ok cwt ->
661
751
(* 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))
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))
666
763
| Error _ ->
667
764
(* Parse not yet implemented - that's expected *)
668
765
()
···
673
770
let x = String.make 48 '\x01' in
674
771
let y = String.make 48 '\x02' in
675
772
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)
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)
678
779
679
780
let test_cose_key_p521 () =
680
781
let x = String.make 66 '\x01' in
681
782
let y = String.make 66 '\x02' in
682
783
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)
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)
685
790
686
791
(* ============= Algorithm Tests ============= *)
687
792
···
692
797
Alcotest.(check bool) "has ES384" true (List.mem Cwt.Algorithm.ES384 all);
693
798
Alcotest.(check bool) "has ES512" true (List.mem Cwt.Algorithm.ES512 all);
694
799
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)
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)
699
812
700
813
let test_algorithm_to_string () =
701
814
let open Cwt.Algorithm in
702
815
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)
816
+
Alcotest.(check bool)
817
+
"HMAC_256 name" true
818
+
(String.length (to_string HMAC_256) > 0)
704
819
705
820
(* ============= Test Runner ============= *)
706
821
707
822
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
-
]
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
test/test_jsonwt.ml
+235
-152
test/test_jsonwt.ml
···
1
1
(** JWT Library Tests
2
2
3
-
Comprehensive tests derived from RFC 7519 (JSON Web Token)
4
-
and RFC 7515 (JSON Web Signature) specifications. *)
3
+
Comprehensive tests derived from RFC 7519 (JSON Web Token) and RFC 7515
4
+
(JSON Web Signature) specifications. *)
5
5
6
6
(* RFC 7515 Appendix A.1 symmetric key for HS256 *)
7
7
let rfc_hs256_key_b64 =
···
9
9
10
10
(* RFC 7519 Section 3.1 example JWT (HS256) *)
11
11
let rfc_section3_1_token =
12
-
"eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9.\
13
-
eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ.\
14
-
dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"
12
+
"eyJ0eXAiOiJKV1QiLA0KICJhbGciOiJIUzI1NiJ9.eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ.dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk"
15
13
16
14
(* RFC 7519 Section 6.1 unsecured JWT *)
17
15
let rfc_section6_1_token =
18
-
"eyJhbGciOiJub25lIn0.\
19
-
eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ.\
20
-
"
16
+
"eyJhbGciOiJub25lIn0.eyJpc3MiOiJqb2UiLA0KICJleHAiOjEzMDA4MTkzODAsDQogImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlfQ."
21
17
22
18
(* Helper to decode base64url to bytes *)
23
19
let b64url_decode s =
24
20
(* Pad to multiple of 4 *)
25
-
let pad = match String.length s mod 4 with
21
+
let pad =
22
+
match String.length s mod 4 with
26
23
| 0 -> ""
27
24
| 2 -> "=="
28
25
| 3 -> "="
···
36
33
37
34
let test_algorithm_roundtrip () =
38
35
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
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
48
49
49
let test_algorithm_unknown () =
50
50
match Jsonwt.Algorithm.of_string "UNKNOWN" with
···
74
74
|> Jsonwt.Claims.set_string "custom" "value"
75
75
|> Jsonwt.Claims.build
76
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)
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)
80
84
81
85
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 *)
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 *)
84
90
let claims =
85
-
Jsonwt.Claims.empty
86
-
|> Jsonwt.Claims.set_iat now
87
-
|> Jsonwt.Claims.set_exp exp
88
-
|> Jsonwt.Claims.set_nbf now
91
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_iat now
92
+
|> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.set_nbf now
89
93
|> Jsonwt.Claims.build
90
94
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))
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))
94
104
95
105
let test_claims_audience_single () =
96
106
let claims =
···
106
116
|> Jsonwt.Claims.set_aud [ "app1"; "app2"; "app3" ]
107
117
|> Jsonwt.Claims.build
108
118
in
109
-
Alcotest.(check (list string)) "aud" [ "app1"; "app2"; "app3" ] (Jsonwt.Claims.aud claims)
119
+
Alcotest.(check (list string))
120
+
"aud" [ "app1"; "app2"; "app3" ] (Jsonwt.Claims.aud claims)
110
121
111
122
(* ============= Parse Tests ============= *)
112
123
···
125
136
let test_parse_invalid_base64 () =
126
137
match Jsonwt.parse "!!!.@@@.###" with
127
138
| Error (Jsonwt.Invalid_base64url _) -> ()
128
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_base64url, got %s" (Jsonwt.error_to_string e))
139
+
| Error e ->
140
+
Alcotest.fail
141
+
(Printf.sprintf "Expected Invalid_base64url, got %s"
142
+
(Jsonwt.error_to_string e))
129
143
| Ok _ -> Alcotest.fail "Expected parse to fail with invalid base64"
130
144
131
145
(* ============= RFC 7519 Test Vectors ============= *)
···
134
148
let test_rfc_unsecured_jwt_parse () =
135
149
match Jsonwt.parse rfc_section6_1_token with
136
150
| 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);
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);
139
157
Alcotest.(check string) "signature is empty" "" jwt.signature
140
158
| Error e ->
141
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
159
+
Alcotest.fail
160
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
142
161
143
162
let test_rfc_unsecured_jwt_verify_rejected_by_default () =
144
163
match Jsonwt.parse rfc_section6_1_token with
145
164
| Ok jwt ->
146
-
let key = Jsonwt.Jwk.symmetric "" in (* dummy key *)
165
+
let key = Jsonwt.Jwk.symmetric "" in
166
+
(* dummy key *)
147
167
begin match Jsonwt.verify ~key jwt with
148
168
| Error Jsonwt.Unsecured_not_allowed -> ()
149
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Unsecured_not_allowed, got: %s" (Jsonwt.error_to_string e))
169
+
| Error e ->
170
+
Alcotest.fail
171
+
(Printf.sprintf "Expected Unsecured_not_allowed, got: %s"
172
+
(Jsonwt.error_to_string e))
150
173
| Ok () -> Alcotest.fail "Unsecured JWT should be rejected by default"
151
174
end
152
175
| Error e ->
153
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
176
+
Alcotest.fail
177
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
154
178
155
179
let test_rfc_unsecured_jwt_verify_allowed_with_opt_in () =
156
180
match Jsonwt.parse rfc_section6_1_token with
157
181
| Ok jwt ->
158
-
let key = Jsonwt.Jwk.symmetric "" in (* dummy key *)
182
+
let key = Jsonwt.Jwk.symmetric "" in
183
+
(* dummy key *)
159
184
begin match Jsonwt.verify ~key ~allow_none:true jwt with
160
185
| Ok () -> ()
161
-
| Error e -> Alcotest.fail (Printf.sprintf "Verification failed: %s" (Jsonwt.error_to_string e))
186
+
| Error e ->
187
+
Alcotest.fail
188
+
(Printf.sprintf "Verification failed: %s" (Jsonwt.error_to_string e))
162
189
end
163
190
| Error e ->
164
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
191
+
Alcotest.fail
192
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
165
193
166
194
(* RFC 7519 Section 3.1: HS256 JWT *)
167
195
let test_rfc_hs256_jwt_parse () =
168
196
match Jsonwt.parse rfc_section3_1_token with
169
197
| Ok jwt ->
170
-
Alcotest.(check bool) "alg is HS256" true (jwt.header.alg = Jsonwt.Algorithm.HS256);
198
+
Alcotest.(check bool)
199
+
"alg is HS256" true
200
+
(jwt.header.alg = Jsonwt.Algorithm.HS256);
171
201
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)
202
+
Alcotest.(check (option string))
203
+
"iss is joe" (Some "joe")
204
+
(Jsonwt.Claims.iss jwt.claims)
173
205
| Error e ->
174
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
206
+
Alcotest.fail
207
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
175
208
176
209
let test_rfc_hs256_jwt_verify () =
177
210
match Jsonwt.parse rfc_section3_1_token with
···
180
213
let key = Jsonwt.Jwk.symmetric key_bytes in
181
214
begin match Jsonwt.verify ~key jwt with
182
215
| Ok () -> ()
183
-
| Error e -> Alcotest.fail (Printf.sprintf "Verification failed: %s" (Jsonwt.error_to_string e))
216
+
| Error e ->
217
+
Alcotest.fail
218
+
(Printf.sprintf "Verification failed: %s" (Jsonwt.error_to_string e))
184
219
end
185
220
| Error e ->
186
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
221
+
Alcotest.fail
222
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
187
223
188
224
let test_rfc_hs256_jwt_verify_wrong_key () =
189
225
match Jsonwt.parse rfc_section3_1_token with
190
226
| Ok jwt ->
191
-
let wrong_key = Jsonwt.Jwk.symmetric "wrong-key-material-that-is-long-enough" in
227
+
let wrong_key =
228
+
Jsonwt.Jwk.symmetric "wrong-key-material-that-is-long-enough"
229
+
in
192
230
begin match Jsonwt.verify ~key:wrong_key jwt with
193
231
| Error Jsonwt.Signature_mismatch -> ()
194
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Signature_mismatch, got: %s" (Jsonwt.error_to_string e))
232
+
| Error e ->
233
+
Alcotest.fail
234
+
(Printf.sprintf "Expected Signature_mismatch, got: %s"
235
+
(Jsonwt.error_to_string e))
195
236
| Ok () -> Alcotest.fail "Verification should fail with wrong key"
196
237
end
197
238
| Error e ->
198
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
239
+
Alcotest.fail
240
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
199
241
200
242
(* ============= Claims Validation Tests ============= *)
201
243
202
244
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 *)
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 *)
205
249
let claims =
206
-
Jsonwt.Claims.empty
207
-
|> Jsonwt.Claims.set_exp exp
208
-
|> Jsonwt.Claims.build
250
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
209
251
in
210
252
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
211
253
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
212
254
match Jsonwt.validate ~now jwt with
213
255
| Error Jsonwt.Token_expired -> ()
214
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Token_expired, got: %s" (Jsonwt.error_to_string e))
256
+
| Error e ->
257
+
Alcotest.fail
258
+
(Printf.sprintf "Expected Token_expired, got: %s"
259
+
(Jsonwt.error_to_string e))
215
260
| Ok () -> Alcotest.fail "Expected Token_expired error"
216
261
217
262
let test_validate_not_yet_valid_token () =
218
263
let nbf = Ptime.of_float_s 1500000000. |> Option.get in
219
-
let now = Ptime.of_float_s 1400000000. |> Option.get in (* Before nbf *)
264
+
let now = Ptime.of_float_s 1400000000. |> Option.get in
265
+
(* Before nbf *)
220
266
let claims =
221
-
Jsonwt.Claims.empty
222
-
|> Jsonwt.Claims.set_nbf nbf
223
-
|> Jsonwt.Claims.build
267
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_nbf nbf |> Jsonwt.Claims.build
224
268
in
225
269
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
226
270
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
227
271
match Jsonwt.validate ~now jwt with
228
272
| 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))
273
+
| Error e ->
274
+
Alcotest.fail
275
+
(Printf.sprintf "Expected Token_not_yet_valid, got: %s"
276
+
(Jsonwt.error_to_string e))
230
277
| Ok () -> Alcotest.fail "Expected Token_not_yet_valid error"
231
278
232
279
let test_validate_with_leeway () =
233
280
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 *)
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 *)
236
285
let claims =
237
-
Jsonwt.Claims.empty
238
-
|> Jsonwt.Claims.set_exp exp
239
-
|> Jsonwt.Claims.build
286
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
240
287
in
241
288
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
242
289
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
243
290
match Jsonwt.validate ~now ~leeway jwt with
244
291
| Ok () -> ()
245
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass with leeway, got: %s" (Jsonwt.error_to_string e))
292
+
| Error e ->
293
+
Alcotest.fail
294
+
(Printf.sprintf "Expected validation to pass with leeway, got: %s"
295
+
(Jsonwt.error_to_string e))
246
296
247
297
let test_validate_issuer_match () =
248
298
let now = Ptime.of_float_s 1400000000. |> Option.get in
···
255
305
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
256
306
match Jsonwt.validate ~now ~iss:"expected-issuer" jwt with
257
307
| Ok () -> ()
258
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass, got: %s" (Jsonwt.error_to_string e))
308
+
| Error e ->
309
+
Alcotest.fail
310
+
(Printf.sprintf "Expected validation to pass, got: %s"
311
+
(Jsonwt.error_to_string e))
259
312
260
313
let test_validate_issuer_mismatch () =
261
314
let now = Ptime.of_float_s 1400000000. |> Option.get in
···
268
321
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
269
322
match Jsonwt.validate ~now ~iss:"expected-issuer" jwt with
270
323
| Error Jsonwt.Invalid_issuer -> ()
271
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_issuer, got: %s" (Jsonwt.error_to_string e))
324
+
| Error e ->
325
+
Alcotest.fail
326
+
(Printf.sprintf "Expected Invalid_issuer, got: %s"
327
+
(Jsonwt.error_to_string e))
272
328
| Ok () -> Alcotest.fail "Expected Invalid_issuer error"
273
329
274
330
let test_validate_audience_match () =
···
282
338
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
283
339
match Jsonwt.validate ~now ~aud:"my-app" jwt with
284
340
| Ok () -> ()
285
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected validation to pass, got: %s" (Jsonwt.error_to_string e))
341
+
| Error e ->
342
+
Alcotest.fail
343
+
(Printf.sprintf "Expected validation to pass, got: %s"
344
+
(Jsonwt.error_to_string e))
286
345
287
346
let test_validate_audience_mismatch () =
288
347
let now = Ptime.of_float_s 1400000000. |> Option.get in
···
295
354
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
296
355
match Jsonwt.validate ~now ~aud:"my-app" jwt with
297
356
| Error Jsonwt.Invalid_audience -> ()
298
-
| Error e -> Alcotest.fail (Printf.sprintf "Expected Invalid_audience, got: %s" (Jsonwt.error_to_string e))
357
+
| Error e ->
358
+
Alcotest.fail
359
+
(Printf.sprintf "Expected Invalid_audience, got: %s"
360
+
(Jsonwt.error_to_string e))
299
361
| Ok () -> Alcotest.fail "Expected Invalid_audience error"
300
362
301
363
(* ============= Algorithm Restriction Tests ============= *)
···
309
371
let allowed_algs = [ Jsonwt.Algorithm.HS384; Jsonwt.Algorithm.HS512 ] in
310
372
begin match Jsonwt.verify ~key ~allowed_algs jwt with
311
373
| 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"
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"
314
380
end
315
381
| Error e ->
316
-
Alcotest.fail (Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
382
+
Alcotest.fail
383
+
(Printf.sprintf "Parse failed: %s" (Jsonwt.error_to_string e))
317
384
318
385
(* ============= Helper Function Tests ============= *)
319
386
320
387
let test_is_expired () =
321
388
let exp = Ptime.of_float_s 1300819380. |> Option.get in
322
389
let claims =
323
-
Jsonwt.Claims.empty
324
-
|> Jsonwt.Claims.set_exp exp
325
-
|> Jsonwt.Claims.build
390
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
326
391
in
327
392
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
328
393
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
329
394
let now_before = Ptime.of_float_s 1300819370. |> Option.get in
330
395
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)
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)
333
402
334
403
let test_time_to_expiry () =
335
404
let exp = Ptime.of_float_s 1300819380. |> Option.get in
336
405
let claims =
337
-
Jsonwt.Claims.empty
338
-
|> Jsonwt.Claims.set_exp exp
339
-
|> Jsonwt.Claims.build
406
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
340
407
in
341
408
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
342
409
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
···
345
412
| Some span ->
346
413
let seconds = Ptime.Span.to_float_s span |> int_of_float in
347
414
Alcotest.(check int) "time to expiry" 10 seconds
348
-
| None ->
349
-
Alcotest.fail "Expected Some time to expiry"
415
+
| None -> Alcotest.fail "Expected Some time to expiry"
350
416
351
417
let test_time_to_expiry_already_expired () =
352
418
let exp = Ptime.of_float_s 1300819380. |> Option.get in
353
419
let claims =
354
-
Jsonwt.Claims.empty
355
-
|> Jsonwt.Claims.set_exp exp
356
-
|> Jsonwt.Claims.build
420
+
Jsonwt.Claims.empty |> Jsonwt.Claims.set_exp exp |> Jsonwt.Claims.build
357
421
in
358
422
let header = Jsonwt.Header.make Jsonwt.Algorithm.None in
359
423
let jwt = { Jsonwt.header; claims; signature = ""; raw = "" } in
···
365
429
(* ============= Error Type Tests ============= *)
366
430
367
431
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
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
380
447
381
448
(* ============= JWK Tests ============= *)
382
449
···
388
455
(* ============= Test Runner ============= *)
389
456
390
457
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
-
]
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
+
]