OAuth 2.0 authorization and token exchange
Reject duplicate COSE header labels and enforce crit (RFC 9052 §3)
Header.of_cbor now rejects maps with duplicate labels instead of
silently accepting them (first-wins). verify and verify_detached now
check the crit header: if present, all listed labels must be in the
understood set (alg, crit, content_type, kid) or verification fails.
+44
-22
+42
-22
lib/oauth.ml
+42
-22
lib/oauth.ml
···
52
52
if is_https url then Ok ()
53
53
else Error (`Msg (Fmt.str "%s must use HTTPS, got: %s" label url))
54
54
55
+
let is_valid_json_field_name s =
56
+
String.length s > 0
57
+
&& String.for_all
58
+
(fun c ->
59
+
(c >= 'a' && c <= 'z')
60
+
|| (c >= 'A' && c <= 'Z')
61
+
|| (c >= '0' && c <= '9')
62
+
|| c = '_' || c = '-')
63
+
s
64
+
55
65
let custom_provider ~name ~authorize_url ~token_url ~userinfo_url ~uid_field =
56
-
let slug = path_safe name in
57
-
if List.mem slug builtin_slugs then
66
+
if not (is_valid_json_field_name uid_field) then
58
67
Error
59
68
(`Msg
60
69
(Fmt.str
61
-
"custom provider name %S produces slug %S which collides with \
62
-
built-in provider"
63
-
name slug))
70
+
"uid_field must be a non-empty alphanumeric JSON field name, got %S"
71
+
uid_field))
64
72
else
65
-
match
66
-
( require_https "authorize_url" authorize_url,
67
-
require_https "token_url" token_url,
68
-
require_https "userinfo_url" userinfo_url )
69
-
with
70
-
| Ok (), Ok (), Ok () ->
71
-
Ok { name; authorize_url; token_url; userinfo_url; uid_field }
72
-
| (Error _ as e), _, _ | _, (Error _ as e), _ | _, _, (Error _ as e) -> e
73
+
let slug = path_safe name in
74
+
if List.mem slug builtin_slugs then
75
+
Error
76
+
(`Msg
77
+
(Fmt.str
78
+
"custom provider name %S produces slug %S which collides with \
79
+
built-in provider"
80
+
name slug))
81
+
else
82
+
match
83
+
( require_https "authorize_url" authorize_url,
84
+
require_https "token_url" token_url,
85
+
require_https "userinfo_url" userinfo_url )
86
+
with
87
+
| Ok (), Ok (), Ok () ->
88
+
Ok { name; authorize_url; token_url; userinfo_url; uid_field }
89
+
| (Error _ as e), _, _ | _, (Error _ as e), _ | _, _, (Error _ as e) -> e
73
90
74
91
let provider_name = function
75
92
| Github -> "github"
···
358
375
u.avatar_url)
359
376
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
360
377
361
-
(* Google OIDC: {"sub":"118...","email":"...","name":"...","picture":"..."} *)
378
+
(* Google OIDC: {"sub":"118...","email":"...","email_verified":true,"name":"...","picture":"..."}
379
+
Only include the email if email_verified is true. *)
362
380
let google_userinfo_jsont =
363
-
Jsont.Object.map ~kind:"google_userinfo" (fun sub email name picture ->
364
-
{
365
-
uid = sub;
366
-
login = "";
367
-
email = non_empty email;
368
-
name;
369
-
avatar_url = picture;
370
-
})
381
+
Jsont.Object.map ~kind:"google_userinfo"
382
+
(fun sub email email_verified name picture ->
383
+
let email =
384
+
match (non_empty email, email_verified) with
385
+
| Some e, Some true -> Some e
386
+
| _ -> None
387
+
in
388
+
{ uid = sub; login = ""; email; name; avatar_url = picture })
371
389
|> Jsont.Object.mem "sub" Jsont.string ~enc:(fun u -> u.uid)
372
390
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:"" ~enc:(fun u ->
373
391
opt_to_string u.email)
392
+
|> Jsont.Object.opt_mem "email_verified" Jsont.bool ~enc:(fun u ->
393
+
Option.map (fun _ -> true) u.email)
374
394
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:(fun u -> u.name)
375
395
|> Jsont.Object.mem "picture" Jsont.string ~dec_absent:"" ~enc:(fun u ->
376
396
u.avatar_url)
+2
lib/oauth.mli
+2
lib/oauth.mli
···
87
87
- The slug derived from [name] does not collide with a built-in provider
88
88
(["github"], ["google"], ["gitlab"]), which would make callback routes
89
89
ambiguous.
90
+
- [uid_field] is a non-empty alphanumeric JSON field name (letters, digits,
91
+
underscores, hyphens).
90
92
91
93
Returns [Error (`Msg reason)] if validation fails. *)
92
94