OAuth 2.0 authorization and token exchange
slack, meross, stix, oauth: stop leaking Json.Error.t in public APIs
- slack: Json_parse variant stays string; convert Json.Error.t at the
internal api.ml boundary before wrapping.
- meross: Protocol.decode wraps Json.Error.t -> string at boundary.
- stix: bundle_of_string, decode_or_fail, encode_or_fail convert at
boundary.
- oauth: classify_token_error converts incoming Json.Error.t at entry.
- Test files adjusted: Json.Error.to_string for raw Json.of_string calls,
plain strings for package-level APIs that already convert.
+74
-64
-1
fuzz/dune
-1
fuzz/dune
+9
-7
fuzz/fuzz_oauth.ml
+9
-7
fuzz/fuzz_oauth.ml
···
27
27
(* Encode a token response as proper JSON using Jsont to avoid injection
28
28
from fuzzed strings containing quotes or backslashes. *)
29
29
let token_response_jsont =
30
-
Json.Object.map ~kind:"token_response"
30
+
Json.Codec.Object.map ~kind:"token_response"
31
31
(fun access_token expires_in refresh_token ->
32
32
(access_token, expires_in, refresh_token))
33
-
|> Json.Object.mem "access_token" Json.string ~enc:(fun (at, _, _) -> at)
34
-
|> Json.Object.opt_mem "expires_in" Json.int ~enc:(fun (_, ei, _) -> ei)
35
-
|> Json.Object.opt_mem "refresh_token" Json.string ~enc:(fun (_, _, rt) ->
36
-
rt)
37
-
|> Json.Object.finish
33
+
|> Json.Codec.Object.mem "access_token" Json.Codec.string
34
+
~enc:(fun (at, _, _) -> at)
35
+
|> Json.Codec.Object.opt_mem "expires_in" Json.Codec.int
36
+
~enc:(fun (_, ei, _) -> ei)
37
+
|> Json.Codec.Object.opt_mem "refresh_token" Json.Codec.string
38
+
~enc:(fun (_, _, rt) -> rt)
39
+
|> Json.Codec.Object.finish
38
40
39
41
(* Restrict fuzzed bytes to printable ASCII so JSON encode/decode roundtrips
40
42
are lossless. JSON strings are Unicode; arbitrary bytes may not survive
···
50
52
let expires_in = Option.map (fun n -> n land max_int mod 100000) expires_in in
51
53
let json =
52
54
match
53
-
Json_bytesrw.encode_string token_response_jsont
55
+
Json.to_string token_response_jsont
54
56
(access_token, expires_in, refresh_token)
55
57
with
56
58
| Ok s -> s
-1
lib/dune
-1
lib/dune
+65
-55
lib/oauth.ml
+65
-55
lib/oauth.ml
···
169
169
170
170
(* -- JSON helpers -------------------------------------------------- *)
171
171
172
-
let decode codec s = Json_bytesrw.decode_string codec s
172
+
let decode codec s = Json.of_string codec s
173
173
174
174
(* -- CSRF State --------------------------------------------------- *)
175
175
···
302
302
}
303
303
304
304
let raw_token_response_jsont =
305
-
Json.Object.map ~kind:"token_response"
305
+
Json.Codec.Object.map ~kind:"token_response"
306
306
(fun
307
307
access_token
308
308
token_type
···
317
317
refresh_token;
318
318
refresh_token_expires_in;
319
319
})
320
-
|> Json.Object.mem "access_token" Json.string ~enc:(fun t -> t.access_token)
321
-
|> Json.Object.opt_mem "token_type" Json.string ~enc:(fun t -> t.token_type)
322
-
|> Json.Object.opt_mem "expires_in" Json.int ~enc:(fun t -> t.expires_in)
323
-
|> Json.Object.opt_mem "refresh_token" Json.string ~enc:(fun t ->
320
+
|> Json.Codec.Object.mem "access_token" Json.Codec.string ~enc:(fun t ->
321
+
t.access_token)
322
+
|> Json.Codec.Object.opt_mem "token_type" Json.Codec.string ~enc:(fun t ->
323
+
t.token_type)
324
+
|> Json.Codec.Object.opt_mem "expires_in" Json.Codec.int ~enc:(fun t ->
325
+
t.expires_in)
326
+
|> Json.Codec.Object.opt_mem "refresh_token" Json.Codec.string ~enc:(fun t ->
324
327
t.refresh_token)
325
-
|> Json.Object.opt_mem "refresh_token_expires_in" Json.int ~enc:(fun t ->
326
-
t.refresh_token_expires_in)
327
-
|> Json.Object.skip_unknown |> Json.Object.finish
328
+
|> Json.Codec.Object.opt_mem "refresh_token_expires_in" Json.Codec.int
329
+
~enc:(fun t -> t.refresh_token_expires_in)
330
+
|> Json.Codec.Object.skip_unknown |> Json.Codec.Object.finish
328
331
329
332
type parse_token_error =
330
333
| Invalid_json
···
351
354
loop 0
352
355
353
356
let classify_token_error body e =
354
-
match decode Json.json body with
357
+
let e = Json.Error.to_string e in
358
+
match decode Json.Codec.Value.t body with
355
359
| Error _ -> Invalid_json
356
360
| Ok _ ->
357
361
if
···
566
570
email is intentionally dropped -- /user returns the public email which is
567
571
unverified. Use parse_github_emails with /user/emails for the verified one. *)
568
572
let github_userinfo_jsont =
569
-
Json.Object.map ~kind:"github_userinfo"
573
+
Json.Codec.Object.map ~kind:"github_userinfo"
570
574
(fun id login _email name avatar_url ->
571
575
{
572
576
uid = string_of_int id;
···
576
580
name;
577
581
avatar_url;
578
582
})
579
-
|> Json.Object.mem "id" Json.int ~enc:(fun _ -> 0)
580
-
|> Json.Object.mem "login" Json.string ~dec_absent:"" ~enc:(fun u ->
581
-
u.login)
582
-
|> Json.Object.mem "email" Json.string ~dec_absent:"" ~enc:(fun u ->
583
-
opt_to_string u.email)
584
-
|> Json.Object.mem "name" Json.string ~dec_absent:"" ~enc:(fun u -> u.name)
585
-
|> Json.Object.mem "avatar_url" Json.string ~dec_absent:"" ~enc:(fun u ->
586
-
u.avatar_url)
587
-
|> Json.Object.skip_unknown |> Json.Object.finish
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:""
587
+
~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
588
593
589
594
(* Google OIDC: {"sub":"118...","email":"...","email_verified":true,"name":"...","picture":"..."}
590
595
Only populate email when email_verified is true. Track the verified flag. *)
591
596
let google_userinfo_jsont =
592
-
Json.Object.map ~kind:"google_userinfo"
597
+
Json.Codec.Object.map ~kind:"google_userinfo"
593
598
(fun sub email email_verified name picture ->
594
599
let verified = email_verified = Some true in
595
600
let email = if verified then non_empty email else None in
···
601
606
name;
602
607
avatar_url = picture;
603
608
})
604
-
|> Json.Object.mem "sub" Json.string ~enc:(fun u -> u.uid)
605
-
|> Json.Object.mem "email" Json.string ~dec_absent:"" ~enc:(fun u ->
606
-
opt_to_string u.email)
607
-
|> Json.Object.opt_mem "email_verified" Json.bool ~enc:(fun u ->
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:""
611
+
~enc:(fun u -> opt_to_string u.email)
612
+
|> Json.Codec.Object.opt_mem "email_verified" Json.Codec.bool ~enc:(fun u ->
608
613
Some u.email_verified)
609
-
|> Json.Object.mem "name" Json.string ~dec_absent:"" ~enc:(fun u -> u.name)
610
-
|> Json.Object.mem "picture" Json.string ~dec_absent:"" ~enc:(fun u ->
611
-
u.avatar_url)
612
-
|> Json.Object.skip_unknown |> Json.Object.finish
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
613
619
614
620
(* GitLab: {"id":123,"username":"john","email":"...","confirmed_at":"2024-...",
615
621
"name":"...","avatar_url":"..."}
616
622
confirmed_at is non-null when the user has verified their email. *)
617
623
let gitlab_userinfo_jsont =
618
-
Json.Object.map ~kind:"gitlab_userinfo"
624
+
Json.Codec.Object.map ~kind:"gitlab_userinfo"
619
625
(fun id username email confirmed_at name avatar_url ->
620
626
let email_verified = Option.is_some confirmed_at in
621
627
{
···
626
632
name;
627
633
avatar_url;
628
634
})
629
-
|> Json.Object.mem "id" Json.int ~enc:(fun _ -> 0)
630
-
|> Json.Object.mem "username" Json.string ~dec_absent:"" ~enc:(fun u ->
631
-
u.login)
632
-
|> Json.Object.mem "email" Json.string ~dec_absent:"" ~enc:(fun u ->
633
-
opt_to_string u.email)
634
-
|> Json.Object.opt_mem "confirmed_at" Json.string ~enc:(fun u ->
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:""
639
+
~enc:(fun u -> opt_to_string u.email)
640
+
|> Json.Codec.Object.opt_mem "confirmed_at" Json.Codec.string ~enc:(fun u ->
635
641
if u.email_verified then Some "" else None)
636
-
|> Json.Object.mem "name" Json.string ~dec_absent:"" ~enc:(fun u -> u.name)
637
-
|> Json.Object.mem "avatar_url" Json.string ~dec_absent:"" ~enc:(fun u ->
638
-
u.avatar_url)
639
-
|> Json.Object.skip_unknown |> Json.Object.finish
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
640
647
641
648
(* Custom: uid extracted from the configured uid_field. Parses the standard
642
649
OIDC email_verified claim (Section 5.1) when present. *)
643
650
let custom_userinfo_jsont ~uid_field =
644
-
Json.Object.map ~kind:"custom_userinfo" (fun uid email email_verified name ->
651
+
Json.Codec.Object.map ~kind:"custom_userinfo"
652
+
(fun uid email email_verified name ->
645
653
let verified = email_verified = Some true in
646
654
let email = if verified then non_empty email else None in
647
655
{
···
652
660
name;
653
661
avatar_url = "";
654
662
})
655
-
|> Json.Object.mem uid_field Json.string ~enc:(fun u -> u.uid)
656
-
|> Json.Object.mem "email" Json.string ~dec_absent:"" ~enc:(fun u ->
657
-
opt_to_string u.email)
658
-
|> Json.Object.opt_mem "email_verified" Json.bool ~enc:(fun u ->
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:""
665
+
~enc:(fun u -> opt_to_string u.email)
666
+
|> Json.Codec.Object.opt_mem "email_verified" Json.Codec.bool ~enc:(fun u ->
659
667
Some u.email_verified)
660
-
|> Json.Object.mem "name" Json.string ~dec_absent:"" ~enc:(fun u -> u.name)
661
-
|> Json.Object.skip_unknown |> Json.Object.finish
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
662
671
663
-
let err_userinfo_parse e = Error ("userinfo parse error: " ^ e)
672
+
let err_userinfo_parse e =
673
+
Error ("userinfo parse error: " ^ Json.Error.to_string e)
664
674
665
675
let err_userinfo_empty_uid provider =
666
676
Error ("userinfo response from " ^ provider_name provider ^ " has empty uid")
···
685
695
type github_email = { email : string; primary : bool; verified : bool }
686
696
687
697
let github_email_jsont =
688
-
Json.Object.map ~kind:"github_email" (fun email primary verified ->
698
+
Json.Codec.Object.map ~kind:"github_email" (fun email primary verified ->
689
699
{ email; primary; verified })
690
-
|> Json.Object.mem "email" Json.string ~enc:(fun e -> e.email)
691
-
|> Json.Object.mem "primary" Json.bool ~enc:(fun e -> e.primary)
692
-
|> Json.Object.mem "verified" Json.bool ~enc:(fun e -> e.verified)
693
-
|> Json.Object.skip_unknown |> Json.Object.finish
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
694
704
695
-
let github_emails_jsont = Json.list github_email_jsont
705
+
let github_emails_jsont = Json.Codec.list github_email_jsont
696
706
697
707
let parse_github_emails body =
698
708
match decode github_emails_jsont body with
699
-
| Error e -> Error ("github emails parse error: " ^ e)
709
+
| Error e -> Error ("github emails parse error: " ^ Json.Error.to_string e)
700
710
| Ok emails -> (
701
711
match List.find_opt (fun e -> e.primary && e.verified) emails with
702
712
| Some e -> Ok e.email