OAuth 2.0 authorization and token exchange
wal, block, sse, zephyr: remove [mutable] from never-reassigned fields
Warning 69 (unused-field, mutable-never-assigned). Four independent
record fields were flagged as mutable but the code only mutates their
referents in place, never rebinds the record slot itself:
- ocaml-wal/lib/wal.ml: [t.file] (the Eio file resource; methods call
Eio.File.pwrite_all etc., the slot is set once at open time).
- ocaml-block/lib/block.ml: [Memory.state.data] (the backing bytes,
written via Bytes.blit_string; [Bytes.t] is already mutable).
- ocaml-sse/lib/sse.ml: [Parser.t.data_buf] (a Buffer.t, written via
Buffer.add_*; the slot never changes).
- ocaml-zephyr/lib/zephyr.ml: drop [mode : Read | Write] entirely —
set at open-time, read nowhere. The open_read / open_write
constructors already distinguish the two call shapes, so mode
tracking was redundant.
+56
-53
+1
-1
dune-project
+1
-1
dune-project
+6
-6
fuzz/fuzz_oauth.ml
+6
-6
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
-
Jsont.Object.map ~kind:"token_response"
30
+
Json.Object.map ~kind:"token_response"
31
31
(fun access_token expires_in refresh_token ->
32
32
(access_token, expires_in, refresh_token))
33
-
|> Jsont.Object.mem "access_token" Jsont.string ~enc:(fun (at, _, _) -> at)
34
-
|> Jsont.Object.opt_mem "expires_in" Jsont.int ~enc:(fun (_, ei, _) -> ei)
35
-
|> Jsont.Object.opt_mem "refresh_token" Jsont.string ~enc:(fun (_, _, rt) ->
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
36
rt)
37
-
|> Jsont.Object.finish
37
+
|> Json.Object.finish
38
38
39
39
(* Restrict fuzzed bytes to printable ASCII so JSON encode/decode roundtrips
40
40
are lossless. JSON strings are Unicode; arbitrary bytes may not survive
···
50
50
let expires_in = Option.map (fun n -> n land max_int mod 100000) expires_in in
51
51
let json =
52
52
match
53
-
Jsont_bytesrw.encode_string token_response_jsont
53
+
Json_bytesrw.encode_string token_response_jsont
54
54
(access_token, expires_in, refresh_token)
55
55
with
56
56
| Ok s -> s
+2
-2
lib/dune
+2
-2
lib/dune
+43
-43
lib/oauth.ml
+43
-43
lib/oauth.ml
···
169
169
170
170
(* -- JSON helpers -------------------------------------------------- *)
171
171
172
-
let decode codec s = Jsont_bytesrw.decode_string codec s
172
+
let decode codec s = Json_bytesrw.decode_string codec s
173
173
174
174
(* -- CSRF State --------------------------------------------------- *)
175
175
···
302
302
}
303
303
304
304
let raw_token_response_jsont =
305
-
Jsont.Object.map ~kind:"token_response"
305
+
Json.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
-
|> Jsont.Object.mem "access_token" Jsont.string ~enc:(fun t -> t.access_token)
321
-
|> Jsont.Object.opt_mem "token_type" Jsont.string ~enc:(fun t -> t.token_type)
322
-
|> Jsont.Object.opt_mem "expires_in" Jsont.int ~enc:(fun t -> t.expires_in)
323
-
|> Jsont.Object.opt_mem "refresh_token" Jsont.string ~enc:(fun t ->
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 ->
324
324
t.refresh_token)
325
-
|> Jsont.Object.opt_mem "refresh_token_expires_in" Jsont.int ~enc:(fun t ->
325
+
|> Json.Object.opt_mem "refresh_token_expires_in" Json.int ~enc:(fun t ->
326
326
t.refresh_token_expires_in)
327
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
327
+
|> Json.Object.skip_unknown |> Json.Object.finish
328
328
329
329
type parse_token_error =
330
330
| Invalid_json
···
351
351
loop 0
352
352
353
353
let classify_token_error body e =
354
-
match decode Jsont.json body with
354
+
match decode Json.json body with
355
355
| Error _ -> Invalid_json
356
356
| Ok _ ->
357
357
if
···
566
566
email is intentionally dropped -- /user returns the public email which is
567
567
unverified. Use parse_github_emails with /user/emails for the verified one. *)
568
568
let github_userinfo_jsont =
569
-
Jsont.Object.map ~kind:"github_userinfo"
569
+
Json.Object.map ~kind:"github_userinfo"
570
570
(fun id login _email name avatar_url ->
571
571
{
572
572
uid = string_of_int id;
···
576
576
name;
577
577
avatar_url;
578
578
})
579
-
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun _ -> 0)
580
-
|> Jsont.Object.mem "login" Jsont.string ~dec_absent:"" ~enc:(fun u ->
579
+
|> Json.Object.mem "id" Json.int ~enc:(fun _ -> 0)
580
+
|> Json.Object.mem "login" Json.string ~dec_absent:"" ~enc:(fun u ->
581
581
u.login)
582
-
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:"" ~enc:(fun u ->
582
+
|> Json.Object.mem "email" Json.string ~dec_absent:"" ~enc:(fun u ->
583
583
opt_to_string u.email)
584
-
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:(fun u -> u.name)
585
-
|> Jsont.Object.mem "avatar_url" Jsont.string ~dec_absent:"" ~enc:(fun u ->
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
586
u.avatar_url)
587
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
587
+
|> Json.Object.skip_unknown |> Json.Object.finish
588
588
589
589
(* Google OIDC: {"sub":"118...","email":"...","email_verified":true,"name":"...","picture":"..."}
590
590
Only populate email when email_verified is true. Track the verified flag. *)
591
591
let google_userinfo_jsont =
592
-
Jsont.Object.map ~kind:"google_userinfo"
592
+
Json.Object.map ~kind:"google_userinfo"
593
593
(fun sub email email_verified name picture ->
594
594
let verified = email_verified = Some true in
595
595
let email = if verified then non_empty email else None in
···
601
601
name;
602
602
avatar_url = picture;
603
603
})
604
-
|> Jsont.Object.mem "sub" Jsont.string ~enc:(fun u -> u.uid)
605
-
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:"" ~enc:(fun u ->
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
606
opt_to_string u.email)
607
-
|> Jsont.Object.opt_mem "email_verified" Jsont.bool ~enc:(fun u ->
607
+
|> Json.Object.opt_mem "email_verified" Json.bool ~enc:(fun u ->
608
608
Some u.email_verified)
609
-
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:(fun u -> u.name)
610
-
|> Jsont.Object.mem "picture" Jsont.string ~dec_absent:"" ~enc:(fun u ->
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
611
u.avatar_url)
612
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
612
+
|> Json.Object.skip_unknown |> Json.Object.finish
613
613
614
614
(* GitLab: {"id":123,"username":"john","email":"...","confirmed_at":"2024-...",
615
615
"name":"...","avatar_url":"..."}
616
616
confirmed_at is non-null when the user has verified their email. *)
617
617
let gitlab_userinfo_jsont =
618
-
Jsont.Object.map ~kind:"gitlab_userinfo"
618
+
Json.Object.map ~kind:"gitlab_userinfo"
619
619
(fun id username email confirmed_at name avatar_url ->
620
620
let email_verified = Option.is_some confirmed_at in
621
621
{
···
626
626
name;
627
627
avatar_url;
628
628
})
629
-
|> Jsont.Object.mem "id" Jsont.int ~enc:(fun _ -> 0)
630
-
|> Jsont.Object.mem "username" Jsont.string ~dec_absent:"" ~enc:(fun u ->
629
+
|> Json.Object.mem "id" Json.int ~enc:(fun _ -> 0)
630
+
|> Json.Object.mem "username" Json.string ~dec_absent:"" ~enc:(fun u ->
631
631
u.login)
632
-
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:"" ~enc:(fun u ->
632
+
|> Json.Object.mem "email" Json.string ~dec_absent:"" ~enc:(fun u ->
633
633
opt_to_string u.email)
634
-
|> Jsont.Object.opt_mem "confirmed_at" Jsont.string ~enc:(fun u ->
634
+
|> Json.Object.opt_mem "confirmed_at" Json.string ~enc:(fun u ->
635
635
if u.email_verified then Some "" else None)
636
-
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:(fun u -> u.name)
637
-
|> Jsont.Object.mem "avatar_url" Jsont.string ~dec_absent:"" ~enc:(fun u ->
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
638
u.avatar_url)
639
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
639
+
|> Json.Object.skip_unknown |> Json.Object.finish
640
640
641
641
(* Custom: uid extracted from the configured uid_field. Parses the standard
642
642
OIDC email_verified claim (Section 5.1) when present. *)
643
643
let custom_userinfo_jsont ~uid_field =
644
-
Jsont.Object.map ~kind:"custom_userinfo" (fun uid email email_verified name ->
644
+
Json.Object.map ~kind:"custom_userinfo" (fun uid email email_verified name ->
645
645
let verified = email_verified = Some true in
646
646
let email = if verified then non_empty email else None in
647
647
{
···
652
652
name;
653
653
avatar_url = "";
654
654
})
655
-
|> Jsont.Object.mem uid_field Jsont.string ~enc:(fun u -> u.uid)
656
-
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:"" ~enc:(fun u ->
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
657
opt_to_string u.email)
658
-
|> Jsont.Object.opt_mem "email_verified" Jsont.bool ~enc:(fun u ->
658
+
|> Json.Object.opt_mem "email_verified" Json.bool ~enc:(fun u ->
659
659
Some u.email_verified)
660
-
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:"" ~enc:(fun u -> u.name)
661
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
660
+
|> Json.Object.mem "name" Json.string ~dec_absent:"" ~enc:(fun u -> u.name)
661
+
|> Json.Object.skip_unknown |> Json.Object.finish
662
662
663
663
let err_userinfo_parse e = Error ("userinfo parse error: " ^ e)
664
664
···
685
685
type github_email = { email : string; primary : bool; verified : bool }
686
686
687
687
let github_email_jsont =
688
-
Jsont.Object.map ~kind:"github_email" (fun email primary verified ->
688
+
Json.Object.map ~kind:"github_email" (fun email primary verified ->
689
689
{ email; primary; verified })
690
-
|> Jsont.Object.mem "email" Jsont.string ~enc:(fun e -> e.email)
691
-
|> Jsont.Object.mem "primary" Jsont.bool ~enc:(fun e -> e.primary)
692
-
|> Jsont.Object.mem "verified" Jsont.bool ~enc:(fun e -> e.verified)
693
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
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
694
694
695
-
let github_emails_jsont = Jsont.list github_email_jsont
695
+
let github_emails_jsont = Json.list github_email_jsont
696
696
697
697
let parse_github_emails body =
698
698
match decode github_emails_jsont body with