User authentication and session management for web applications
Fix 5 auth/oauth/sqlite security bugs
1. Sqlite: silent data loss on corrupt DB — Store.v caught all exceptions
and fell back to Sqlite.v (which truncates). Now only catches Eio.Io
(file not found). Remove Sqlite.v; add Sqlite.open_ ~create flag.
2. Sign-out: now revokes server-side session via Store.delete_session.
Previously only cleared the browser cookie — copied sid stayed valid.
Changed to POST /auth/signout with header-based session lookup.
3. OAuth: authorization URL now includes response_type=code per RFC 6749.
4. OAuth: token exchange/refresh now uses application/x-www-form-urlencoded
per RFC 6749, not JSON. Removed JSON-body functions, added form_encode
helper and exchange_form_body/refresh_form_body returning strings.
5. Auth: callback now uses provider.userinfo_url instead of hardcoded
GitHub API. Added userinfo_url to Oauth.provider type. Google, GitLab,
and custom providers can now complete login.
+680
+4
auth.opam
+4
auth.opam
+335
lib/auth.ml
+335
lib/auth.ml
···
1
+
(** User authentication and session management. *)
2
+
3
+
open Http
4
+
5
+
let src = Logs.Src.create "auth" ~doc:"Auth"
6
+
7
+
module Log = (val Logs.src_log src : Logs.LOG)
8
+
9
+
(* ── Config ──────────────────────────────────────────────────────── *)
10
+
11
+
type config = {
12
+
oauth_provider : Oauth.provider;
13
+
client_id : string;
14
+
client_secret : string;
15
+
base_url : string;
16
+
cookie_secret : string;
17
+
http : Requests.t;
18
+
}
19
+
20
+
let config ~oauth_provider ~client_id ~client_secret ~base_url ~cookie_secret
21
+
~http =
22
+
{ oauth_provider; client_id; client_secret; base_url; cookie_secret; http }
23
+
24
+
(* ── Types ───────────────────────────────────────────────────────── *)
25
+
26
+
type user = {
27
+
id : int;
28
+
email : string;
29
+
name : string;
30
+
avatar_url : string;
31
+
created_at : float;
32
+
}
33
+
34
+
let pp_user ppf u = Fmt.pf ppf "user(%d, %s, %s)" u.id u.email u.name
35
+
36
+
type session = { token : string; user_id : int; expires_at : float }
37
+
38
+
let session_max_age = 30 * 24 * 3600 (* 30 days *)
39
+
let cookie_name = "sid"
40
+
41
+
(* ── Store ───────────────────────────────────────────────────────── *)
42
+
43
+
module Store = struct
44
+
type t = { db : Sqlite.t; sessions : Sqlite.Table.t }
45
+
46
+
let init_tables db =
47
+
Sqlite.create_table db
48
+
~sql:
49
+
"CREATE TABLE IF NOT EXISTS users (id INTEGER PRIMARY KEY, email TEXT \
50
+
NOT NULL, name TEXT NOT NULL DEFAULT '', avatar_url TEXT NOT NULL \
51
+
DEFAULT '', created_at REAL NOT NULL)";
52
+
Sqlite.create_table db
53
+
~sql:
54
+
"CREATE TABLE IF NOT EXISTS oauth_identities (id INTEGER PRIMARY KEY, \
55
+
user_id INTEGER NOT NULL, provider TEXT NOT NULL, provider_uid TEXT \
56
+
NOT NULL, access_token TEXT NOT NULL DEFAULT '')";
57
+
()
58
+
59
+
let v ~sw path =
60
+
let db = Sqlite.open_ ~sw ~create:true path in
61
+
init_tables db;
62
+
let sessions = Sqlite.Table.create db ~name:"sessions" in
63
+
{ db; sessions }
64
+
65
+
let decode_user (rowid : int64) (values : Sqlite.value list) : user option =
66
+
match values with
67
+
| [ _; Vtext email; Vtext name; Vtext avatar_url; Vfloat created_at ] ->
68
+
Some { id = Int64.to_int rowid; email; name; avatar_url; created_at }
69
+
| _ -> None
70
+
71
+
let find_user t user_id =
72
+
Sqlite.fold_table t.db "users" ~init:None ~f:(fun rowid values acc ->
73
+
if Int64.to_int rowid = user_id then decode_user rowid values else acc)
74
+
75
+
let find_user_by_provider t ~provider ~provider_uid =
76
+
(* Find the user_id from oauth_identities, then look up the user *)
77
+
let user_id =
78
+
Sqlite.fold_table t.db "oauth_identities" ~init:None
79
+
~f:(fun _rowid values acc ->
80
+
match values with
81
+
| [ _; Vint uid; Vtext p; Vtext puid; _ ]
82
+
when p = provider && puid = provider_uid ->
83
+
Some (Int64.to_int uid)
84
+
| _ -> acc)
85
+
in
86
+
match user_id with None -> None | Some uid -> find_user t uid
87
+
88
+
let create_user t ~email ~name ~avatar_url ~provider ~provider_uid
89
+
~access_token =
90
+
let now = Unix.gettimeofday () in
91
+
let user_rowid =
92
+
Sqlite.insert t.db ~table:"users"
93
+
[ Sqlite.Vnull; Vtext email; Vtext name; Vtext avatar_url; Vfloat now ]
94
+
in
95
+
let _identity_rowid =
96
+
Sqlite.insert t.db ~table:"oauth_identities"
97
+
[
98
+
Vnull;
99
+
Vint user_rowid;
100
+
Vtext provider;
101
+
Vtext provider_uid;
102
+
Vtext access_token;
103
+
]
104
+
in
105
+
Sqlite.sync t.db;
106
+
{ id = Int64.to_int user_rowid; email; name; avatar_url; created_at = now }
107
+
108
+
let create_session t ~user_id =
109
+
let token = Ohex.encode (Crypto_rng.generate 32) in
110
+
let expires_at = Unix.gettimeofday () +. float_of_int session_max_age in
111
+
let value = Fmt.str "%d:%.0f" user_id expires_at in
112
+
Sqlite.Table.put t.sessions token value;
113
+
{ token; user_id; expires_at }
114
+
115
+
let find_session t token =
116
+
match Sqlite.Table.find t.sessions token with
117
+
| None -> None
118
+
| Some value -> (
119
+
match String.split_on_char ':' value with
120
+
| [ uid_s; exp_s ] -> (
121
+
match (int_of_string_opt uid_s, float_of_string_opt exp_s) with
122
+
| Some user_id, Some expires_at ->
123
+
if Unix.gettimeofday () > expires_at then begin
124
+
Sqlite.Table.delete t.sessions token;
125
+
None
126
+
end
127
+
else Some { token; user_id; expires_at }
128
+
| _ -> None)
129
+
| _ -> None)
130
+
131
+
let delete_session t token = Sqlite.Table.delete t.sessions token
132
+
end
133
+
134
+
(* ── Cookie helpers ──────────────────────────────────────────────── *)
135
+
136
+
let set_cookie_header ~base_url token =
137
+
let secure = String.sub base_url 0 5 = "https" in
138
+
let flags =
139
+
Fmt.str "; Path=/; HttpOnly; SameSite=Lax; Max-Age=%d%s" session_max_age
140
+
(if secure then "; Secure" else "")
141
+
in
142
+
("Set-Cookie", Fmt.str "%s=%s%s" cookie_name token flags)
143
+
144
+
let clear_cookie_header () =
145
+
( "Set-Cookie",
146
+
Fmt.str "%s=; Path=/; HttpOnly; SameSite=Lax; Max-Age=0" cookie_name )
147
+
148
+
let extract_session_token (headers : Headers.t) =
149
+
match Headers.string "cookie" headers with
150
+
| None -> None
151
+
| Some cookie_str ->
152
+
(* Simple cookie parsing: find sid=<value> *)
153
+
let pairs = String.split_on_char ';' cookie_str in
154
+
List.find_map
155
+
(fun pair ->
156
+
let pair = String.trim pair in
157
+
match String.split_on_char '=' pair with
158
+
| [ name; value ] when String.trim name = cookie_name ->
159
+
Some (String.trim value)
160
+
| _ -> None)
161
+
pairs
162
+
163
+
(* ── Middleware ───────────────────────────────────────────────────── *)
164
+
165
+
let current_user _config store (req : Respond.post_request) =
166
+
match extract_session_token req.headers with
167
+
| None -> None
168
+
| Some token -> (
169
+
match Store.find_session store token with
170
+
| None -> None
171
+
| Some session -> Store.find_user store session.user_id)
172
+
173
+
let current_user_from_params _config store _params headers =
174
+
match extract_session_token headers with
175
+
| None -> None
176
+
| Some token -> (
177
+
match Store.find_session store token with
178
+
| None -> None
179
+
| Some session -> Store.find_user store session.user_id)
180
+
181
+
(* ── Provider user profile fetch ─────────────────────────────────── *)
182
+
183
+
type provider_user = {
184
+
uid : string; (* provider-specific unique ID *)
185
+
login : string;
186
+
email : string;
187
+
name : string;
188
+
avatar_url : string;
189
+
}
190
+
191
+
(* Generic userinfo: providers return different field names but all have
192
+
some form of id, name, email, avatar. We try common field names. *)
193
+
let provider_user_jsont =
194
+
Jsont.Object.map ~kind:"provider_user" (fun id login email name avatar_url ->
195
+
{
196
+
uid = (match id with i when i > 0 -> string_of_int i | _ -> login);
197
+
login;
198
+
email;
199
+
name;
200
+
avatar_url;
201
+
})
202
+
|> Jsont.Object.mem "id" Jsont.int ~dec_absent:0 ~enc:(fun _ -> 0)
203
+
|> Jsont.Object.mem "login" Jsont.string ~dec_absent:""
204
+
~enc:(fun (u : provider_user) -> u.login)
205
+
|> Jsont.Object.mem "email" Jsont.string ~dec_absent:""
206
+
~enc:(fun (u : provider_user) -> u.email)
207
+
|> Jsont.Object.mem "name" Jsont.string ~dec_absent:""
208
+
~enc:(fun (u : provider_user) -> u.name)
209
+
|> Jsont.Object.mem "avatar_url" Jsont.string ~dec_absent:""
210
+
~enc:(fun (u : provider_user) -> u.avatar_url)
211
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
212
+
213
+
let fetch_provider_user http ~userinfo_url ~access_token =
214
+
let headers =
215
+
Headers.empty
216
+
|> Headers.set `Authorization (Fmt.str "Bearer %s" access_token)
217
+
|> Headers.set `Accept "application/json"
218
+
in
219
+
let resp = Requests.get http userinfo_url ~headers in
220
+
let body = Requests.Response.text resp in
221
+
match Jsont_bytesrw.decode_string provider_user_jsont body with
222
+
| Ok user -> Ok user
223
+
| Error e -> Error e
224
+
225
+
(* ── Routes ──────────────────────────────────────────────────────── *)
226
+
227
+
(** GET /auth/signin — redirect to OAuth provider *)
228
+
let signin_route config _params =
229
+
let state = Oauth.generate_state () in
230
+
(* Sign the state for CSRF verification on callback *)
231
+
let signed_state = Csrf.sign_state ~secret:config.cookie_secret state in
232
+
let redirect_uri = config.base_url ^ "/auth/callback" in
233
+
let scope =
234
+
if config.oauth_provider.name = "github" then [ "user:email" ] else []
235
+
in
236
+
let url =
237
+
Oauth.authorization_url config.oauth_provider ~client_id:config.client_id
238
+
~redirect_uri ~state:signed_state ~scope
239
+
in
240
+
Respond.Response.redirect url
241
+
242
+
(** GET /auth/callback — exchange code, create/find user, set session *)
243
+
let callback_route config store params =
244
+
let code = List.assoc_opt "code" params in
245
+
let state = List.assoc_opt "state" params in
246
+
match (code, state) with
247
+
| None, _ | _, None ->
248
+
Log.warn (fun m -> m "callback: missing code or state");
249
+
Respond.Response.bad_request "Missing code or state"
250
+
| Some code, Some state -> (
251
+
(* Verify CSRF state *)
252
+
match Csrf.verify_state ~secret:config.cookie_secret state with
253
+
| None ->
254
+
Log.warn (fun m -> m "callback: invalid state (CSRF check failed)");
255
+
Respond.Response.bad_request "Invalid state"
256
+
| Some _original_state -> (
257
+
(* Exchange code for access token *)
258
+
let redirect_uri = config.base_url ^ "/auth/callback" in
259
+
let form_str =
260
+
Oauth.exchange_form_body ~client_id:config.client_id
261
+
~client_secret:config.client_secret ~code ~redirect_uri
262
+
in
263
+
let token_url = config.oauth_provider.token_url in
264
+
let headers =
265
+
Headers.of_list
266
+
[
267
+
("Content-Type", "application/x-www-form-urlencoded");
268
+
("Accept", "application/json");
269
+
]
270
+
in
271
+
let body = Requests.Body.text form_str in
272
+
let resp = Requests.post config.http token_url ~body ~headers in
273
+
let resp_body = Requests.Response.text resp in
274
+
match Oauth.parse_token_response resp_body with
275
+
| Error e ->
276
+
Log.err (fun m ->
277
+
m "callback: token exchange failed: %a"
278
+
Oauth.pp_parse_token_error e);
279
+
Respond.Response.internal_server_error "Token exchange failed"
280
+
| Ok token_resp -> (
281
+
(* Fetch user profile from provider *)
282
+
match
283
+
fetch_provider_user config.http
284
+
~userinfo_url:config.oauth_provider.userinfo_url
285
+
~access_token:token_resp.access_token
286
+
with
287
+
| Error e ->
288
+
Log.err (fun m -> m "callback: user fetch failed: %s" e);
289
+
Respond.Response.internal_server_error "User fetch failed"
290
+
| Ok pu ->
291
+
let provider = config.oauth_provider.name in
292
+
let provider_uid = pu.uid in
293
+
let email =
294
+
if pu.email <> "" then pu.email
295
+
else pu.login ^ "@" ^ provider
296
+
in
297
+
(* Find or create user *)
298
+
let user =
299
+
match
300
+
Store.find_user_by_provider store ~provider ~provider_uid
301
+
with
302
+
| Some u -> u
303
+
| None ->
304
+
Store.create_user store ~email ~name:pu.name
305
+
~avatar_url:pu.avatar_url ~provider ~provider_uid
306
+
~access_token:token_resp.access_token
307
+
in
308
+
(* Create session *)
309
+
let session = Store.create_session store ~user_id:user.id in
310
+
Log.info (fun m ->
311
+
m "callback: signed in user %d (%s)" user.id user.email);
312
+
let cookie =
313
+
set_cookie_header ~base_url:config.base_url session.token
314
+
in
315
+
Respond.Response.v ~status:302
316
+
~headers:[ ("Location", "/"); cookie ]
317
+
~content_type:"text/plain" "")))
318
+
319
+
(** POST /auth/signout — revoke session server-side, clear cookie, redirect *)
320
+
let signout_route _config store (req : Respond.post_request) =
321
+
(* Revoke the server-side session so copied tokens are invalidated *)
322
+
(match extract_session_token req.headers with
323
+
| Some token -> Store.delete_session store token
324
+
| None -> ());
325
+
let cookie = clear_cookie_header () in
326
+
Respond.Response.v ~status:302
327
+
~headers:[ ("Location", "/"); cookie ]
328
+
~content_type:"text/plain" ""
329
+
330
+
let routes config store =
331
+
[
332
+
Respond.get "/auth/signin" (signin_route config);
333
+
Respond.get "/auth/callback" (callback_route config store);
334
+
Respond.post "/auth/signout" (signout_route config store);
335
+
]
+115
lib/auth.mli
+115
lib/auth.mli
···
1
+
(** User authentication and session management for web applications.
2
+
3
+
Provides OAuth-based authentication, user management, and cookie-based
4
+
session handling. Ties together {!Oauth}, {!Sqlite}, and {!Csrf} into a
5
+
reusable auth flow.
6
+
7
+
{2 Quick Start}
8
+
9
+
{[
10
+
let store = Auth.Store.v ~sw db_path in
11
+
let config =
12
+
Auth.config ~oauth_provider:Oauth.Github.provider
13
+
~client_id:"xxx" ~client_secret:"yyy"
14
+
~base_url:"https://app.com" ~cookie_secret:"secret"
15
+
in
16
+
let routes = Auth.routes config store in
17
+
(* Add to your Respond routes *)
18
+
]} *)
19
+
20
+
open Http
21
+
22
+
(** {1 Configuration} *)
23
+
24
+
type config
25
+
(** Auth configuration: OAuth provider, client credentials, URLs, secrets. *)
26
+
27
+
val config :
28
+
oauth_provider:Oauth.provider ->
29
+
client_id:string ->
30
+
client_secret:string ->
31
+
base_url:string ->
32
+
cookie_secret:string ->
33
+
http:Requests.t ->
34
+
config
35
+
(** [config ~oauth_provider ~client_id ~client_secret ~base_url ~cookie_secret
36
+
~http] creates auth configuration.
37
+
38
+
@param base_url Public base URL (e.g. [https://run.space])
39
+
@param cookie_secret Secret for signing session cookies (32+ chars) *)
40
+
41
+
(** {1 Users} *)
42
+
43
+
type user = {
44
+
id : int;
45
+
email : string;
46
+
name : string;
47
+
avatar_url : string;
48
+
created_at : float;
49
+
}
50
+
(** A user account. *)
51
+
52
+
val pp_user : user Fmt.t
53
+
54
+
(** {1 Sessions} *)
55
+
56
+
type session = { token : string; user_id : int; expires_at : float }
57
+
(** A server-side session. *)
58
+
59
+
(** {1 Store} *)
60
+
61
+
module Store : sig
62
+
type t
63
+
(** User and session database. *)
64
+
65
+
val v : sw:Eio.Switch.t -> Eio.Fs.dir_ty Eio.Path.t -> t
66
+
(** [v ~sw path] opens or creates the auth database at [path]. *)
67
+
68
+
val find_user_by_provider :
69
+
t -> provider:string -> provider_uid:string -> user option
70
+
(** Find a user by OAuth provider identity. *)
71
+
72
+
val find_user : t -> int -> user option
73
+
(** Find a user by ID. *)
74
+
75
+
val create_user :
76
+
t ->
77
+
email:string ->
78
+
name:string ->
79
+
avatar_url:string ->
80
+
provider:string ->
81
+
provider_uid:string ->
82
+
access_token:string ->
83
+
user
84
+
(** Create a user and linked OAuth identity. Returns the new user. *)
85
+
86
+
val create_session : t -> user_id:int -> session
87
+
(** Create a session for a user. Returns the session with a random token.
88
+
Sessions expire after 30 days. *)
89
+
90
+
val find_session : t -> string -> session option
91
+
(** [find_session store token] looks up a session by token. Returns [None] if
92
+
not found or expired. *)
93
+
94
+
val delete_session : t -> string -> unit
95
+
(** [delete_session store token] revokes a session. *)
96
+
end
97
+
98
+
(** {1 Middleware} *)
99
+
100
+
val current_user : config -> Store.t -> Respond.post_request -> user option
101
+
(** [current_user config store req] extracts the session cookie from the request
102
+
and returns the authenticated user, or [None]. *)
103
+
104
+
val current_user_from_params :
105
+
config -> Store.t -> Respond.params -> Headers.t -> user option
106
+
(** Same as {!current_user} but takes params and headers directly (for GET
107
+
routes that need to check auth via cookie header). *)
108
+
109
+
(** {1 Routes} *)
110
+
111
+
val routes : config -> Store.t -> Respond.route list
112
+
(** [routes config store] returns auth routes:
113
+
- [GET /auth/signin] — redirect to OAuth provider
114
+
- [GET /auth/callback] — handle OAuth callback, create session
115
+
- [GET /auth/signout] — clear session, redirect to [/] *)
+16
lib/dune
+16
lib/dune
+4
test/dune
+4
test/dune
+4
test/test.ml
+4
test/test.ml
+200
test/test_auth.ml
+200
test/test_auth.ml
···
1
+
open Eio.Std
2
+
module Headers = Requests.Headers
3
+
module Response = Requests.Response
4
+
5
+
let contains str ~substring =
6
+
let len = String.length substring in
7
+
let rec go i =
8
+
if i + len > String.length str then false
9
+
else if String.sub str i len = substring then true
10
+
else go (i + 1)
11
+
in
12
+
go 0
13
+
14
+
let first_existing paths =
15
+
match List.find_opt Sys.file_exists paths with
16
+
| Some path -> path
17
+
| None ->
18
+
Alcotest.fail
19
+
(Fmt.str "missing test fixture, looked for one of: %s"
20
+
(String.concat ", " paths))
21
+
22
+
let read_file paths =
23
+
In_channel.with_open_bin (first_existing paths) In_channel.input_all
24
+
25
+
let next_port =
26
+
let port = ref 38080 in
27
+
fun () ->
28
+
let v = !port in
29
+
incr port;
30
+
v
31
+
32
+
let base_url port = Fmt.str "http://127.0.0.1:%d" port
33
+
34
+
let temp_db_path env name =
35
+
let cwd = Eio.Stdenv.cwd env in
36
+
let dir = Eio.Path.(cwd / "_build" / "test_auth") in
37
+
(try Eio.Path.mkdirs ~exists_ok:true ~perm:0o755 dir with Eio.Io _ -> ());
38
+
Eio.Path.(dir / Fmt.str "%s_%d.db" name (Random.int 1_000_000))
39
+
40
+
let start_server env ~sw ~port routes =
41
+
let root = Eio.Stdenv.cwd env in
42
+
Eio.Fiber.fork_daemon ~sw (fun () ->
43
+
Respond.run ~net:env#net ~port ~root routes);
44
+
Eio.Time.sleep env#clock 0.05
45
+
46
+
let requests_timeout = Requests.Timeout.v ~connect:0.2 ~read:0.2 ~total:0.3 ()
47
+
48
+
let test_store_v_rejects_invalid_database () =
49
+
Eio_main.run @@ fun env ->
50
+
let path = temp_db_path env "invalid" in
51
+
let garbage = "not a sqlite database" in
52
+
Eio.Path.save ~create:(`Or_truncate 0o644) path garbage;
53
+
let raised = ref false in
54
+
(try Eio.Switch.run @@ fun sw -> ignore (Auth.Store.v ~sw path)
55
+
with _ -> raised := true);
56
+
Alcotest.(check bool) "invalid db raises" true !raised;
57
+
Alcotest.(check string) "invalid db is preserved" garbage (Eio.Path.load path)
58
+
59
+
let test_signout_revokes_server_session () =
60
+
Eio_main.run @@ fun env ->
61
+
Eio.Switch.run @@ fun sw ->
62
+
let port = next_port () in
63
+
let http =
64
+
Requests.v ~sw ~follow_redirects:false ~timeout:requests_timeout env
65
+
in
66
+
let store = Auth.Store.v ~sw (temp_db_path env "signout") in
67
+
let config =
68
+
Auth.config ~oauth_provider:Oauth.Github.provider ~client_id:"client"
69
+
~client_secret:"secret" ~base_url:(base_url port)
70
+
~cookie_secret:"cookie-secret" ~http
71
+
in
72
+
let user =
73
+
Auth.Store.create_user store ~email:"user@example.com" ~name:"User"
74
+
~avatar_url:"https://example.com/avatar.png" ~provider:"github"
75
+
~provider_uid:"42" ~access_token:"token"
76
+
in
77
+
let session = Auth.Store.create_session store ~user_id:user.id in
78
+
start_server env ~sw ~port (Auth.routes config store);
79
+
let headers =
80
+
Headers.of_list [ ("Cookie", Fmt.str "sid=%s" session.token) ]
81
+
in
82
+
let resp = Requests.get http ~headers (base_url port ^ "/auth/signout") in
83
+
Alcotest.(check int)
84
+
"signout returns redirect" 302
85
+
(Response.status_code resp);
86
+
Alcotest.(check bool)
87
+
"session deleted on signout" true
88
+
(Option.is_none (Auth.Store.find_session store session.token))
89
+
90
+
let test_callback_uses_form_urlencoded_token_exchange () =
91
+
Eio_main.run @@ fun env ->
92
+
Eio.Switch.run @@ fun sw ->
93
+
let provider_port = next_port () in
94
+
let auth_port = next_port () in
95
+
let captured_headers = ref None in
96
+
let captured_body = ref None in
97
+
let token_routes =
98
+
[
99
+
Respond.post "/token" (fun req ->
100
+
captured_headers := Some req.headers;
101
+
captured_body := Some req.body;
102
+
Respond.Response.json {|{"access_token":"tok"}|});
103
+
]
104
+
in
105
+
start_server env ~sw ~port:provider_port token_routes;
106
+
let server_http =
107
+
Requests.v ~sw ~follow_redirects:false ~timeout:requests_timeout env
108
+
in
109
+
let client =
110
+
Requests.v ~sw ~follow_redirects:false ~timeout:requests_timeout env
111
+
in
112
+
let store = Auth.Store.v ~sw (temp_db_path env "callback") in
113
+
let provider =
114
+
{
115
+
Oauth.name = "google";
116
+
authorize_url = base_url provider_port ^ "/authorize";
117
+
token_url = base_url provider_port ^ "/token";
118
+
}
119
+
in
120
+
let config =
121
+
Auth.config ~oauth_provider:provider ~client_id:"client"
122
+
~client_secret:"secret" ~base_url:(base_url auth_port)
123
+
~cookie_secret:"cookie-secret" ~http:server_http
124
+
in
125
+
start_server env ~sw ~port:auth_port (Auth.routes config store);
126
+
let signin = Requests.get client (base_url auth_port ^ "/auth/signin") in
127
+
let location =
128
+
match Response.headers signin |> Headers.find `Location with
129
+
| Some location -> location
130
+
| None -> Alcotest.fail "signin route did not redirect"
131
+
in
132
+
let state =
133
+
match
134
+
Uri.of_string location |> fun uri -> Uri.get_query_param uri "state"
135
+
with
136
+
| Some state -> state
137
+
| None -> Alcotest.fail "signin redirect missing state"
138
+
in
139
+
ignore
140
+
(Requests.get client
141
+
(Fmt.str "%s/auth/callback?code=abc&state=%s" (base_url auth_port)
142
+
(Uri.pct_encode state)));
143
+
let headers =
144
+
match !captured_headers with
145
+
| Some headers -> headers
146
+
| None -> Alcotest.fail "token endpoint was not called"
147
+
in
148
+
let body =
149
+
match !captured_body with
150
+
| Some body -> body
151
+
| None -> Alcotest.fail "token endpoint body was not captured"
152
+
in
153
+
Alcotest.(check (option string))
154
+
"token exchange uses form content type"
155
+
(Some "application/x-www-form-urlencoded")
156
+
(Headers.find `Content_type headers);
157
+
Alcotest.(check bool)
158
+
"token exchange body is not JSON" false
159
+
(String.length body > 0 && body.[0] = '{');
160
+
Alcotest.(check bool)
161
+
"token exchange body includes authorization_code grant" true
162
+
(contains body ~substring:"grant_type=authorization_code")
163
+
164
+
let test_auth_source_is_not_hardwired_to_github () =
165
+
let source = read_file [ "lib/auth.ml"; "ocaml-auth/lib/auth.ml" ] in
166
+
Alcotest.(check bool)
167
+
"generic auth flow should not hardcode the GitHub profile endpoint" false
168
+
(contains source ~substring:"https://api.github.com/user")
169
+
170
+
let test_auth_opam_has_real_metadata () =
171
+
let opam = read_file [ "auth.opam"; "ocaml-auth/auth.opam" ] in
172
+
Alcotest.(check bool)
173
+
"auth.opam declares dependencies" true
174
+
(contains opam ~substring:"depends:");
175
+
Alcotest.(check bool)
176
+
"auth.opam declares a build recipe" true
177
+
(contains opam ~substring:"build:")
178
+
179
+
let test_library_name_avoids_top_level_auth_module () =
180
+
let dune = read_file [ "lib/dune"; "ocaml-auth/lib/dune" ] in
181
+
Alcotest.(check bool)
182
+
"library should not publish a top-level Auth module name" false
183
+
(contains dune ~substring:"(name auth)")
184
+
185
+
let suite =
186
+
( "auth",
187
+
[
188
+
Alcotest.test_case "store rejects invalid database" `Quick
189
+
test_store_v_rejects_invalid_database;
190
+
Alcotest.test_case "signout revokes session" `Quick
191
+
test_signout_revokes_server_session;
192
+
Alcotest.test_case "callback token exchange uses form encoding" `Quick
193
+
test_callback_uses_form_urlencoded_token_exchange;
194
+
Alcotest.test_case "source is not hardwired to github" `Quick
195
+
test_auth_source_is_not_hardwired_to_github;
196
+
Alcotest.test_case "auth.opam has real metadata" `Quick
197
+
test_auth_opam_has_real_metadata;
198
+
Alcotest.test_case "library name avoids top-level Auth module" `Quick
199
+
test_library_name_avoids_top_level_auth_module;
200
+
] )