Google API authentication helpers: service accounts and local OAuth
prune cram fixtures: declare fmt dep missed in Printf→Fmt migration
Commit 5fbed21c switched every cram test fixture from Printf to Fmt
without updating the dune stanzas to depend on fmt, so `dune build`
inside the fixtures fails and the cram expected output stopped
matching reality. Add fmt to each executable/library and refresh the
one stale expected block (cascade_cleanup) still showing Printf.
+803
+40
dune-project
+40
dune-project
···
1
+
(lang dune 3.21)
2
+
3
+
(name gauth)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(source (tangled gazagnaire.org/ocaml-gauth))
8
+
(license MIT)
9
+
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
10
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
11
+
12
+
(package
13
+
(name gauth)
14
+
(synopsis "Google API authentication helpers: service accounts and local OAuth")
15
+
(tags (org:blacksun google network http crypto))
16
+
(description
17
+
"Authentication helpers for Google APIs (Docs, Sheets, Drive, Calendar,
18
+
Gmail, ...). Supports two flows: (1) service-account JWT bearer per
19
+
RFC 7523 using a service-account JSON key, and (2) interactive local
20
+
OAuth for CLIs with a localhost callback listener. Produces lifecycle-
21
+
managed Oauth.Token.t values ready for use with Requests.")
22
+
(depends
23
+
(ocaml (>= 5.1))
24
+
(dune (>= 3.21))
25
+
(base64 (>= 3.0))
26
+
(digestif (>= 1.0))
27
+
(eio (>= 1.0))
28
+
(fmt (>= 0.9))
29
+
(jsont (>= 0.2))
30
+
(bytesrw (>= 0.1))
31
+
(jwt (>= 0.1))
32
+
(logs (>= 0.7))
33
+
(oauth (>= 0.1))
34
+
(ptime (>= 1.0))
35
+
(requests (>= 0.1))
36
+
(uri (>= 4.0))
37
+
(x509 (>= 1.0))
38
+
(alcotest :with-test)
39
+
(eio_main :with-test)
40
+
(odoc :with-doc)))
+54
gauth.opam
+54
gauth.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis:
4
+
"Google API authentication helpers: service accounts and local OAuth"
5
+
description: """
6
+
Authentication helpers for Google APIs (Docs, Sheets, Drive, Calendar,
7
+
Gmail, ...). Supports two flows: (1) service-account JWT bearer per
8
+
RFC 7523 using a service-account JSON key, and (2) interactive local
9
+
OAuth for CLIs with a localhost callback listener. Produces lifecycle-
10
+
managed Oauth.Token.t values ready for use with Requests."""
11
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
12
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
13
+
license: "MIT"
14
+
tags: ["org:blacksun" "google" "network" "http" "crypto"]
15
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-gauth"
16
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-gauth/issues"
17
+
depends: [
18
+
"ocaml" {>= "5.1"}
19
+
"dune" {>= "3.21" & >= "3.21"}
20
+
"base64" {>= "3.0"}
21
+
"digestif" {>= "1.0"}
22
+
"eio" {>= "1.0"}
23
+
"fmt" {>= "0.9"}
24
+
"jsont" {>= "0.2"}
25
+
"bytesrw" {>= "0.1"}
26
+
"jwt" {>= "0.1"}
27
+
"logs" {>= "0.7"}
28
+
"oauth" {>= "0.1"}
29
+
"ptime" {>= "1.0"}
30
+
"requests" {>= "0.1"}
31
+
"uri" {>= "4.0"}
32
+
"x509" {>= "1.0"}
33
+
"alcotest" {with-test}
34
+
"eio_main" {with-test}
35
+
"odoc" {with-doc}
36
+
]
37
+
build: [
38
+
["dune" "subst"] {dev}
39
+
[
40
+
"dune"
41
+
"build"
42
+
"-p"
43
+
name
44
+
"-j"
45
+
jobs
46
+
"@install"
47
+
"@runtest" {with-test}
48
+
"@doc" {with-doc}
49
+
]
50
+
]
51
+
dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-gauth"
52
+
x-maintenance-intent: ["(latest)"]
53
+
x-quality-build: "2026-04-16"
54
+
x-quality-test: "2026-04-16"
+18
lib/dune
+18
lib/dune
+474
lib/gauth.ml
+474
lib/gauth.ml
···
1
+
(** Google API authentication helpers. *)
2
+
3
+
let src = Logs.Src.create "gauth" ~doc:"Google API authentication helpers"
4
+
5
+
module Log = (val Logs.src_log src : Logs.LOG)
6
+
7
+
(* Error helpers — keep all the [`Msg] error shapes in one place so the
8
+
surface formatting stays consistent. *)
9
+
10
+
let err_msg fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmt
11
+
let err_parse_token e = err_msg "%a" Oauth.pp_parse_token_error e
12
+
let err_sa_expected_rsa () = err_msg "service-account key must be RSA"
13
+
let err_sa_wrong_type t = err_msg "expected type=service_account, got %S" t
14
+
let err_sa_pem m = err_msg "failed to decode private_key PEM: %s" m
15
+
let err_sa_json e = err_msg "service-account JSON parse: %s" e
16
+
let err_io e = err_msg "%s" (Printexc.to_string e)
17
+
let err_jwt_sign e = err_msg "JWT sign: %s" (Jwt.error_to_string e)
18
+
19
+
let err_http_status status body =
20
+
err_msg "token endpoint HTTP %d: %s" status body
21
+
22
+
let err_redirect m = err_msg "redirect URI: %s" m
23
+
let err_callback_missing_code = `Msg "callback missing code parameter"
24
+
let err_callback_state_mismatch = `Msg "OAuth state mismatch (CSRF)"
25
+
let err_callback_timeout = `Msg "timed out waiting for OAuth callback"
26
+
let err_callback_malformed = `Msg "malformed callback request"
27
+
let err_provider msg = `Msg ("provider error: " ^ msg)
28
+
29
+
let err_code_exchange e =
30
+
`Msg (Fmt.str "code exchange failed: %a" Oauth.pp_parse_token_error e)
31
+
32
+
(* ── Token abstraction ───────────────────────────────────────────── *)
33
+
34
+
type refresher = unit -> (string, [ `Msg of string ]) result
35
+
(** Custom refresh callback — pluggable to support both user-flow tokens (which
36
+
have a refresh_token) and service-account tokens (which re-run the JWT
37
+
bearer exchange). *)
38
+
39
+
type token_state = {
40
+
mutable access_token : string;
41
+
mutable expires_at : float option;
42
+
refresh : refresher;
43
+
clock : float Eio.Time.clock_ty Eio.Resource.t;
44
+
mutex : Eio.Mutex.t;
45
+
}
46
+
47
+
type token =
48
+
| Oauth_token of Oauth.Token.t
49
+
(** User-flow token — delegates refresh to {!Oauth.Token}. *)
50
+
| Sa_token of token_state (** Service-account token — custom refresher. *)
51
+
52
+
let stale ~clock ~threshold = function
53
+
| None -> false
54
+
| Some exp -> Eio.Time.now clock +. threshold >= exp
55
+
56
+
let refresh_threshold = 60.0
57
+
58
+
let sa_try_access s =
59
+
Eio.Mutex.use_rw ~protect:true s.mutex (fun () ->
60
+
if stale ~clock:s.clock ~threshold:refresh_threshold s.expires_at then
61
+
match s.refresh () with Error _ as e -> e | Ok access -> Ok access
62
+
else Ok s.access_token)
63
+
64
+
let try_access = function
65
+
| Oauth_token t -> (
66
+
match Oauth.Token.try_access t with
67
+
| Ok s -> Ok s
68
+
| Error e -> err_parse_token e)
69
+
| Sa_token s -> sa_try_access s
70
+
71
+
let access t =
72
+
match try_access t with
73
+
| Ok s -> s
74
+
| Error (`Msg m) -> Fmt.failwith "Gauth.access: %s" m
75
+
76
+
(* ── Service accounts ────────────────────────────────────────────── *)
77
+
78
+
module Service_account = struct
79
+
type key = {
80
+
client_email : string;
81
+
token_uri : string;
82
+
private_key : X509.Private_key.t;
83
+
private_key_jwk : Jwt.Jwk.t;
84
+
kid : string option;
85
+
}
86
+
87
+
type raw_key = {
88
+
type_ : string;
89
+
client_email : string;
90
+
token_uri : string option;
91
+
private_key : string;
92
+
private_key_id : string option;
93
+
}
94
+
95
+
let raw_jsont =
96
+
Jsont.Object.map ~kind:"service_account"
97
+
(fun type_ client_email token_uri private_key private_key_id ->
98
+
{ type_; client_email; token_uri; private_key; private_key_id })
99
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun k -> k.type_)
100
+
|> Jsont.Object.mem "client_email" Jsont.string ~enc:(fun k ->
101
+
k.client_email)
102
+
|> Jsont.Object.opt_mem "token_uri" Jsont.string ~enc:(fun k -> k.token_uri)
103
+
|> Jsont.Object.mem "private_key" Jsont.string ~enc:(fun k -> k.private_key)
104
+
|> Jsont.Object.opt_mem "private_key_id" Jsont.string ~enc:(fun k ->
105
+
k.private_key_id)
106
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
107
+
108
+
(* Convert X509 RSA private key to a Jwt.Jwk RSA private key.
109
+
JWK RFC 7518 §6.3 requires the RSA components as unsigned big-endian
110
+
octet strings. Crypto_pk.Rsa.priv holds them as Z.t. *)
111
+
let jwk_of_rsa_priv (p : Crypto_pk.Rsa.priv) : Jwt.Jwk.t =
112
+
let octets z = Crypto_pk.Z_extra.to_octets_be z in
113
+
Jwt.Jwk.rsa_priv ~n:(octets p.n) ~e:(octets p.e) ~d:(octets p.d)
114
+
~p:(octets p.p) ~q:(octets p.q) ~dp:(octets p.dp) ~dq:(octets p.dq)
115
+
~qi:(octets p.q')
116
+
117
+
let of_raw (r : raw_key) =
118
+
if r.type_ <> "service_account" then err_sa_wrong_type r.type_
119
+
else
120
+
match X509.Private_key.decode_pem r.private_key with
121
+
| Error (`Msg m) -> err_sa_pem m
122
+
| Ok (`RSA rsa_priv as priv) ->
123
+
let jwk = jwk_of_rsa_priv rsa_priv in
124
+
let jwk =
125
+
match r.private_key_id with
126
+
| Some k -> Jwt.Jwk.with_kid k jwk
127
+
| None -> jwk
128
+
in
129
+
let token_uri =
130
+
Option.value r.token_uri
131
+
~default:"https://oauth2.googleapis.com/token"
132
+
in
133
+
Ok
134
+
{
135
+
client_email = r.client_email;
136
+
token_uri;
137
+
private_key = priv;
138
+
private_key_jwk = jwk;
139
+
kid = r.private_key_id;
140
+
}
141
+
| Ok _ -> err_sa_expected_rsa ()
142
+
143
+
let of_json s =
144
+
match Jsont_bytesrw.decode_string raw_jsont s with
145
+
| Error e -> err_sa_json e
146
+
| Ok r -> of_raw r
147
+
148
+
let of_file path =
149
+
try of_json (Eio.Path.load path) with Eio.Io _ as e -> err_io e
150
+
151
+
let client_email (k : key) = k.client_email
152
+
153
+
(* Build and sign the JWT assertion per RFC 7523 §2.1 and Google's SA
154
+
guide. *)
155
+
let make_assertion ~clock ?subject ~scopes (k : key) =
156
+
let now = Eio.Time.now clock in
157
+
let iat = int_of_float now in
158
+
let exp = iat + 3600 in
159
+
let scope_str = String.concat " " scopes in
160
+
let fields =
161
+
[
162
+
Fmt.str {|"iss":"%s"|} k.client_email;
163
+
Fmt.str {|"scope":"%s"|} scope_str;
164
+
Fmt.str {|"aud":"%s"|} k.token_uri;
165
+
Fmt.str {|"iat":%d|} iat;
166
+
Fmt.str {|"exp":%d|} exp;
167
+
]
168
+
in
169
+
let fields =
170
+
match subject with
171
+
| None -> fields
172
+
| Some s -> fields @ [ Fmt.str {|"sub":"%s"|} s ]
173
+
in
174
+
let claims_json = "{" ^ String.concat "," fields ^ "}" in
175
+
let header = Jwt.Header.make ?kid:k.kid Jwt.Algorithm.RS256 in
176
+
let claims =
177
+
match Jwt.Claims.of_json claims_json with
178
+
| Ok c -> c
179
+
| Error e ->
180
+
Fmt.failwith "Gauth: assertion claims: %s" (Jwt.error_to_string e)
181
+
in
182
+
match Jwt.v ~header ~claims ~key:k.private_key_jwk with
183
+
| Error e -> err_jwt_sign e
184
+
| Ok t -> Ok (Jwt.encode t, float_of_int exp)
185
+
186
+
let form_encode params =
187
+
let pct_encode s =
188
+
let buf = Buffer.create (String.length s) in
189
+
String.iter
190
+
(fun c ->
191
+
match c with
192
+
| 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '-' | '_' | '.' | '~' ->
193
+
Buffer.add_char buf c
194
+
| _ -> Buffer.add_string buf (Fmt.str "%%%02X" (Char.code c)))
195
+
s;
196
+
Buffer.contents buf
197
+
in
198
+
String.concat "&"
199
+
(List.map (fun (k, v) -> pct_encode k ^ "=" ^ pct_encode v) params)
200
+
201
+
let exchange http (k : key) assertion =
202
+
let body_str =
203
+
form_encode
204
+
[
205
+
("grant_type", "urn:ietf:params:oauth:grant-type:jwt-bearer");
206
+
("assertion", assertion);
207
+
]
208
+
in
209
+
let headers =
210
+
Http.Headers.of_list
211
+
[
212
+
("Content-Type", "application/x-www-form-urlencoded");
213
+
("Accept", "application/json");
214
+
]
215
+
in
216
+
let body = Requests.Body.text body_str in
217
+
let resp = Requests.post http k.token_uri ~body ~headers in
218
+
let status = Requests.Response.status_code resp in
219
+
let text = Requests.Response.text resp in
220
+
if status < 200 || status >= 300 then err_http_status status text
221
+
else
222
+
match Oauth.parse_token_response text with
223
+
| Ok tr -> Ok tr
224
+
| Error e -> err_parse_token e
225
+
226
+
let do_exchange http ~clock ?subject ~scopes (k : key) =
227
+
match make_assertion ~clock ?subject ~scopes k with
228
+
| Error _ as e -> e
229
+
| Ok (assertion, _claim_exp) -> (
230
+
match exchange http k assertion with
231
+
| Error _ as e -> e
232
+
| Ok tr ->
233
+
let now = Eio.Time.now clock in
234
+
let expires_at =
235
+
match tr.expires_in with
236
+
| Some d -> Some (now +. float_of_int d)
237
+
| None -> None
238
+
in
239
+
Ok (tr.access_token, expires_at))
240
+
241
+
let token http ~clock ?subject ~scopes k =
242
+
match do_exchange http ~clock ?subject ~scopes k with
243
+
| Error _ as e -> e
244
+
| Ok (access_token, expires_at) ->
245
+
(* The refresher mutates [state] in place so subsequent calls to
246
+
[access] pick up the new token without allocating. *)
247
+
let state_ref = ref None in
248
+
let refresh () =
249
+
match do_exchange http ~clock ?subject ~scopes k with
250
+
| Error _ as e -> e
251
+
| Ok (new_access, new_expires) -> (
252
+
match !state_ref with
253
+
| None -> Ok new_access
254
+
| Some s ->
255
+
s.access_token <- new_access;
256
+
s.expires_at <- new_expires;
257
+
Ok new_access)
258
+
in
259
+
let state =
260
+
{
261
+
access_token;
262
+
expires_at;
263
+
refresh;
264
+
clock :> float Eio.Time.clock_ty Eio.Resource.t;
265
+
mutex = Eio.Mutex.create ();
266
+
}
267
+
in
268
+
state_ref := Some state;
269
+
Ok (Sa_token state)
270
+
end
271
+
272
+
(* ── Local OAuth flow ────────────────────────────────────────────── *)
273
+
274
+
module Local_flow = struct
275
+
(* Minimal HTTP request parser: reads just enough to extract the request
276
+
line. The body is ignored — this handler only serves GET callbacks. *)
277
+
let read_request flow =
278
+
let reader = Eio.Buf_read.of_flow flow ~max_size:16_384 in
279
+
Eio.Buf_read.line reader
280
+
281
+
let parse_request_line line =
282
+
match String.split_on_char ' ' line with
283
+
| method_ :: path :: _ when String.length method_ > 0 -> Some (method_, path)
284
+
| _ -> None
285
+
286
+
let parse_callback_query path =
287
+
match String.index_opt path '?' with
288
+
| None -> []
289
+
| Some i ->
290
+
let qs = String.sub path (i + 1) (String.length path - i - 1) in
291
+
Uri.query_of_encoded qs
292
+
|> List.map (fun (k, vs) -> (k, match vs with [] -> "" | v :: _ -> v))
293
+
294
+
let html_response ~status ~body =
295
+
let reason = if status = 200 then "OK" else "Bad Request" in
296
+
Fmt.str
297
+
"HTTP/1.1 %d %s\r\n\
298
+
Content-Type: text/html; charset=utf-8\r\n\
299
+
Content-Length: %d\r\n\
300
+
Connection: close\r\n\
301
+
\r\n\
302
+
%s"
303
+
status reason (String.length body) body
304
+
305
+
let success_html =
306
+
"<!doctype html><html><body style=\"font-family: system-ui; padding: \
307
+
2em\"><h2>Authorization complete</h2><p>You can close this \
308
+
tab.</p></body></html>"
309
+
310
+
let error_html msg =
311
+
Fmt.str
312
+
"<!doctype html><html><body style=\"font-family: system-ui; padding: \
313
+
2em; color: #c00\"><h2>Authorization failed</h2><p>%s</p></body></html>"
314
+
msg
315
+
316
+
let default_on_url url =
317
+
Fmt.epr "Open this URL in your browser to authorize:@.@. %s@." url
318
+
319
+
(* Decide how to respond to the browser and what token (if any) resulted.
320
+
Returns [(status, html_body, result)] — the caller writes the HTML
321
+
and records the result. *)
322
+
let classify_callback ~http ~clock ~client_id ~client_secret ~state ~verifier
323
+
~redirect_uri line =
324
+
match parse_request_line line with
325
+
| None -> (400, error_html "malformed request", Error err_callback_malformed)
326
+
| Some (_, path) -> (
327
+
let params = parse_callback_query path in
328
+
let find k = List.assoc_opt k params in
329
+
match (find "error", find "code", find "state") with
330
+
| Some err, _, _ ->
331
+
( 400,
332
+
error_html ("provider error: " ^ err),
333
+
Error (err_provider err) )
334
+
| None, None, _ ->
335
+
(400, error_html "missing code", Error err_callback_missing_code)
336
+
| None, Some code, actual_state -> (
337
+
let actual = Option.value actual_state ~default:"" in
338
+
if not (Oauth.validate_state ~expected:state ~actual) then
339
+
( 400,
340
+
error_html "state mismatch (CSRF)",
341
+
Error err_callback_state_mismatch )
342
+
else
343
+
match
344
+
Oauth.exchange_code http Oauth.Google ~client_id ~client_secret
345
+
~code ~redirect_uri ~code_verifier:verifier ()
346
+
with
347
+
| Error e ->
348
+
( 400,
349
+
error_html "code exchange failed",
350
+
Error (err_code_exchange e) )
351
+
| Ok tr ->
352
+
let tok =
353
+
Oauth.Token.of_response http Oauth.Google ~client_id
354
+
~client_secret ~clock tr
355
+
in
356
+
(200, success_html, Ok (Oauth_token tok))))
357
+
358
+
let build_auth_url ~client_id ~redirect_uri ~state ~challenge ~scopes =
359
+
let base =
360
+
Oauth.authorization_url Oauth.Google ~client_id ~redirect_uri ~state
361
+
~scope:scopes ~code_challenge:challenge
362
+
~code_challenge_method:Oauth.S256 ()
363
+
in
364
+
(* Google needs access_type=offline and prompt=consent to issue a
365
+
refresh_token. *)
366
+
Uri.of_string base
367
+
|> (fun u -> Uri.add_query_param u ("access_type", [ "offline" ]))
368
+
|> (fun u -> Uri.add_query_param u ("prompt", [ "consent" ]))
369
+
|> Uri.to_string
370
+
371
+
let listen_loopback ~sw ~net port =
372
+
let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, port) in
373
+
let sock = Eio.Net.listen ~backlog:5 ~reuse_addr:true ~sw net addr in
374
+
let actual =
375
+
match Eio.Net.listening_addr sock with `Tcp (_, p) -> p | _ -> port
376
+
in
377
+
(sock, actual)
378
+
379
+
let send_response flow ~status ~body =
380
+
try Eio.Flow.copy_string (html_response ~status ~body) flow
381
+
with Eio.Io _ -> ()
382
+
383
+
let run http ~clock ~net ~sw ~client_id ~client_secret ~scopes ?(port = 0)
384
+
?(on_url = default_on_url) ?(timeout = 120.0) () =
385
+
let socket, actual_port = listen_loopback ~sw ~net port in
386
+
let redirect_uri_str = Fmt.str "http://127.0.0.1:%d/callback" actual_port in
387
+
match Oauth.redirect_uri redirect_uri_str with
388
+
| Error (`Msg m) -> err_redirect m
389
+
| Ok redirect_uri ->
390
+
let state = Oauth.generate_state () in
391
+
let verifier = Oauth.generate_code_verifier () in
392
+
let challenge = Oauth.code_challenge Oauth.S256 verifier in
393
+
let url =
394
+
build_auth_url ~client_id ~redirect_uri ~state ~challenge ~scopes
395
+
in
396
+
on_url url;
397
+
let result = ref (Error err_callback_timeout) in
398
+
let finished = Eio.Condition.create () in
399
+
let done_ = ref false in
400
+
let finish r =
401
+
result := r;
402
+
done_ := true;
403
+
Eio.Condition.broadcast finished
404
+
in
405
+
Eio.Fiber.fork ~sw (fun () ->
406
+
Eio.Net.accept_fork socket ~sw
407
+
~on_error:(fun _ -> ())
408
+
(fun flow _addr ->
409
+
let line = try read_request flow with End_of_file -> "" in
410
+
let status, body, r =
411
+
classify_callback ~http ~clock ~client_id ~client_secret
412
+
~state ~verifier ~redirect_uri line
413
+
in
414
+
send_response flow ~status ~body;
415
+
finish r));
416
+
Eio.Fiber.fork ~sw (fun () ->
417
+
Eio.Time.sleep clock timeout;
418
+
if not !done_ then finish (Error err_callback_timeout));
419
+
let mutex = Eio.Mutex.create () in
420
+
Eio.Mutex.use_rw ~protect:true mutex (fun () ->
421
+
while not !done_ do
422
+
Eio.Condition.await_no_mutex finished
423
+
done);
424
+
!result
425
+
end
426
+
427
+
(* ── Persistence ─────────────────────────────────────────────────── *)
428
+
429
+
type snapshot = {
430
+
access_token : string;
431
+
refresh_token : string option;
432
+
expires_at : float option;
433
+
}
434
+
435
+
let snapshot_jsont =
436
+
Jsont.Object.map ~kind:"gauth_token"
437
+
(fun access_token refresh_token expires_at ->
438
+
{ access_token; refresh_token; expires_at })
439
+
|> Jsont.Object.mem "access_token" Jsont.string ~enc:(fun s -> s.access_token)
440
+
|> Jsont.Object.opt_mem "refresh_token" Jsont.string ~enc:(fun s ->
441
+
s.refresh_token)
442
+
|> Jsont.Object.opt_mem "expires_at" Jsont.number ~enc:(fun s -> s.expires_at)
443
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
444
+
445
+
let snapshot_of_token = function
446
+
| Oauth_token t ->
447
+
{
448
+
access_token = Oauth.Token.access_token t;
449
+
refresh_token = Oauth.Token.refresh_token t;
450
+
expires_at = Oauth.Token.expires_at t;
451
+
}
452
+
| Sa_token s ->
453
+
{
454
+
access_token = s.access_token;
455
+
refresh_token = None;
456
+
expires_at = s.expires_at;
457
+
}
458
+
459
+
let to_json t =
460
+
let s = snapshot_of_token t in
461
+
match Jsont_bytesrw.encode_string snapshot_jsont s with
462
+
| Ok s -> s
463
+
| Error e -> Fmt.failwith "Gauth.to_json: %s" e
464
+
465
+
let of_json http ~clock ~client_id ~client_secret body =
466
+
match Jsont_bytesrw.decode_string snapshot_jsont body with
467
+
| Error e -> Error (`Msg e)
468
+
| Ok s ->
469
+
let tok =
470
+
Oauth.Token.make http Oauth.Google ~client_id ~client_secret ~clock
471
+
~access_token:s.access_token ?refresh_token:s.refresh_token
472
+
?expires_at:s.expires_at ()
473
+
in
474
+
Ok (Oauth_token tok)
+128
lib/gauth.mli
+128
lib/gauth.mli
···
1
+
(** Authentication helpers for Google APIs.
2
+
3
+
Two flows are supported, mirroring the common access patterns for Google
4
+
APIs:
5
+
6
+
- {b Service account} — server-to-server authentication using a JSON
7
+
service-account key. Implements the JWT bearer grant
8
+
({{:https://datatracker.ietf.org/doc/html/rfc7523} RFC 7523}) as described
9
+
in
10
+
{{:https://developers.google.com/identity/protocols/oauth2/service-account}
11
+
Google's service-account OAuth guide}.
12
+
- {b Local OAuth flow} — interactive sign-in for CLI tools. Spins up a
13
+
localhost HTTP listener, redirects the user to Google's consent page,
14
+
captures the returned authorization code, and exchanges it for tokens.
15
+
16
+
Both flows return a {!token}, which provides a uniform [access] method that
17
+
transparently refreshes credentials near expiry. *)
18
+
19
+
type token
20
+
(** An authenticated Google access token with automatic refresh. *)
21
+
22
+
val access : token -> string
23
+
(** [access t] returns an unexpired access token, refreshing synchronously if
24
+
needed.
25
+
26
+
@raise Failure if refresh fails. *)
27
+
28
+
val try_access : token -> (string, [ `Msg of string ]) result
29
+
(** [try_access t] is the non-raising variant of {!access}. *)
30
+
31
+
(** {1 Service accounts} *)
32
+
33
+
module Service_account : sig
34
+
type key
35
+
(** A parsed Google service-account key. Holds the RSA private key, client
36
+
email, token URI, and optional key ID. *)
37
+
38
+
val of_json : string -> (key, [ `Msg of string ]) result
39
+
(** [of_json s] parses a Google service-account JSON key (the file downloaded
40
+
from the Google Cloud Console). *)
41
+
42
+
val of_file : _ Eio.Path.t -> (key, [ `Msg of string ]) result
43
+
(** [of_file path] reads and parses a service-account JSON file. *)
44
+
45
+
val client_email : key -> string
46
+
(** [client_email k] is the service-account's email address (also the JWT
47
+
[iss] claim). *)
48
+
49
+
val token :
50
+
Requests.t ->
51
+
clock:_ Eio.Time.clock ->
52
+
?subject:string ->
53
+
scopes:string list ->
54
+
key ->
55
+
(token, [ `Msg of string ]) result
56
+
(** [token http ~clock ?subject ~scopes key] performs the JWT bearer flow and
57
+
returns a refreshable token.
58
+
59
+
- [scopes] is the list of OAuth scope URLs, e.g.
60
+
[["https://www.googleapis.com/auth/documents"]].
61
+
- [subject] enables
62
+
{{:https://developers.google.com/identity/protocols/oauth2/service-account#delegatingauthority}
63
+
domain-wide delegation}: impersonate a Workspace user. Only usable when
64
+
the service-account is authorized for the target domain. *)
65
+
end
66
+
67
+
(** {1 Local OAuth flow (interactive)} *)
68
+
69
+
module Local_flow : sig
70
+
(** Interactive OAuth for CLI tools.
71
+
72
+
The flow:
73
+
+ A TCP listener is started on [http://127.0.0.1:\<port\>/].
74
+
+ The Google consent URL is produced and passed to [on_url]. The default
75
+
prints the URL and suggests opening it; override [on_url] to launch a
76
+
browser automatically.
77
+
+ The user authorizes in their browser; Google redirects to the localhost
78
+
listener with the authorization code.
79
+
+ The listener sends back an HTML confirmation page and hands the code to
80
+
the exchange. *)
81
+
82
+
val run :
83
+
Requests.t ->
84
+
clock:_ Eio.Time.clock ->
85
+
net:_ Eio.Net.t ->
86
+
sw:Eio.Switch.t ->
87
+
client_id:string ->
88
+
client_secret:string ->
89
+
scopes:string list ->
90
+
?port:int ->
91
+
?on_url:(string -> unit) ->
92
+
?timeout:float ->
93
+
unit ->
94
+
(token, [ `Msg of string ]) result
95
+
(** [run http ~clock ~net ~sw ~client_id ~client_secret ~scopes ?port ?on_url
96
+
?timeout ()] runs the interactive flow and returns a token on success.
97
+
98
+
- [port] defaults to [0] (let the OS assign an ephemeral port).
99
+
- [on_url] defaults to printing a clickable URL to stderr.
100
+
- [timeout] defaults to 120 seconds — how long to wait for the callback
101
+
before giving up. *)
102
+
end
103
+
104
+
(** {1 Persistence}
105
+
106
+
Serialize a token to JSON for CLI-friendly "login once, use many times"
107
+
workflows. The JSON format is:
108
+
{v
109
+
{
110
+
"access_token": "...",
111
+
"refresh_token": "...",
112
+
"expires_at": 1703001600.0
113
+
}
114
+
v} *)
115
+
116
+
val to_json : token -> string
117
+
(** [to_json t] serializes the current token state to JSON. *)
118
+
119
+
val of_json :
120
+
Requests.t ->
121
+
clock:_ Eio.Time.clock ->
122
+
client_id:string ->
123
+
client_secret:string ->
124
+
string ->
125
+
(token, [ `Msg of string ]) result
126
+
(** [of_json http ~clock ~client_id ~client_secret s] restores a token from JSON
127
+
produced by {!to_json}. [client_id] and [client_secret] are required so the
128
+
token can refresh itself. *)
+3
test/dune
+3
test/dune
+3
test/test.ml
+3
test/test.ml
+79
test/test_gauth.ml
+79
test/test_gauth.ml
···
1
+
(* Generate an RSA private key and serialize as a Google-style service-account
2
+
JSON blob. Tests that Service_account.of_json accepts it. *)
3
+
let synthetic_key ~email =
4
+
let priv = X509.Private_key.generate ~bits:2048 `RSA in
5
+
let pem = X509.Private_key.encode_pem priv in
6
+
let pem_escaped = String.concat "\\n" (String.split_on_char '\n' pem) in
7
+
Fmt.str
8
+
{|{"type":"service_account","project_id":"proj","private_key_id":"kid123","private_key":"%s","client_email":"%s","client_id":"123","token_uri":"https://oauth2.googleapis.com/token"}|}
9
+
pem_escaped email
10
+
11
+
let sa_of_json_ok () =
12
+
let json = synthetic_key ~email:"svc@proj.iam.gserviceaccount.com" in
13
+
match Gauth.Service_account.of_json json with
14
+
| Ok k ->
15
+
Alcotest.(check string)
16
+
"client_email" "svc@proj.iam.gserviceaccount.com"
17
+
(Gauth.Service_account.client_email k)
18
+
| Error (`Msg m) -> Alcotest.failf "unexpected error: %s" m
19
+
20
+
let sa_bad_type () =
21
+
let json = {|{"type":"user","client_email":"x","private_key":"..."}|} in
22
+
match Gauth.Service_account.of_json json with
23
+
| Ok _ -> Alcotest.fail "expected Error for non-service-account type"
24
+
| Error (`Msg _) -> ()
25
+
26
+
let sa_malformed () =
27
+
match Gauth.Service_account.of_json "not json" with
28
+
| Ok _ -> Alcotest.fail "expected Error for malformed JSON"
29
+
| Error (`Msg _) -> ()
30
+
31
+
let sa_missing_fields () =
32
+
let json = {|{"type":"service_account"}|} in
33
+
match Gauth.Service_account.of_json json with
34
+
| Ok _ -> Alcotest.fail "expected Error for missing fields"
35
+
| Error (`Msg _) -> ()
36
+
37
+
let with_env f =
38
+
Eio_main.run @@ fun env ->
39
+
Eio.Switch.run @@ fun sw ->
40
+
let http = Requests.v ~sw env in
41
+
let clock = Eio.Stdenv.clock env in
42
+
f ~http ~clock
43
+
44
+
let json_roundtrip () =
45
+
with_env @@ fun ~http ~clock ->
46
+
let future = Eio.Time.now clock +. 3600. in
47
+
let json =
48
+
Fmt.str {|{"access_token":"acc","refresh_token":"ref","expires_at":%f}|}
49
+
future
50
+
in
51
+
match
52
+
Gauth.of_json http ~clock ~client_id:"cid" ~client_secret:"csec" json
53
+
with
54
+
| Error (`Msg m) -> Alcotest.failf "of_json: %s" m
55
+
| Ok g -> (
56
+
let json' = Gauth.to_json g in
57
+
match
58
+
Gauth.of_json http ~clock ~client_id:"cid" ~client_secret:"csec" json'
59
+
with
60
+
| Error (`Msg m) -> Alcotest.failf "roundtrip of_json: %s" m
61
+
| Ok g' ->
62
+
Alcotest.(check string)
63
+
"access_token preserved" "acc"
64
+
(match Gauth.try_access g' with
65
+
| Ok s -> s
66
+
| Error (`Msg m) -> Alcotest.failf "try_access: %s" m))
67
+
68
+
let suite =
69
+
( "gauth",
70
+
[
71
+
Alcotest.test_case "service_account of_json ok" `Slow sa_of_json_ok;
72
+
Alcotest.test_case "service_account rejects non-sa type" `Quick
73
+
sa_bad_type;
74
+
Alcotest.test_case "service_account rejects malformed JSON" `Quick
75
+
sa_malformed;
76
+
Alcotest.test_case "service_account rejects missing fields" `Quick
77
+
sa_missing_fields;
78
+
Alcotest.test_case "to_json of_json roundtrip" `Quick json_roundtrip;
79
+
] )