OAuth 2.0 authorization and token exchange
oauth: let open Json.Codec in cleanup
42 Json.Codec. prefixes removed. The userinfo record has a `name`
field that clashes with Json.Codec.mem_map.name, so:
- Hoisted accessors `uid`, `login`, `email_verified`, `name`,
`avatar_url` after the userinfo type. `name` carries `(u : userinfo)`
annotation; the others are unique field names so no annotation
needed.
- Each `*_userinfo_jsont` constructor return-types as `: userinfo`
so the inline record literal disambiguates from `mem_map`.
- One stray `decode Value.t` (after the global Json.Codec strip)
restored to `Json.Codec.Value.t` -- it's outside any open scope.
+59
-56
+59
-56
lib/oauth.ml
+59
-56
lib/oauth.ml
···
302
302
}
303
303
304
304
let raw_token_response_jsont =
305
-
Json.Codec.Object.map ~kind:"token_response"
305
+
let open Json.Codec in
306
+
Object.map ~kind:"token_response"
306
307
(fun
307
308
access_token
308
309
token_type
···
317
318
refresh_token;
318
319
refresh_token_expires_in;
319
320
})
320
-
|> Json.Codec.Object.mem "access_token" Json.Codec.string ~enc:(fun t ->
321
+
|> Object.mem "access_token" string ~enc:(fun t ->
321
322
t.access_token)
322
-
|> Json.Codec.Object.opt_mem "token_type" Json.Codec.string ~enc:(fun t ->
323
+
|> Object.opt_mem "token_type" string ~enc:(fun t ->
323
324
t.token_type)
324
-
|> Json.Codec.Object.opt_mem "expires_in" Json.Codec.int ~enc:(fun t ->
325
+
|> Object.opt_mem "expires_in" int ~enc:(fun t ->
325
326
t.expires_in)
326
-
|> Json.Codec.Object.opt_mem "refresh_token" Json.Codec.string ~enc:(fun t ->
327
+
|> Object.opt_mem "refresh_token" string ~enc:(fun t ->
327
328
t.refresh_token)
328
-
|> Json.Codec.Object.opt_mem "refresh_token_expires_in" Json.Codec.int
329
+
|> Object.opt_mem "refresh_token_expires_in" int
329
330
~enc:(fun t -> t.refresh_token_expires_in)
330
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
331
+
|> Object.skip_unknown |> Object.finish
331
332
332
333
type parse_token_error =
333
334
| Invalid_json
···
562
563
avatar_url : string;
563
564
}
564
565
566
+
let uid u = u.uid
567
+
let login u = u.login
568
+
let email_verified u = u.email_verified
569
+
let name (u : userinfo) = u.name
570
+
let avatar_url u = u.avatar_url
571
+
565
572
(* Convert empty or missing strings to None for optional fields. *)
566
573
let non_empty s = if s = "" then None else Some s
567
574
let opt_to_string = function Some s -> s | None -> ""
···
570
577
email is intentionally dropped -- /user returns the public email which is
571
578
unverified. Use parse_github_emails with /user/emails for the verified one. *)
572
579
let github_userinfo_jsont =
573
-
Json.Codec.Object.map ~kind:"github_userinfo"
574
-
(fun id login _email name avatar_url ->
580
+
let open Json.Codec in
581
+
Object.map ~kind:"github_userinfo"
582
+
(fun id login _email name avatar_url : userinfo ->
575
583
{
576
584
uid = string_of_int id;
577
585
login;
···
580
588
name;
581
589
avatar_url;
582
590
})
583
-
|> Json.Codec.Object.mem "id" Json.Codec.int ~enc:(fun _ -> 0)
584
-
|> Json.Codec.Object.mem "login" Json.Codec.string ~dec_absent:""
585
-
~enc:(fun u -> u.login)
586
-
|> Json.Codec.Object.mem "email" Json.Codec.string ~dec_absent:""
591
+
|> Object.mem "id" int ~enc:(fun _ -> 0)
592
+
|> Object.mem "login" string ~dec_absent:"" ~enc:login
593
+
|> Object.mem "email" string ~dec_absent:""
587
594
~enc:(fun u -> opt_to_string u.email)
588
-
|> Json.Codec.Object.mem "name" Json.Codec.string ~dec_absent:""
589
-
~enc:(fun u -> u.name)
590
-
|> Json.Codec.Object.mem "avatar_url" Json.Codec.string ~dec_absent:""
591
-
~enc:(fun u -> u.avatar_url)
592
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
595
+
|> Object.mem "name" string ~dec_absent:"" ~enc:name
596
+
|> Object.mem "avatar_url" string ~dec_absent:"" ~enc:avatar_url
597
+
|> Object.skip_unknown |> Object.finish
593
598
594
599
(* Google OIDC: {"sub":"118...","email":"...","email_verified":true,"name":"...","picture":"..."}
595
600
Only populate email when email_verified is true. Track the verified flag. *)
596
601
let google_userinfo_jsont =
597
-
Json.Codec.Object.map ~kind:"google_userinfo"
598
-
(fun sub email email_verified name picture ->
602
+
let open Json.Codec in
603
+
Object.map ~kind:"google_userinfo"
604
+
(fun sub email email_verified name picture : userinfo ->
599
605
let verified = email_verified = Some true in
600
606
let email = if verified then non_empty email else None in
601
607
{
···
606
612
name;
607
613
avatar_url = picture;
608
614
})
609
-
|> Json.Codec.Object.mem "sub" Json.Codec.string ~enc:(fun u -> u.uid)
610
-
|> Json.Codec.Object.mem "email" Json.Codec.string ~dec_absent:""
615
+
|> Object.mem "sub" string ~enc:uid
616
+
|> Object.mem "email" string ~dec_absent:""
611
617
~enc:(fun u -> opt_to_string u.email)
612
-
|> Json.Codec.Object.opt_mem "email_verified" Json.Codec.bool ~enc:(fun u ->
613
-
Some u.email_verified)
614
-
|> Json.Codec.Object.mem "name" Json.Codec.string ~dec_absent:""
615
-
~enc:(fun u -> u.name)
616
-
|> Json.Codec.Object.mem "picture" Json.Codec.string ~dec_absent:""
617
-
~enc:(fun u -> u.avatar_url)
618
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
618
+
|> Object.opt_mem "email_verified" bool ~enc:(fun u ->
619
+
Some (email_verified u))
620
+
|> Object.mem "name" string ~dec_absent:"" ~enc:name
621
+
|> Object.mem "picture" string ~dec_absent:"" ~enc:avatar_url
622
+
|> Object.skip_unknown |> Object.finish
619
623
620
624
(* GitLab: {"id":123,"username":"john","email":"...","confirmed_at":"2024-...",
621
625
"name":"...","avatar_url":"..."}
622
626
confirmed_at is non-null when the user has verified their email. *)
623
627
let gitlab_userinfo_jsont =
624
-
Json.Codec.Object.map ~kind:"gitlab_userinfo"
625
-
(fun id username email confirmed_at name avatar_url ->
628
+
let open Json.Codec in
629
+
Object.map ~kind:"gitlab_userinfo"
630
+
(fun id username email confirmed_at name avatar_url : userinfo ->
626
631
let email_verified = Option.is_some confirmed_at in
627
632
{
628
633
uid = string_of_int id;
···
632
637
name;
633
638
avatar_url;
634
639
})
635
-
|> Json.Codec.Object.mem "id" Json.Codec.int ~enc:(fun _ -> 0)
636
-
|> Json.Codec.Object.mem "username" Json.Codec.string ~dec_absent:""
637
-
~enc:(fun u -> u.login)
638
-
|> Json.Codec.Object.mem "email" Json.Codec.string ~dec_absent:""
640
+
|> Object.mem "id" int ~enc:(fun _ -> 0)
641
+
|> Object.mem "username" string ~dec_absent:"" ~enc:login
642
+
|> Object.mem "email" string ~dec_absent:""
639
643
~enc:(fun u -> opt_to_string u.email)
640
-
|> Json.Codec.Object.opt_mem "confirmed_at" Json.Codec.string ~enc:(fun u ->
641
-
if u.email_verified then Some "" else None)
642
-
|> Json.Codec.Object.mem "name" Json.Codec.string ~dec_absent:""
643
-
~enc:(fun u -> u.name)
644
-
|> Json.Codec.Object.mem "avatar_url" Json.Codec.string ~dec_absent:""
645
-
~enc:(fun u -> u.avatar_url)
646
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
644
+
|> Object.opt_mem "confirmed_at" string ~enc:(fun u ->
645
+
if email_verified u then Some "" else None)
646
+
|> Object.mem "name" string ~dec_absent:"" ~enc:name
647
+
|> Object.mem "avatar_url" string ~dec_absent:"" ~enc:avatar_url
648
+
|> Object.skip_unknown |> Object.finish
647
649
648
650
(* Custom: uid extracted from the configured uid_field. Parses the standard
649
651
OIDC email_verified claim (Section 5.1) when present. *)
650
652
let custom_userinfo_jsont ~uid_field =
651
-
Json.Codec.Object.map ~kind:"custom_userinfo"
652
-
(fun uid email email_verified name ->
653
+
let open Json.Codec in
654
+
Object.map ~kind:"custom_userinfo"
655
+
(fun uid email email_verified name : userinfo ->
653
656
let verified = email_verified = Some true in
654
657
let email = if verified then non_empty email else None in
655
658
{
···
660
663
name;
661
664
avatar_url = "";
662
665
})
663
-
|> Json.Codec.Object.mem uid_field Json.Codec.string ~enc:(fun u -> u.uid)
664
-
|> Json.Codec.Object.mem "email" Json.Codec.string ~dec_absent:""
666
+
|> Object.mem uid_field string ~enc:uid
667
+
|> Object.mem "email" string ~dec_absent:""
665
668
~enc:(fun u -> opt_to_string u.email)
666
-
|> Json.Codec.Object.opt_mem "email_verified" Json.Codec.bool ~enc:(fun u ->
667
-
Some u.email_verified)
668
-
|> Json.Codec.Object.mem "name" Json.Codec.string ~dec_absent:""
669
-
~enc:(fun u -> u.name)
670
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
669
+
|> Object.opt_mem "email_verified" bool
670
+
~enc:(fun u -> Some (email_verified u))
671
+
|> Object.mem "name" string ~dec_absent:"" ~enc:name
672
+
|> Object.skip_unknown |> Object.finish
671
673
672
674
let err_userinfo_parse e =
673
675
Error ("userinfo parse error: " ^ Json.Error.to_string e)
···
695
697
type github_email = { email : string; primary : bool; verified : bool }
696
698
697
699
let github_email_jsont =
698
-
Json.Codec.Object.map ~kind:"github_email" (fun email primary verified ->
700
+
let open Json.Codec in
701
+
Object.map ~kind:"github_email" (fun email primary verified ->
699
702
{ email; primary; verified })
700
-
|> Json.Codec.Object.mem "email" Json.Codec.string ~enc:(fun e -> e.email)
701
-
|> Json.Codec.Object.mem "primary" Json.Codec.bool ~enc:(fun e -> e.primary)
702
-
|> Json.Codec.Object.mem "verified" Json.Codec.bool ~enc:(fun e -> e.verified)
703
-
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
703
+
|> Object.mem "email" string ~enc:(fun e -> e.email)
704
+
|> Object.mem "primary" bool ~enc:(fun e -> e.primary)
705
+
|> Object.mem "verified" bool ~enc:(fun e -> e.verified)
706
+
|> Object.skip_unknown |> Object.finish
704
707
705
708
let github_emails_jsont = Json.Codec.list github_email_jsont
706
709