OAuth 2.0 authorization and token exchange
s3, bottler: stream bottle uploads, don't hold the body in memory
New S3.Http.put_object_file takes a file path + env, computes the
SigV4 payload hash by streaming the file once through Digestif
(64 KB buffer, no heap allocation beyond the buffer), then hands
Requests.Body.of_file the same path so the HTTP layer streams the
second pass straight to the socket. A 200 MB bottle no longer has
to fit in the OCaml heap.
Sigv4.sign grows an optional ?payload_hash so callers that hash
the body out-of-band (streaming signers, aws-chunked, unsigned
payload) can override the string-based default without rewriting
the signing pipeline.
Bottler.Upload.put_both swaps Bos.OS.File.read + put_object for
put_object_file, removing the last heap-holds-entire-body
behaviour in the upload path.
+19
-19
+13
-13
lib/oauth.ml
+13
-13
lib/oauth.ml
···
4
4
5
5
module Log = (val Logs.src_log src : Logs.LOG)
6
6
7
-
(* ── Providers ───────────────────────────────────────────────────── *)
7
+
(* -- Providers ----------------------------------------------------- *)
8
8
9
9
type provider = Github | Google | Gitlab | Custom of custom_provider
10
10
···
128
128
| Gitlab -> [ "read_user" ]
129
129
| Custom _ -> []
130
130
131
-
(* ── Redirect URI ───────────────────────────────────────────────── *)
131
+
(* -- Redirect URI ------------------------------------------------- *)
132
132
133
133
type redirect_uri = string
134
134
···
167
167
168
168
let redirect_uri_to_string s = s
169
169
170
-
(* ── JSON helpers ────────────────────────────────────────────────── *)
170
+
(* -- JSON helpers -------------------------------------------------- *)
171
171
172
172
let decode codec s = Jsont_bytesrw.decode_string codec s
173
173
174
-
(* ── CSRF State ─────────────────────────────────────────────────── *)
174
+
(* -- CSRF State --------------------------------------------------- *)
175
175
176
176
let generate_state () = Ohex.encode (Crypto_rng.generate 32)
177
177
178
178
let validate_state ~expected ~actual =
179
179
String.length expected > 0 && Eqaf.equal expected actual
180
180
181
-
(* ── PKCE (RFC 7636) ─────────────────────────────────────────────── *)
181
+
(* -- PKCE (RFC 7636) ----------------------------------------------- *)
182
182
183
183
type challenge_method = S256 | Plain
184
184
type code_verifier = string
···
218
218
219
219
let challenge_method_to_string = function S256 -> "S256" | Plain -> "plain"
220
220
221
-
(* ── Authorization URL ───────────────────────────────────────────── *)
221
+
(* -- Authorization URL --------------------------------------------- *)
222
222
223
223
let authorization_url provider ~client_id ~redirect_uri ~state ~scope
224
224
?code_challenge:cc ?code_challenge_method () =
···
249
249
in
250
250
Uri.with_query uri query |> Uri.to_string
251
251
252
-
(* ── Token Exchange ──────────────────────────────────────────────── *)
252
+
(* -- Token Exchange ------------------------------------------------ *)
253
253
254
254
let pct_encode s =
255
255
let buf = Buffer.create (String.length s) in
···
284
284
in
285
285
form_encode params
286
286
287
-
(* ── Token Response ──────────────────────────────────────────────── *)
287
+
(* -- Token Response ------------------------------------------------ *)
288
288
289
289
type token_response = {
290
290
access_token : string;
···
389
389
Log.warn (fun m -> m "Token parse failed: %a" pp_parse_token_error err);
390
390
Error err
391
391
392
-
(* ── Token Refresh ───────────────────────────────────────────────── *)
392
+
(* -- Token Refresh ------------------------------------------------- *)
393
393
394
394
let refresh_form_body ~client_id ~client_secret ~refresh_token =
395
395
form_encode
···
433
433
let form_str = refresh_form_body ~client_id ~client_secret ~refresh_token in
434
434
post_token_endpoint http provider form_str
435
435
436
-
(* ── Token Lifecycle ─────────────────────────────────────────────── *)
436
+
(* -- Token Lifecycle ----------------------------------------------- *)
437
437
438
438
module Token = struct
439
439
(* Refresh when the access token is within this many seconds of expiry.
···
547
547
stale_state ~clock:t.clock ~threshold:0.0 t.state)
548
548
end
549
549
550
-
(* ── Userinfo Parsing ────────────────────────────────────────────── *)
550
+
(* -- Userinfo Parsing ---------------------------------------------- *)
551
551
552
552
type userinfo = {
553
553
uid : string;
···
563
563
let opt_to_string = function Some s -> s | None -> ""
564
564
565
565
(* GitHub: {"id":123,"login":"octocat","email":"...","name":"...","avatar_url":"..."}
566
-
email is intentionally dropped — /user returns the public email which is
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
569
Jsont.Object.map ~kind:"github_userinfo"
···
678
678
| Ok u when u.uid = "" -> err_userinfo_empty_uid provider
679
679
| Ok u -> Ok u
680
680
681
-
(* ── GitHub Verified Emails ─────────────────────────────────────── *)
681
+
(* -- GitHub Verified Emails --------------------------------------- *)
682
682
683
683
let github_emails_url = "https://api.github.com/user/emails"
684
684
+6
-6
lib/oauth.mli
+6
-6
lib/oauth.mli
···
63
63
uid_field : string; (** JSON field containing the unique user identifier. *)
64
64
}
65
65
(** Configuration for a custom OAuth provider not covered by the built-in
66
-
variants. The type is private — use {!custom_provider} to construct values.
66
+
variants. The type is private -- use {!custom_provider} to construct values.
67
67
Fields are readable for pattern matching.
68
68
69
69
{b Security}: All URLs must use HTTPS. Per
···
95
95
(** [provider_name p] is the canonical provider identifier used for identity
96
96
storage. Returns ["github"], ["google"], ["gitlab"], or [c.name] verbatim
97
97
for custom providers. This value is stored in the database as the [provider]
98
-
column — it must be unique per provider and stable. *)
98
+
column -- it must be unique per provider and stable. *)
99
99
100
100
val provider_slug : provider -> string
101
101
(** [provider_slug p] is a URL-safe lowercase slug derived from the provider
···
104
104
sanitized to [[a-z0-9-]].
105
105
106
106
{!custom_provider} rejects names whose slug collides with a built-in
107
-
provider. Distinct custom providers may still produce the same slug — use
107
+
provider. Distinct custom providers may still produce the same slug -- use
108
108
{!provider_name} for identity lookup. *)
109
109
110
110
val authorize_url : provider -> string
···
290
290
291
291
A self-refreshing token wrapper. Holds an access token and (optional)
292
292
refresh token, and transparently refreshes the access token when it is near
293
-
expiry. Safe to share across Eio fibers — internal state is protected by a
293
+
expiry. Safe to share across Eio fibers -- internal state is protected by a
294
294
mutex so only one fiber refreshes at a time while others wait.
295
295
296
296
{b Example}
···
428
428
429
429
Returns [Error msg] if no email is both [primary = true] and
430
430
[verified = true]. This is the only reliable way to obtain a user's email
431
-
from GitHub — the [/user] endpoint returns the {i public} email which may be
432
-
absent or unverified. *)
431
+
from GitHub -- the [/user] endpoint returns the {i public} email which may
432
+
be absent or unverified. *)