OAuth 2.0 authorization and token exchange
Make email an option type; add GitHub verified email endpoint
userinfo.email is now string option instead of string. For GitHub,
parse_userinfo intentionally returns None — the /user endpoint only
has the public email which is unverified. Add parse_github_emails to
extract the primary verified email from /user/emails (requires
user:email scope).
ocaml-auth's fetch_userinfo now calls /user/emails for GitHub to
populate the verified email. The type change forces all callers to
handle the missing-email case explicitly.
3 new tests for parse_github_emails. Existing tests updated.
+110
-14
+53
-11
lib/oauth.ml
+53
-11
lib/oauth.ml
···
332
332
type userinfo = {
333
333
uid : string;
334
334
login : string;
335
-
email : string;
335
+
email : string option;
336
336
name : string;
337
337
avatar_url : string;
338
338
}
339
339
340
-
(* GitHub: {"id":123,"login":"octocat","email":"...","name":"...","avatar_url":"..."} *)
340
+
(* Convert empty or missing strings to None for optional fields. *)
341
+
let non_empty s = if s = "" then None else Some s
342
+
let opt_to_string = function Some s -> s | None -> ""
343
+
344
+
(* GitHub: {"id":123,"login":"octocat","email":"...","name":"...","avatar_url":"..."}
345
+
email is intentionally dropped — /user returns the public email which is
346
+
unverified. Use parse_github_emails with /user/emails for the verified one. *)
341
347
let github_userinfo_jsont =
342
348
Jsont.Object.map ~kind:"github_userinfo"
343
-
(fun id login email name avatar_url ->
344
-
{ uid = string_of_int id; login; email; name; avatar_url })
349
+
(fun id login _email name avatar_url ->
350
+
{ uid = string_of_int id; login; email = None; name; avatar_url })
345
351
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun _ -> 0)
346
352
|> Jsont.Object.mem "login" Jsont.string ~dec_absent:"" ~enc:(fun u ->
347
353
u.login)
348
354
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:"" ~enc:(fun u ->
349
-
u.email)
355
+
opt_to_string u.email)
350
356
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:(fun u -> u.name)
351
357
|> Jsont.Object.mem "avatar_url" Jsont.string ~dec_absent:"" ~enc:(fun u ->
352
358
u.avatar_url)
···
355
361
(* Google OIDC: {"sub":"118...","email":"...","name":"...","picture":"..."} *)
356
362
let google_userinfo_jsont =
357
363
Jsont.Object.map ~kind:"google_userinfo" (fun sub email name picture ->
358
-
{ uid = sub; login = ""; email; name; avatar_url = picture })
364
+
{
365
+
uid = sub;
366
+
login = "";
367
+
email = non_empty email;
368
+
name;
369
+
avatar_url = picture;
370
+
})
359
371
|> Jsont.Object.mem "sub" Jsont.string ~enc:(fun u -> u.uid)
360
372
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:"" ~enc:(fun u ->
361
-
u.email)
373
+
opt_to_string u.email)
362
374
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:(fun u -> u.name)
363
375
|> Jsont.Object.mem "picture" Jsont.string ~dec_absent:"" ~enc:(fun u ->
364
376
u.avatar_url)
···
368
380
let gitlab_userinfo_jsont =
369
381
Jsont.Object.map ~kind:"gitlab_userinfo"
370
382
(fun id username email name avatar_url ->
371
-
{ uid = string_of_int id; login = username; email; name; avatar_url })
383
+
{
384
+
uid = string_of_int id;
385
+
login = username;
386
+
email = non_empty email;
387
+
name;
388
+
avatar_url;
389
+
})
372
390
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun _ -> 0)
373
391
|> Jsont.Object.mem "username" Jsont.string ~dec_absent:"" ~enc:(fun u ->
374
392
u.login)
375
393
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:"" ~enc:(fun u ->
376
-
u.email)
394
+
opt_to_string u.email)
377
395
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:(fun u -> u.name)
378
396
|> Jsont.Object.mem "avatar_url" Jsont.string ~dec_absent:"" ~enc:(fun u ->
379
397
u.avatar_url)
···
382
400
(* Custom: uid extracted from the configured uid_field *)
383
401
let custom_userinfo_jsont ~uid_field =
384
402
Jsont.Object.map ~kind:"custom_userinfo" (fun uid email name ->
385
-
{ uid; login = ""; email; name; avatar_url = "" })
403
+
{ uid; login = ""; email = non_empty email; name; avatar_url = "" })
386
404
|> Jsont.Object.mem uid_field Jsont.string ~enc:(fun u -> u.uid)
387
405
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:"" ~enc:(fun u ->
388
-
u.email)
406
+
opt_to_string u.email)
389
407
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:(fun u -> u.name)
390
408
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
391
409
···
406
424
| Error e -> err_userinfo_parse e
407
425
| Ok u when u.uid = "" -> err_userinfo_empty_uid provider
408
426
| Ok u -> Ok u
427
+
428
+
(* ── GitHub Verified Emails ─────────────────────────────────────── *)
429
+
430
+
let github_emails_url = "https://api.github.com/user/emails"
431
+
432
+
type github_email = { email : string; primary : bool; verified : bool }
433
+
434
+
let github_email_jsont =
435
+
Jsont.Object.map ~kind:"github_email" (fun email primary verified ->
436
+
{ email; primary; verified })
437
+
|> Jsont.Object.mem "email" Jsont.string ~enc:(fun e -> e.email)
438
+
|> Jsont.Object.mem "primary" Jsont.bool ~enc:(fun e -> e.primary)
439
+
|> Jsont.Object.mem "verified" Jsont.bool ~enc:(fun e -> e.verified)
440
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
441
+
442
+
let github_emails_jsont = Jsont.list github_email_jsont
443
+
444
+
let parse_github_emails body =
445
+
match decode github_emails_jsont body with
446
+
| Error e -> Error ("github emails parse error: " ^ e)
447
+
| Ok emails -> (
448
+
match List.find_opt (fun e -> e.primary && e.verified) emails with
449
+
| Some e -> Ok e.email
450
+
| None -> Error "no primary verified email found in GitHub response")
+27
-3
lib/oauth.mli
+27
-3
lib/oauth.mli
···
271
271
272
272
type userinfo = {
273
273
uid : string; (** Provider-specific unique identifier. *)
274
-
login : string; (** Username or login handle. *)
275
-
email : string; (** Email address (may be empty). *)
274
+
login : string; (** Username or login handle (may be empty). *)
275
+
email : string option;
276
+
(** Email address, or [None] if the provider did not return one.
277
+
278
+
{b Not verified.} This value comes directly from the provider's
279
+
userinfo endpoint and has not been independently verified. For GitHub
280
+
in particular, [/user] returns the user's {i public} email which may
281
+
be [None]; the verified primary email requires a separate
282
+
[GET /user/emails] call with the [user:email] scope. Do not use this
283
+
field for authentication decisions without independent verification.
284
+
*)
276
285
name : string; (** Display name (may be empty). *)
277
286
avatar_url : string; (** Avatar URL (may be empty). *)
278
287
}
279
288
(** Parsed userinfo from a provider's user profile endpoint.
280
289
281
-
The [uid] is guaranteed non-empty when parsing succeeds. *)
290
+
The [uid] is guaranteed non-empty when parsing succeeds. All other fields
291
+
are best-effort: they reflect whatever the provider returned and are not
292
+
independently verified. *)
282
293
283
294
val parse_userinfo : provider -> string -> (userinfo, string) result
284
295
(** [parse_userinfo provider body] parses a JSON userinfo response using the
···
286
297
287
298
Returns [Error msg] if the JSON is invalid or the unique identifier field is
288
299
missing or empty. *)
300
+
301
+
val github_emails_url : string
302
+
(** The GitHub API endpoint for the authenticated user's email addresses.
303
+
Requires the [user:email] scope. *)
304
+
305
+
val parse_github_emails : string -> (string, string) result
306
+
(** [parse_github_emails body] parses the JSON response from
307
+
{!github_emails_url} and returns the user's primary verified email address.
308
+
309
+
Returns [Error msg] if no email is both [primary = true] and
310
+
[verified = true]. This is the only reliable way to obtain a user's email
311
+
from GitHub — the [/user] endpoint returns the {i public} email which may be
312
+
absent or unverified. *)
+30
test/test_github_oauth.ml
+30
test/test_github_oauth.ml
···
157
157
| Error e ->
158
158
Alcotest.(check bool) "is Invalid_json" true (e = Oauth.Invalid_json)
159
159
160
+
(* ── GitHub verified emails ──────────────────────────────────────── *)
161
+
162
+
let test_parse_github_emails_verified_primary () =
163
+
let body =
164
+
{|[{"email":"noreply@github.com","primary":false,"verified":true},{"email":"real@example.com","primary":true,"verified":true},{"email":"old@example.com","primary":false,"verified":false}]|}
165
+
in
166
+
match Oauth.parse_github_emails body with
167
+
| Ok email ->
168
+
Alcotest.(check string) "primary verified" "real@example.com" email
169
+
| Error e -> Alcotest.failf "unexpected error: %s" e
170
+
171
+
let test_parse_github_emails_no_verified_primary () =
172
+
let body =
173
+
{|[{"email":"unverified@example.com","primary":true,"verified":false}]|}
174
+
in
175
+
match Oauth.parse_github_emails body with
176
+
| Error _ -> ()
177
+
| Ok _ -> Alcotest.fail "expected error when no verified primary email"
178
+
179
+
let test_parse_github_emails_empty () =
180
+
match Oauth.parse_github_emails "[]" with
181
+
| Error _ -> ()
182
+
| Ok _ -> Alcotest.fail "expected error on empty list"
183
+
160
184
let test_refresh_request_body () =
161
185
let body =
162
186
Oauth.refresh_form_body ~client_id:"test_client"
···
269
293
Alcotest.test_case "validate_state empty" `Quick test_validate_state_empty;
270
294
Alcotest.test_case "validate_state length mismatch" `Quick
271
295
test_validate_state_length_mismatch;
296
+
Alcotest.test_case "github emails verified primary" `Quick
297
+
test_parse_github_emails_verified_primary;
298
+
Alcotest.test_case "github emails no verified primary" `Quick
299
+
test_parse_github_emails_no_verified_primary;
300
+
Alcotest.test_case "github emails empty" `Quick
301
+
test_parse_github_emails_empty;
272
302
Alcotest.test_case "generate_state length and format" `Quick
273
303
test_generate_state;
274
304
Alcotest.test_case "generate_state unique" `Quick