OAuth 2.0 authorization and token exchange
oauth: split library + Flow + JWT client-auth
Splits oauth.ml into per-concept single-word files (encoding, provider,
redirect, pkce, state, auth, response, exchange, authz, par, flow, token,
userinfo, jws) and makes oauth.ml a thin facade that re-exports them so
the public Oauth.* API is unchanged.
In the same commit: Oauth.Flow ties state + PKCE + optional PAR + optional
DPoP (with RFC 9449 section 8 nonce-challenge retry) into begin_authz /
complete_authz / refresh_bound, and Oauth.Client_auth gets two more RFC
7523 variants:
- Client_auth.secret_jwt signs the client_assertion with HS256 keyed on
the client_secret. The secret never crosses the wire.
- Client_auth.private_key_jwt signs with a Dpop.key (ES256 or EdDSA),
reusing ocaml-dpop's primitives; Dpop exposes a new sign_message for
that purpose.
apply now takes ~aud (the endpoint URL) so the JWT variants can populate
the audience claim. Callers in exchange.ml / par.ml / flow.ml thread
it through.
11 new tests for Client_auth cover the form-field layout, HS256 signature
equality, kid embedding, EdDSA path, and ES256 signature round-trip
verification. 86 tests pass total.
+1353
-974
+81
lib/auth.ml
+81
lib/auth.ml
···
1
+
(* Client authentication at the OAuth token endpoint (RFC 6749 section 2.3,
2
+
RFC 7523 for the JWT variants). *)
3
+
4
+
type t =
5
+
| None of { client_id : string }
6
+
| Basic of { client_id : string; client_secret : string }
7
+
| Post of { client_id : string; client_secret : string }
8
+
| Secret_jwt of {
9
+
client_id : string;
10
+
client_secret : string;
11
+
kid : string option;
12
+
}
13
+
| Private_key_jwt of {
14
+
client_id : string;
15
+
key : Dpop.key;
16
+
kid : string option;
17
+
}
18
+
19
+
let none ~client_id = None { client_id }
20
+
let basic ~client_id ~client_secret = Basic { client_id; client_secret }
21
+
let post ~client_id ~client_secret = Post { client_id; client_secret }
22
+
23
+
let secret_jwt ~client_id ~client_secret ?kid () =
24
+
Secret_jwt { client_id; client_secret; kid }
25
+
26
+
let private_key_jwt ~client_id ~key ?kid () =
27
+
Private_key_jwt { client_id; key; kid }
28
+
29
+
let client_id = function
30
+
| None { client_id }
31
+
| Basic { client_id; _ }
32
+
| Post { client_id; _ }
33
+
| Secret_jwt { client_id; _ }
34
+
| Private_key_jwt { client_id; _ } ->
35
+
client_id
36
+
37
+
let jwt_bearer_assertion_type =
38
+
"urn:ietf:params:oauth:client-assertion-type:jwt-bearer"
39
+
40
+
(* [apply auth ~aud] yields [(form_fields, headers)] for a request to the
41
+
endpoint at URL [aud]. [aud] is the JWT audience claim for the JWT
42
+
variants (RFC 7523 section 3) and is ignored by the non-JWT variants.
43
+
[client_id] is always included in the body because several providers
44
+
require it in both the header and the form; putting it there is safe as
45
+
[client_id] is not a secret. *)
46
+
let apply t ~aud =
47
+
match t with
48
+
| None { client_id } -> ([ ("client_id", client_id) ], [])
49
+
| Post { client_id; client_secret } ->
50
+
([ ("client_id", client_id); ("client_secret", client_secret) ], [])
51
+
| Basic { client_id; client_secret } ->
52
+
(* RFC 6749 section 2.3.1: percent-encode both halves before joining by
53
+
':' to avoid ambiguity with secrets containing colons or non-ASCII. *)
54
+
let cred =
55
+
Printf.sprintf "%s:%s"
56
+
(Encoding.pct_encode client_id)
57
+
(Encoding.pct_encode client_secret)
58
+
in
59
+
let b64 = Base64.encode_exn cred in
60
+
([ ("client_id", client_id) ], [ ("Authorization", "Basic " ^ b64) ])
61
+
| Secret_jwt { client_id; client_secret; kid } ->
62
+
let assertion =
63
+
Jws.client_assertion ~key:(Jws.hs256 client_secret) ~client_id ~aud ?kid
64
+
()
65
+
in
66
+
( [
67
+
("client_id", client_id);
68
+
("client_assertion_type", jwt_bearer_assertion_type);
69
+
("client_assertion", assertion);
70
+
],
71
+
[] )
72
+
| Private_key_jwt { client_id; key; kid } ->
73
+
let assertion =
74
+
Jws.client_assertion ~key:(Jws.asym key) ~client_id ~aud ?kid ()
75
+
in
76
+
( [
77
+
("client_id", client_id);
78
+
("client_assertion_type", jwt_bearer_assertion_type);
79
+
("client_assertion", assertion);
80
+
],
81
+
[] )
+30
lib/authz.ml
+30
lib/authz.ml
···
1
+
(* Authorization URL builder (the non-PAR path). *)
2
+
3
+
let url provider ~client_id ~redirect_uri ~state ~scope ?code_challenge:cc
4
+
?code_challenge_method () =
5
+
let uri = Uri.of_string (Provider.authorize_url provider) in
6
+
let base_query =
7
+
[
8
+
("response_type", [ "code" ]);
9
+
("client_id", [ client_id ]);
10
+
("redirect_uri", [ Redirect.to_string redirect_uri ]);
11
+
("state", [ state ]);
12
+
]
13
+
in
14
+
let query =
15
+
match scope with
16
+
| [] -> base_query
17
+
| lst -> ("scope", [ String.concat " " lst ]) :: base_query
18
+
in
19
+
let query =
20
+
match cc with
21
+
| None -> query
22
+
| Some challenge ->
23
+
let method_ =
24
+
match code_challenge_method with Some m -> m | None -> Pkce.S256
25
+
in
26
+
("code_challenge", [ challenge ])
27
+
:: ("code_challenge_method", [ Pkce.method_to_string method_ ])
28
+
:: query
29
+
in
30
+
Uri.with_query uri query |> Uri.to_string
+23
lib/encoding.ml
+23
lib/encoding.ml
···
1
+
(* Form and URL encoding helpers shared across token-endpoint, PAR, and
2
+
authorization-URL construction. *)
3
+
4
+
let pct_encode s =
5
+
let buf = Buffer.create (String.length s) in
6
+
String.iter
7
+
(fun c ->
8
+
match c with
9
+
| 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '-' | '_' | '.' | '~' ->
10
+
Buffer.add_char buf c
11
+
| _ -> Buffer.add_string buf (Fmt.str "%%%02X" (Char.code c)))
12
+
s;
13
+
Buffer.contents buf
14
+
15
+
let form_encode params =
16
+
String.concat "&"
17
+
(List.map (fun (k, v) -> pct_encode k ^ "=" ^ pct_encode v) params)
18
+
19
+
let base_token_headers =
20
+
[
21
+
("Content-Type", "application/x-www-form-urlencoded");
22
+
("Accept", "application/json");
23
+
]
+105
lib/exchange.ml
+105
lib/exchange.ml
···
1
+
(* Token endpoint exchanges: code -> access_token, refresh_token ->
2
+
access_token. Plus DPoP-aware POST with RFC 9449 nonce-challenge retry. *)
3
+
4
+
let src = Logs.Src.create "oauth.exchange" ~doc:"OAuth token endpoint"
5
+
6
+
module Log = (val Logs.src_log src : Logs.LOG)
7
+
8
+
let exchange_form_body ~client_auth ~aud ~code ~redirect_uri ?code_verifier () =
9
+
let auth_fields, auth_headers = Auth.apply client_auth ~aud in
10
+
let grant =
11
+
[
12
+
("grant_type", "authorization_code");
13
+
("code", code);
14
+
("redirect_uri", Redirect.to_string redirect_uri);
15
+
]
16
+
in
17
+
let extras =
18
+
match code_verifier with None -> [] | Some v -> [ ("code_verifier", v) ]
19
+
in
20
+
(Encoding.form_encode (auth_fields @ grant @ extras), auth_headers)
21
+
22
+
let refresh_form_body ~client_auth ~aud ~refresh_token =
23
+
let auth_fields, auth_headers = Auth.apply client_auth ~aud in
24
+
let body =
25
+
Encoding.form_encode
26
+
(auth_fields
27
+
@ [ ("grant_type", "refresh_token"); ("refresh_token", refresh_token) ])
28
+
in
29
+
(body, auth_headers)
30
+
31
+
let post_token_endpoint http provider ~extra_headers form_str =
32
+
if not (Requests.verify_tls http) then
33
+
invalid_arg
34
+
"Oauth: Requests.t handle must have TLS certificate verification enabled";
35
+
let url = Provider.token_url provider in
36
+
let body = Requests.Body.text form_str in
37
+
let headers =
38
+
Http.Headers.of_list (Encoding.base_token_headers @ extra_headers)
39
+
in
40
+
let resp = Requests.post http url ~body ~headers in
41
+
let status = Requests.Response.status_code resp in
42
+
if status < 200 || status >= 300 then begin
43
+
Log.warn (fun m -> m "Token endpoint returned HTTP %d" status);
44
+
Error (Response.Http_error status)
45
+
end
46
+
else Response.parse (Requests.Response.text resp)
47
+
48
+
let exchange_code http provider ~client_auth ~code ~redirect_uri ?code_verifier
49
+
() =
50
+
let form_str, extra_headers =
51
+
exchange_form_body ~client_auth
52
+
~aud:(Provider.token_url provider)
53
+
~code ~redirect_uri ?code_verifier ()
54
+
in
55
+
post_token_endpoint http provider ~extra_headers form_str
56
+
57
+
let refresh_token http provider ~client_auth ~refresh_token =
58
+
let form_str, extra_headers =
59
+
refresh_form_body ~client_auth
60
+
~aud:(Provider.token_url provider)
61
+
~refresh_token
62
+
in
63
+
post_token_endpoint http provider ~extra_headers form_str
64
+
65
+
(* Strip query and fragment from a URL for the DPoP htu claim. Dpop.proof
66
+
already strips them, but doing it here too keeps the actual request
67
+
target and the claim aligned even if Dpop.proof's behaviour changes. *)
68
+
let htu_of_url url =
69
+
let u = Uri.of_string url in
70
+
Uri.with_query (Uri.with_fragment u None) [] |> Uri.to_string
71
+
72
+
(* POST a form body with an optional DPoP proof. On a [DPoP-Nonce] challenge
73
+
(RFC 9449 section 8) the request is retried once with the nonce embedded
74
+
in the proof. Returns the response body on 2xx, or an error status. *)
75
+
let post_form ?dpop_key ~htm url http ~extra_headers form_str =
76
+
if not (Requests.verify_tls http) then
77
+
invalid_arg
78
+
"Oauth: Requests.t handle must have TLS certificate verification enabled";
79
+
let htu = htu_of_url url in
80
+
let make_headers ?nonce () =
81
+
let dpop_hdr =
82
+
match dpop_key with
83
+
| None -> []
84
+
| Some k -> [ ("DPoP", Dpop.proof k ~htm ~htu ?nonce ()) ]
85
+
in
86
+
Http.Headers.of_list (Encoding.base_token_headers @ extra_headers @ dpop_hdr)
87
+
in
88
+
let send headers =
89
+
let body = Requests.Body.text form_str in
90
+
Requests.post http url ~body ~headers
91
+
in
92
+
let resp = send (make_headers ()) in
93
+
let status = Requests.Response.status_code resp in
94
+
if status >= 200 && status < 300 then Ok (Requests.Response.text resp)
95
+
else
96
+
match (dpop_key, Requests.Response.header_string "DPoP-Nonce" resp) with
97
+
| Some _, Some nonce ->
98
+
Log.info (fun m -> m "Retrying %s with DPoP nonce" url);
99
+
let resp = send (make_headers ~nonce ()) in
100
+
let status = Requests.Response.status_code resp in
101
+
if status >= 200 && status < 300 then Ok (Requests.Response.text resp)
102
+
else Error status
103
+
| _ ->
104
+
Log.warn (fun m -> m "Token endpoint returned HTTP %d" status);
105
+
Error status
+87
lib/flow.ml
+87
lib/flow.ml
···
1
+
(* High-level code flow: state + PKCE + optional PAR + optional DPoP with
2
+
nonce-challenge retry (RFC 9449 section 8). *)
3
+
4
+
type ctx = {
5
+
state : string;
6
+
code_verifier : Pkce.verifier;
7
+
redirect_uri : Redirect.t;
8
+
}
9
+
10
+
let state c = c.state
11
+
let code_verifier c = c.code_verifier
12
+
13
+
type error = Par_error of Par.error | Token_error of Response.error
14
+
15
+
let pp_error fmt = function
16
+
| Par_error e -> Fmt.pf fmt "PAR: %a" Par.pp_error e
17
+
| Token_error e -> Fmt.pf fmt "token: %a" Response.pp_error e
18
+
19
+
let begin_authz http provider ~client_auth ~redirect_uri ~scope ?dpop_key
20
+
?use_par () =
21
+
let state = State.generate () in
22
+
let verifier = Pkce.generate_verifier () in
23
+
let challenge = Pkce.challenge Pkce.S256 verifier in
24
+
let ctx = { state; code_verifier = verifier; redirect_uri } in
25
+
let par_available = Provider.par_endpoint provider <> None in
26
+
let do_par = match use_par with Some b -> b | None -> par_available in
27
+
if do_par then
28
+
let dpop_proof =
29
+
match dpop_key with
30
+
| None -> None
31
+
| Some k ->
32
+
let htu =
33
+
match Provider.par_endpoint provider with
34
+
| Some u -> Exchange.htu_of_url u
35
+
| None -> ""
36
+
in
37
+
Some (Dpop.proof k ~htm:"POST" ~htu ())
38
+
in
39
+
match
40
+
Par.push http provider ~client_auth ~redirect_uri ~state ~scope
41
+
~code_challenge:challenge ~code_challenge_method:Pkce.S256 ?dpop_proof
42
+
()
43
+
with
44
+
| Error e -> Error (Par_error e)
45
+
| Ok pr ->
46
+
let client_id = Auth.client_id client_auth in
47
+
let url =
48
+
Par.authorization_url provider ~client_id ~request_uri:pr.request_uri
49
+
in
50
+
Ok (url, ctx)
51
+
else
52
+
let client_id = Auth.client_id client_auth in
53
+
let url =
54
+
Authz.url provider ~client_id ~redirect_uri ~state ~scope
55
+
~code_challenge:challenge ~code_challenge_method:Pkce.S256 ()
56
+
in
57
+
Ok (url, ctx)
58
+
59
+
let complete_authz http provider ~client_auth ~ctx ~returned_state ~code
60
+
?dpop_key () =
61
+
if not (State.validate ~expected:ctx.state ~actual:returned_state) then
62
+
Error (Token_error (Response.Http_error 400))
63
+
else
64
+
let url = Provider.token_url provider in
65
+
let form_str, extra_headers =
66
+
Exchange.exchange_form_body ~client_auth ~aud:url ~code
67
+
~redirect_uri:ctx.redirect_uri ~code_verifier:ctx.code_verifier ()
68
+
in
69
+
match
70
+
Exchange.post_form ?dpop_key ~htm:"POST" url http ~extra_headers form_str
71
+
with
72
+
| Error status -> Error (Token_error (Response.Http_error status))
73
+
| Ok body -> (
74
+
match Response.parse body with
75
+
| Ok _ as ok -> ok
76
+
| Error e -> Error (Token_error e))
77
+
78
+
let refresh_bound http provider ~client_auth ~refresh_token ?dpop_key () =
79
+
let url = Provider.token_url provider in
80
+
let form_str, extra_headers =
81
+
Exchange.refresh_form_body ~client_auth ~aud:url ~refresh_token
82
+
in
83
+
match
84
+
Exchange.post_form ?dpop_key ~htm:"POST" url http ~extra_headers form_str
85
+
with
86
+
| Error status -> Error (Response.Http_error status)
87
+
| Ok body -> Response.parse body
+59
lib/jws.ml
+59
lib/jws.ml
···
1
+
(* Minimal JWS signing for RFC 7523 client JWT assertions. Only the three
2
+
algorithms actually used by OAuth client authentication: HS256 (keyed
3
+
with the client_secret), ES256, and EdDSA. The last two delegate to
4
+
ocaml-dpop's primitives so clients can share a key between DPoP proofs
5
+
and client assertions. *)
6
+
7
+
type key = Hs256 of string | Asym of Dpop.key
8
+
9
+
let hs256 secret = Hs256 secret
10
+
let asym k = Asym k
11
+
12
+
let alg = function
13
+
| Hs256 _ -> "HS256"
14
+
| Asym k -> (
15
+
match Dpop.alg k with Dpop.ES256 -> "ES256" | Dpop.EdDSA -> "EdDSA")
16
+
17
+
let b64url s = Base64.encode_exn ~pad:false ~alphabet:Base64.uri_safe_alphabet s
18
+
let jstring s = Json.Value.string s
19
+
let jint n = Json.Value.int n
20
+
let jmem k v = Json.Value.member (Json.Value.name k) v
21
+
let jobject ms = Json.Value.object' ms
22
+
let json_to_string v = Json.to_string Json.Codec.Value.t v
23
+
24
+
(* JWS protected header in lexicographic member order. *)
25
+
let make_header ~alg ?kid () =
26
+
let base = [ jmem "alg" (jstring alg) ] in
27
+
let base =
28
+
match kid with None -> base | Some k -> base @ [ jmem "kid" (jstring k) ]
29
+
in
30
+
let base = base @ [ jmem "typ" (jstring "JWT") ] in
31
+
json_to_string (jobject base)
32
+
33
+
let sign_bytes key msg =
34
+
match key with
35
+
| Hs256 secret ->
36
+
Digestif.SHA256.(hmac_string ~key:secret msg |> to_raw_string)
37
+
| Asym k -> Dpop.sign_message k msg
38
+
39
+
(* RFC 7523 section 3 client assertion. Lexicographic claim order. *)
40
+
let client_assertion ~key ~client_id ~aud ?kid ?(ttl = 60) () =
41
+
let now = int_of_float (Unix.time ()) in
42
+
let jti = b64url (Crypto_rng.generate 16) in
43
+
let header = make_header ~alg:(alg key) ?kid () in
44
+
let payload =
45
+
json_to_string
46
+
(jobject
47
+
[
48
+
jmem "aud" (jstring aud);
49
+
jmem "exp" (jint (now + ttl));
50
+
jmem "iat" (jint now);
51
+
jmem "iss" (jstring client_id);
52
+
jmem "jti" (jstring jti);
53
+
jmem "sub" (jstring client_id);
54
+
])
55
+
in
56
+
let h = b64url header in
57
+
let p = b64url payload in
58
+
let sig_bytes = sign_bytes key (h ^ "." ^ p) in
59
+
h ^ "." ^ p ^ "." ^ b64url sig_bytes
+51
-954
lib/oauth.ml
+51
-954
lib/oauth.ml
···
1
1
(** OAuth 2.0 authorization and token exchange. *)
2
2
3
-
let src = Logs.Src.create "oauth" ~doc:"OAuth 2.0 helpers"
4
-
5
-
module Log = (val Logs.src_log src : Logs.LOG)
6
-
7
-
(* -- Providers ----------------------------------------------------- *)
3
+
(* Provider *)
8
4
9
-
type provider = Github | Google | Gitlab | Custom of custom_provider
5
+
type provider = Provider.t =
6
+
| Github
7
+
| Google
8
+
| Gitlab
9
+
| Custom of custom_provider
10
10
11
-
and custom_provider = {
11
+
and custom_provider = Provider.custom = {
12
12
name : string;
13
13
authorize_url : string;
14
14
token_url : string;
···
17
17
par_endpoint : string option;
18
18
}
19
19
20
-
(* Sanitize a string for use as a URL path segment per RFC 3986 section 3.3:
21
-
lowercase, keep only unreserved chars [a-z0-9-], collapse runs of
22
-
dashes, strip leading/trailing dashes. Non-ASCII bytes (UTF-8) are
23
-
treated as separators (slugified), not percent-encoded, to keep
24
-
routes readable. Falls back to "custom" if the result is empty. *)
25
-
let path_safe s =
26
-
let len = String.length s in
27
-
let buf = Buffer.create len in
28
-
let prev_dash = ref true in
29
-
for i = 0 to len - 1 do
30
-
match Char.lowercase_ascii s.[i] with
31
-
| ('a' .. 'z' | '0' .. '9') as c ->
32
-
Buffer.add_char buf c;
33
-
prev_dash := false
34
-
| _ ->
35
-
if not !prev_dash then Buffer.add_char buf '-';
36
-
prev_dash := true
37
-
done;
38
-
let result = Buffer.contents buf in
39
-
let rlen = String.length result in
40
-
let result =
41
-
if rlen > 0 && result.[rlen - 1] = '-' then String.sub result 0 (rlen - 1)
42
-
else result
43
-
in
44
-
if result = "" then "custom" else result
45
-
46
-
let builtin_slugs = [ "github"; "google"; "gitlab" ]
47
-
48
-
let require_https label url =
49
-
let uri = Uri.of_string url in
50
-
match Uri.scheme uri with
51
-
| Some "https" ->
52
-
if Uri.host uri = None then
53
-
Error (`Msg (Fmt.str "%s has no host: %s" label url))
54
-
else Ok ()
55
-
| Some scheme ->
56
-
Error (`Msg (Fmt.str "%s must use HTTPS, got %s://: %s" label scheme url))
57
-
| None ->
58
-
Error (`Msg (Fmt.str "%s must be an absolute HTTPS URL: %s" label url))
59
-
60
-
let is_valid_json_field_name s =
61
-
String.length s > 0
62
-
&& String.for_all
63
-
(fun c ->
64
-
(c >= 'a' && c <= 'z')
65
-
|| (c >= 'A' && c <= 'Z')
66
-
|| (c >= '0' && c <= '9')
67
-
|| c = '_' || c = '-')
68
-
s
69
-
70
-
let custom_provider ~name ~authorize_url ~token_url ~userinfo_url ~uid_field
71
-
?par_endpoint () =
72
-
if not (is_valid_json_field_name uid_field) then
73
-
Error
74
-
(`Msg
75
-
(Fmt.str
76
-
"uid_field must be a non-empty alphanumeric JSON field name, got %S"
77
-
uid_field))
78
-
else
79
-
let slug = path_safe name in
80
-
if List.mem slug builtin_slugs then
81
-
Error
82
-
(`Msg
83
-
(Fmt.str
84
-
"custom provider name %S produces slug %S which collides with \
85
-
built-in provider"
86
-
name slug))
87
-
else
88
-
let par_check =
89
-
match par_endpoint with
90
-
| None -> Ok ()
91
-
| Some url -> require_https "par_endpoint" url
92
-
in
93
-
match
94
-
( require_https "authorize_url" authorize_url,
95
-
require_https "token_url" token_url,
96
-
require_https "userinfo_url" userinfo_url,
97
-
par_check )
98
-
with
99
-
| Ok (), Ok (), Ok (), Ok () ->
100
-
Ok
101
-
{
102
-
name;
103
-
authorize_url;
104
-
token_url;
105
-
userinfo_url;
106
-
uid_field;
107
-
par_endpoint;
108
-
}
109
-
| (Error _ as e), _, _, _
110
-
| _, (Error _ as e), _, _
111
-
| _, _, (Error _ as e), _
112
-
| _, _, _, (Error _ as e) ->
113
-
e
114
-
115
-
let provider_name = function
116
-
| Github -> "github"
117
-
| Google -> "google"
118
-
| Gitlab -> "gitlab"
119
-
| Custom c -> c.name
120
-
121
-
let provider_slug = function
122
-
| Github -> "github"
123
-
| Google -> "google"
124
-
| Gitlab -> "gitlab"
125
-
| Custom c -> path_safe c.name
126
-
127
-
let authorize_url = function
128
-
| Github -> "https://github.com/login/oauth/authorize"
129
-
| Google -> "https://accounts.google.com/o/oauth2/v2/auth"
130
-
| Gitlab -> "https://gitlab.com/oauth/authorize"
131
-
| Custom c -> c.authorize_url
132
-
133
-
let token_url = function
134
-
| Github -> "https://github.com/login/oauth/access_token"
135
-
| Google -> "https://oauth2.googleapis.com/token"
136
-
| Gitlab -> "https://gitlab.com/oauth/token"
137
-
| Custom c -> c.token_url
138
-
139
-
let userinfo_url = function
140
-
| Github -> "https://api.github.com/user"
141
-
| Google -> "https://www.googleapis.com/oauth2/v3/userinfo"
142
-
| Gitlab -> "https://gitlab.com/api/v4/user"
143
-
| Custom c -> c.userinfo_url
144
-
145
-
let default_scope = function
146
-
| Github -> [ "user:email" ]
147
-
| Google -> [ "openid"; "email"; "profile" ]
148
-
| Gitlab -> [ "read_user" ]
149
-
| Custom _ -> []
150
-
151
-
(* -- Redirect URI ------------------------------------------------- *)
152
-
153
-
type redirect_uri = string
154
-
155
-
let is_loopback_host = function
156
-
| "localhost" | "127.0.0.1" | "::1" | "[::1]" -> true
157
-
| _ -> false
158
-
159
-
let is_loopback_http uri =
160
-
match Uri.scheme uri with
161
-
| Some "http" -> (
162
-
match Uri.host uri with Some h -> is_loopback_host h | None -> false)
163
-
| _ -> false
164
-
165
-
let redirect_uri s =
166
-
let uri = Uri.of_string s in
167
-
match Uri.scheme uri with
168
-
| None -> Error (`Msg "redirect_uri must be an absolute URI with a scheme")
169
-
| Some "https" -> (
170
-
match Uri.fragment uri with
171
-
| Some _ ->
172
-
Error
173
-
(`Msg
174
-
"redirect_uri must not contain a fragment (RFC 6749 section \
175
-
3.1.2)")
176
-
| None -> Ok s)
177
-
| Some "http" when is_loopback_http uri -> (
178
-
match Uri.fragment uri with
179
-
| Some _ ->
180
-
Error
181
-
(`Msg
182
-
"redirect_uri must not contain a fragment (RFC 6749 section \
183
-
3.1.2)")
184
-
| None -> Ok s)
185
-
| Some "http" ->
186
-
Error
187
-
(`Msg
188
-
"redirect_uri must use HTTPS (http:// is only allowed for localhost)")
189
-
| Some scheme ->
190
-
Error (`Msg (Fmt.str "redirect_uri must use HTTPS, got %s://" scheme))
191
-
192
-
let redirect_uri_to_string s = s
193
-
194
-
(* -- JSON helpers -------------------------------------------------- *)
20
+
let custom_provider = Provider.custom_provider
21
+
let provider_name = Provider.name
22
+
let provider_slug = Provider.slug
23
+
let authorize_url = Provider.authorize_url
24
+
let token_url = Provider.token_url
25
+
let userinfo_url = Provider.userinfo_url
26
+
let default_scope = Provider.default_scope
195
27
196
-
let decode codec s = Json.of_string codec s
28
+
(* Redirect URI *)
197
29
198
-
(* -- CSRF State --------------------------------------------------- *)
30
+
type redirect_uri = Redirect.t
199
31
200
-
let generate_state () = Ohex.encode (Crypto_rng.generate 32)
32
+
let redirect_uri = Redirect.validate
33
+
let redirect_uri_to_string = Redirect.to_string
201
34
202
-
let validate_state ~expected ~actual =
203
-
String.length expected > 0 && Eqaf.equal expected actual
35
+
(* CSRF state *)
204
36
205
-
(* -- PKCE (RFC 7636) ----------------------------------------------- *)
37
+
let generate_state = State.generate
38
+
let validate_state = State.validate
206
39
207
-
type challenge_method = S256 | Plain
208
-
type code_verifier = string
40
+
(* PKCE *)
209
41
210
-
(* Base64url encoding per RFC 4648 section 5, no padding. *)
211
-
let base64url_encode_no_pad s =
212
-
let b64 = Base64.encode_exn ~pad:false ~alphabet:Base64.uri_safe_alphabet s in
213
-
b64
42
+
type challenge_method = Pkce.method_ = S256 | Plain
43
+
type code_verifier = Pkce.verifier
214
44
215
-
let is_unreserved c =
216
-
(c >= 'A' && c <= 'Z')
217
-
|| (c >= 'a' && c <= 'z')
218
-
|| (c >= '0' && c <= '9')
219
-
|| c = '-' || c = '.' || c = '_' || c = '~'
45
+
let code_verifier_of_string = Pkce.verifier_of_string
46
+
let code_verifier_to_string = Pkce.verifier_to_string
47
+
let generate_code_verifier = Pkce.generate_verifier
48
+
let code_challenge = Pkce.challenge
220
49
221
-
let code_verifier_of_string s =
222
-
let len = String.length s in
223
-
if len < 43 || len > 128 then
224
-
Error (`Msg (Fmt.str "code_verifier must be 43-128 characters, got %d" len))
225
-
else if not (String.for_all is_unreserved s) then
226
-
Error (`Msg "code_verifier contains characters outside [A-Za-z0-9._~-]")
227
-
else Ok s
50
+
(* Authorization URL *)
228
51
229
-
let code_verifier_to_string s = s
52
+
let authorization_url = Authz.url
230
53
231
-
let generate_code_verifier () =
232
-
(* 32 random bytes -> 43 base64url chars (RFC 7636 section 4.1) *)
233
-
base64url_encode_no_pad (Crypto_rng.generate 32)
54
+
(* Client authentication *)
234
55
235
-
let code_challenge method_ verifier =
236
-
match method_ with
237
-
| Plain -> verifier
238
-
| S256 ->
239
-
(* BASE64URL(SHA256(ASCII(code_verifier))) per RFC 7636 section 4.2 *)
240
-
let hash = Digestif.SHA256.(digest_string verifier |> to_raw_string) in
241
-
base64url_encode_no_pad hash
56
+
module Client_auth = Auth
242
57
243
-
let challenge_method_to_string = function S256 -> "S256" | Plain -> "plain"
58
+
(* Token response *)
244
59
245
-
(* -- Authorization URL --------------------------------------------- *)
246
-
247
-
let authorization_url provider ~client_id ~redirect_uri ~state ~scope
248
-
?code_challenge:cc ?code_challenge_method () =
249
-
let uri = Uri.of_string (authorize_url provider) in
250
-
let base_query =
251
-
[
252
-
("response_type", [ "code" ]);
253
-
("client_id", [ client_id ]);
254
-
("redirect_uri", [ redirect_uri_to_string redirect_uri ]);
255
-
("state", [ state ]);
256
-
]
257
-
in
258
-
let query =
259
-
match scope with
260
-
| [] -> base_query
261
-
| lst -> ("scope", [ String.concat " " lst ]) :: base_query
262
-
in
263
-
let query =
264
-
match cc with
265
-
| None -> query
266
-
| Some challenge ->
267
-
let method_ =
268
-
match code_challenge_method with Some m -> m | None -> S256
269
-
in
270
-
("code_challenge", [ challenge ])
271
-
:: ("code_challenge_method", [ challenge_method_to_string method_ ])
272
-
:: query
273
-
in
274
-
Uri.with_query uri query |> Uri.to_string
275
-
276
-
(* -- URL / form encoding ------------------------------------------- *)
277
-
278
-
(* RFC 3986 unreserved set. Shared by the authorization URL builder, the
279
-
token-endpoint form body, and Basic-auth credential encoding (RFC 6749
280
-
section 2.3.1 says credentials use application/x-www-form-urlencoded, which is
281
-
this same set on the byte level). *)
282
-
let pct_encode s =
283
-
let buf = Buffer.create (String.length s) in
284
-
String.iter
285
-
(fun c ->
286
-
match c with
287
-
| 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '-' | '_' | '.' | '~' ->
288
-
Buffer.add_char buf c
289
-
| _ -> Buffer.add_string buf (Fmt.str "%%%02X" (Char.code c)))
290
-
s;
291
-
Buffer.contents buf
292
-
293
-
let form_encode params =
294
-
String.concat "&"
295
-
(List.map (fun (k, v) -> pct_encode k ^ "=" ^ pct_encode v) params)
296
-
297
-
(* -- Client Authentication ----------------------------------------- *)
298
-
299
-
module Client_auth = struct
300
-
type t =
301
-
| None of { client_id : string }
302
-
| Basic of { client_id : string; client_secret : string }
303
-
| Post of { client_id : string; client_secret : string }
304
-
305
-
let none ~client_id = None { client_id }
306
-
let basic ~client_id ~client_secret = Basic { client_id; client_secret }
307
-
let post ~client_id ~client_secret = Post { client_id; client_secret }
308
-
309
-
let client_id = function
310
-
| None { client_id } | Basic { client_id; _ } | Post { client_id; _ } ->
311
-
client_id
312
-
313
-
(* [apply auth] yields [(form_fields, headers)] for a token-endpoint
314
-
request. Callers append grant-type-specific fields (e.g. [code],
315
-
[refresh_token]) to [form_fields] before form-encoding. [client_id] is
316
-
always included in the body because several providers require it in
317
-
both the header and the form; putting it there is safe as [client_id]
318
-
is not a secret (RFC 6749 section 2.3.1). *)
319
-
let apply = function
320
-
| None { client_id } -> ([ ("client_id", client_id) ], [])
321
-
| Post { client_id; client_secret } ->
322
-
([ ("client_id", client_id); ("client_secret", client_secret) ], [])
323
-
| Basic { client_id; client_secret } ->
324
-
(* RFC 6749 section 2.3.1: percent-encode both halves before joining by ':'
325
-
to avoid ambiguity with secrets containing colons or non-ASCII. *)
326
-
let cred =
327
-
Printf.sprintf "%s:%s" (pct_encode client_id)
328
-
(pct_encode client_secret)
329
-
in
330
-
let b64 = Base64.encode_exn cred in
331
-
([ ("client_id", client_id) ], [ ("Authorization", "Basic " ^ b64) ])
332
-
end
333
-
334
-
let client_auth_apply = Client_auth.apply
335
-
336
-
(* -- Token Exchange ------------------------------------------------ *)
337
-
338
-
let exchange_form_body ~client_auth ~code ~redirect_uri ?code_verifier () =
339
-
let auth_fields, auth_headers = client_auth_apply client_auth in
340
-
let grant =
341
-
[
342
-
("grant_type", "authorization_code");
343
-
("code", code);
344
-
("redirect_uri", redirect_uri_to_string redirect_uri);
345
-
]
346
-
in
347
-
let extras =
348
-
match code_verifier with None -> [] | Some v -> [ ("code_verifier", v) ]
349
-
in
350
-
(form_encode (auth_fields @ grant @ extras), auth_headers)
351
-
352
-
(* -- Token Response ------------------------------------------------ *)
353
-
354
-
type token_response = {
60
+
type token_response = Response.t = {
355
61
access_token : string;
356
62
expires_in : int option;
357
63
refresh_token : string option;
358
64
refresh_token_expires_in : int option;
359
65
}
360
66
361
-
type raw_token_response = {
362
-
access_token : string;
363
-
token_type : string option;
364
-
expires_in : int option;
365
-
refresh_token : string option;
366
-
refresh_token_expires_in : int option;
367
-
}
368
-
369
-
let raw_token_response_jsont =
370
-
let open Json.Codec in
371
-
Object.map ~kind:"token_response"
372
-
(fun
373
-
access_token
374
-
token_type
375
-
expires_in
376
-
refresh_token
377
-
refresh_token_expires_in
378
-
->
379
-
{
380
-
access_token;
381
-
token_type;
382
-
expires_in;
383
-
refresh_token;
384
-
refresh_token_expires_in;
385
-
})
386
-
|> Object.member "access_token" string ~enc:(fun t -> t.access_token)
387
-
|> Object.opt_member "token_type" string ~enc:(fun t -> t.token_type)
388
-
|> Object.opt_member "expires_in" int ~enc:(fun t -> t.expires_in)
389
-
|> Object.opt_member "refresh_token" string ~enc:(fun t -> t.refresh_token)
390
-
|> Object.opt_member "refresh_token_expires_in" int ~enc:(fun t ->
391
-
t.refresh_token_expires_in)
392
-
|> Object.skip_unknown |> Object.seal
393
-
394
-
type parse_token_error =
67
+
type parse_token_error = Response.error =
395
68
| Invalid_json
396
69
| Missing_access_token
397
70
| Invalid_token_format
398
71
| Unsupported_token_type of string
399
72
| Http_error of int
400
73
401
-
let pp_parse_token_error fmt = function
402
-
| Invalid_json -> Fmt.pf fmt "Invalid JSON"
403
-
| Missing_access_token -> Fmt.pf fmt "Missing access_token field"
404
-
| Invalid_token_format -> Fmt.pf fmt "Invalid token format"
405
-
| Unsupported_token_type t ->
406
-
Fmt.pf fmt "Unsupported token_type %S (only Bearer is supported)" t
407
-
| Http_error status -> Fmt.pf fmt "HTTP error %d from token endpoint" status
74
+
let pp_parse_token_error = Response.pp_error
75
+
let parse_token_response = Response.parse
408
76
409
-
let has_substring ~sub s =
410
-
let len = String.length sub in
411
-
let rec loop i =
412
-
if i + len > String.length s then false
413
-
else if String.sub s i len = sub then true
414
-
else loop (i + 1)
415
-
in
416
-
loop 0
77
+
(* Token exchange *)
417
78
418
-
let classify_token_error body e =
419
-
let e = Json.Error.to_string e in
420
-
match decode Json.Codec.Value.t body with
421
-
| Error _ -> Invalid_json
422
-
| Ok _ ->
423
-
if
424
-
has_substring ~sub:"Missing member" e
425
-
&& has_substring ~sub:"access_token" e
426
-
then Missing_access_token
427
-
else Invalid_token_format
79
+
let exchange_code = Exchange.exchange_code
80
+
let refresh_token = Exchange.refresh_token
428
81
429
-
let is_bearer = function
430
-
| None -> true (* GitHub omits token_type; default is Bearer *)
431
-
| Some s -> String.lowercase_ascii s = "bearer"
82
+
(* PAR *)
432
83
433
-
let parse_token_response body =
434
-
match decode raw_token_response_jsont body with
435
-
| Ok t ->
436
-
if t.access_token = "" then begin
437
-
Log.warn (fun m -> m "Token parse failed: empty access_token");
438
-
Error Missing_access_token
439
-
end
440
-
else if not (is_bearer t.token_type) then begin
441
-
let tt = Option.get t.token_type in
442
-
Log.warn (fun m -> m "Token parse failed: unsupported token_type %S" tt);
443
-
Error (Unsupported_token_type tt)
444
-
end
445
-
else
446
-
Ok
447
-
{
448
-
access_token = t.access_token;
449
-
expires_in = t.expires_in;
450
-
refresh_token = t.refresh_token;
451
-
refresh_token_expires_in = t.refresh_token_expires_in;
452
-
}
453
-
| Error e ->
454
-
let err = classify_token_error body e in
455
-
Log.warn (fun m -> m "Token parse failed: %a" pp_parse_token_error err);
456
-
Error err
84
+
module Par = Par
457
85
458
-
(* -- Token Refresh ------------------------------------------------- *)
459
-
460
-
let refresh_form_body ~client_auth ~refresh_token =
461
-
let auth_fields, auth_headers = client_auth_apply client_auth in
462
-
let body =
463
-
form_encode
464
-
(auth_fields
465
-
@ [ ("grant_type", "refresh_token"); ("refresh_token", refresh_token) ])
466
-
in
467
-
(body, auth_headers)
468
-
469
-
let base_token_headers =
470
-
[
471
-
("Content-Type", "application/x-www-form-urlencoded");
472
-
("Accept", "application/json");
473
-
]
86
+
(* High-level flow *)
474
87
475
-
let post_token_endpoint http provider ~extra_headers form_str =
476
-
if not (Requests.verify_tls http) then
477
-
invalid_arg
478
-
"Oauth: Requests.t handle must have TLS certificate verification enabled";
479
-
let url = token_url provider in
480
-
let body = Requests.Body.text form_str in
481
-
let headers = Http.Headers.of_list (base_token_headers @ extra_headers) in
482
-
let resp = Requests.post http url ~body ~headers in
483
-
let status = Requests.Response.status_code resp in
484
-
if status < 200 || status >= 300 then begin
485
-
Log.warn (fun m -> m "Token endpoint returned HTTP %d" status);
486
-
Error (Http_error status)
487
-
end
488
-
else parse_token_response (Requests.Response.text resp)
88
+
module Flow = Flow
489
89
490
-
let exchange_code http provider ~client_auth ~code ~redirect_uri ?code_verifier
491
-
() =
492
-
let form_str, extra_headers =
493
-
exchange_form_body ~client_auth ~code ~redirect_uri ?code_verifier ()
494
-
in
495
-
post_token_endpoint http provider ~extra_headers form_str
90
+
(* Token lifecycle *)
496
91
497
-
let refresh_token http provider ~client_auth ~refresh_token =
498
-
let form_str, extra_headers = refresh_form_body ~client_auth ~refresh_token in
499
-
post_token_endpoint http provider ~extra_headers form_str
92
+
module Token = Token
500
93
501
-
(* -- Pushed Authorization Requests (RFC 9126) --------------------- *)
94
+
(* Userinfo *)
502
95
503
-
let par_endpoint_of = function
504
-
| Github | Google | Gitlab -> None
505
-
| Custom c -> c.par_endpoint
506
-
507
-
module Par = struct
508
-
type response = { request_uri : string; expires_in : int }
509
-
510
-
type error =
511
-
| No_par_endpoint
512
-
| Http_error of int
513
-
| Invalid_json
514
-
| Missing_request_uri
515
-
| Invalid_expires_in
516
-
517
-
let pp_error fmt = function
518
-
| No_par_endpoint -> Fmt.pf fmt "provider has no PAR endpoint"
519
-
| Http_error code -> Fmt.pf fmt "PAR endpoint returned HTTP %d" code
520
-
| Invalid_json -> Fmt.pf fmt "Invalid JSON"
521
-
| Missing_request_uri -> Fmt.pf fmt "Missing request_uri field"
522
-
| Invalid_expires_in -> Fmt.pf fmt "Missing or invalid expires_in field"
523
-
524
-
type raw = { request_uri : string; expires_in : int option }
525
-
526
-
let raw_jsont =
527
-
let open Json.Codec in
528
-
Object.map ~kind:"par_response" (fun request_uri expires_in ->
529
-
{ request_uri; expires_in })
530
-
|> Object.member "request_uri" string ~dec_absent:"" ~enc:(fun r ->
531
-
r.request_uri)
532
-
|> Object.opt_member "expires_in" int ~enc:(fun r -> r.expires_in)
533
-
|> Object.skip_unknown |> Object.seal
534
-
535
-
let parse_response body =
536
-
match decode raw_jsont body with
537
-
| Error _ -> Error Invalid_json
538
-
| Ok { request_uri = ""; _ } -> Error Missing_request_uri
539
-
| Ok { expires_in = None; _ } -> Error Invalid_expires_in
540
-
| Ok { request_uri; expires_in = Some secs } ->
541
-
Ok ({ request_uri; expires_in = secs } : response)
542
-
543
-
(* Same authorization parameters the non-PAR [authorization_url] would have
544
-
added to the query string, minus [client_id] which Client_auth carries. *)
545
-
let authz_fields ~redirect_uri ~state ~scope ?code_challenge
546
-
?code_challenge_method () =
547
-
let base =
548
-
[
549
-
("response_type", "code");
550
-
("redirect_uri", redirect_uri_to_string redirect_uri);
551
-
("state", state);
552
-
]
553
-
in
554
-
let base =
555
-
match scope with
556
-
| [] -> base
557
-
| lst -> base @ [ ("scope", String.concat " " lst) ]
558
-
in
559
-
match code_challenge with
560
-
| None -> base
561
-
| Some cc ->
562
-
let method_ =
563
-
match code_challenge_method with Some m -> m | None -> S256
564
-
in
565
-
base
566
-
@ [
567
-
("code_challenge", cc);
568
-
("code_challenge_method", challenge_method_to_string method_);
569
-
]
570
-
571
-
let push http provider ~client_auth ~redirect_uri ~state ~scope
572
-
?code_challenge ?code_challenge_method ?dpop_proof () =
573
-
match par_endpoint_of provider with
574
-
| None -> Error No_par_endpoint
575
-
| Some url ->
576
-
if not (Requests.verify_tls http) then
577
-
invalid_arg
578
-
"Oauth.Par.push: Requests.t handle must have TLS certificate \
579
-
verification enabled";
580
-
let auth_fields, auth_headers = client_auth_apply client_auth in
581
-
let fields =
582
-
auth_fields
583
-
@ authz_fields ~redirect_uri ~state ~scope ?code_challenge
584
-
?code_challenge_method ()
585
-
in
586
-
let form_str = form_encode fields in
587
-
let dpop_headers =
588
-
match dpop_proof with None -> [] | Some p -> [ ("DPoP", p) ]
589
-
in
590
-
let headers =
591
-
Http.Headers.of_list (base_token_headers @ auth_headers @ dpop_headers)
592
-
in
593
-
let body = Requests.Body.text form_str in
594
-
let resp = Requests.post http url ~body ~headers in
595
-
let status = Requests.Response.status_code resp in
596
-
if status < 200 || status >= 300 then begin
597
-
Log.warn (fun m -> m "PAR endpoint returned HTTP %d" status);
598
-
Error (Http_error status)
599
-
end
600
-
else parse_response (Requests.Response.text resp)
601
-
602
-
let authorization_url provider ~client_id ~request_uri =
603
-
let uri = Uri.of_string (authorize_url provider) in
604
-
let q =
605
-
[ ("client_id", [ client_id ]); ("request_uri", [ request_uri ]) ]
606
-
in
607
-
Uri.with_query uri q |> Uri.to_string
608
-
end
609
-
610
-
(* -- DPoP-aware token endpoint POST (nonce retry) ----------------- *)
611
-
612
-
(* Strip query and fragment from a URL for the DPoP htu claim. Dpop.proof
613
-
already strips them, but we do it here too so the [htu] we pass to it
614
-
matches the actual request target even if Dpop.proof ever changes. *)
615
-
let htu_of_url url =
616
-
let u = Uri.of_string url in
617
-
Uri.with_query (Uri.with_fragment u None) [] |> Uri.to_string
618
-
619
-
let post_form ?dpop_key ~htm url http ~extra_headers form_str =
620
-
if not (Requests.verify_tls http) then
621
-
invalid_arg
622
-
"Oauth: Requests.t handle must have TLS certificate verification enabled";
623
-
let htu = htu_of_url url in
624
-
let make_headers ?nonce () =
625
-
let dpop_hdr =
626
-
match dpop_key with
627
-
| None -> []
628
-
| Some k -> [ ("DPoP", Dpop.proof k ~htm ~htu ?nonce ()) ]
629
-
in
630
-
Http.Headers.of_list (base_token_headers @ extra_headers @ dpop_hdr)
631
-
in
632
-
let send headers =
633
-
let body = Requests.Body.text form_str in
634
-
Requests.post http url ~body ~headers
635
-
in
636
-
let resp = send (make_headers ()) in
637
-
let status = Requests.Response.status_code resp in
638
-
if status >= 200 && status < 300 then Ok (Requests.Response.text resp)
639
-
else
640
-
(* RFC 9449 section 8: retry once if the server demands a DPoP nonce. *)
641
-
match (dpop_key, Requests.Response.header_string "DPoP-Nonce" resp) with
642
-
| Some _, Some nonce ->
643
-
Log.info (fun m -> m "Retrying request to %s with DPoP nonce" url);
644
-
let resp = send (make_headers ~nonce ()) in
645
-
let status = Requests.Response.status_code resp in
646
-
if status >= 200 && status < 300 then Ok (Requests.Response.text resp)
647
-
else Error status
648
-
| _ ->
649
-
Log.warn (fun m -> m "Token endpoint returned HTTP %d" status);
650
-
Error status
651
-
652
-
(* -- Flow (RFC 6749 + RFC 7636 + RFC 9126 + RFC 9449) ------------- *)
653
-
654
-
module Flow = struct
655
-
type ctx = {
656
-
state : string;
657
-
code_verifier : code_verifier;
658
-
redirect_uri : redirect_uri;
659
-
}
660
-
661
-
let state c = c.state
662
-
let code_verifier c = c.code_verifier
663
-
664
-
type error = Par_error of Par.error | Token_error of parse_token_error
665
-
666
-
let pp_error fmt = function
667
-
| Par_error e -> Fmt.pf fmt "PAR: %a" Par.pp_error e
668
-
| Token_error e -> Fmt.pf fmt "token: %a" pp_parse_token_error e
669
-
670
-
let begin_authz http provider ~client_auth ~redirect_uri ~scope ?dpop_key
671
-
?use_par () =
672
-
let state = generate_state () in
673
-
let verifier = generate_code_verifier () in
674
-
let challenge = code_challenge S256 verifier in
675
-
let ctx = { state; code_verifier = verifier; redirect_uri } in
676
-
let par_available = par_endpoint_of provider <> None in
677
-
let do_par = match use_par with Some b -> b | None -> par_available in
678
-
if do_par then
679
-
let dpop_proof =
680
-
match dpop_key with
681
-
| None -> None
682
-
| Some k ->
683
-
let htu =
684
-
match par_endpoint_of provider with
685
-
| Some u -> htu_of_url u
686
-
| None -> ""
687
-
in
688
-
Some (Dpop.proof k ~htm:"POST" ~htu ())
689
-
in
690
-
match
691
-
Par.push http provider ~client_auth ~redirect_uri ~state ~scope
692
-
~code_challenge:challenge ~code_challenge_method:S256 ?dpop_proof ()
693
-
with
694
-
| Error e -> Error (Par_error e)
695
-
| Ok pr ->
696
-
let client_id = Client_auth.client_id client_auth in
697
-
let url =
698
-
Par.authorization_url provider ~client_id
699
-
~request_uri:pr.request_uri
700
-
in
701
-
Ok (url, ctx)
702
-
else
703
-
let client_id = Client_auth.client_id client_auth in
704
-
let url =
705
-
authorization_url provider ~client_id ~redirect_uri ~state ~scope
706
-
~code_challenge:challenge ~code_challenge_method:S256 ()
707
-
in
708
-
Ok (url, ctx)
709
-
710
-
let complete_authz http provider ~client_auth ~ctx ~returned_state ~code
711
-
?dpop_key () =
712
-
if not (validate_state ~expected:ctx.state ~actual:returned_state) then
713
-
Error (Token_error (Http_error 400))
714
-
else
715
-
let form_str, extra_headers =
716
-
exchange_form_body ~client_auth ~code ~redirect_uri:ctx.redirect_uri
717
-
~code_verifier:ctx.code_verifier ()
718
-
in
719
-
let url = token_url provider in
720
-
match
721
-
post_form ?dpop_key ~htm:"POST" url http ~extra_headers form_str
722
-
with
723
-
| Error status -> Error (Token_error (Http_error status))
724
-
| Ok body -> (
725
-
match parse_token_response body with
726
-
| Ok _ as ok -> ok
727
-
| Error e -> Error (Token_error e))
728
-
729
-
let refresh_bound http provider ~client_auth ~refresh_token ?dpop_key () =
730
-
let form_str, extra_headers =
731
-
refresh_form_body ~client_auth ~refresh_token
732
-
in
733
-
let url = token_url provider in
734
-
match post_form ?dpop_key ~htm:"POST" url http ~extra_headers form_str with
735
-
| Error status -> Error (Http_error status)
736
-
| Ok body -> parse_token_response body
737
-
end
738
-
739
-
(* -- Token Lifecycle ----------------------------------------------- *)
740
-
741
-
module Token = struct
742
-
(* Refresh when the access token is within this many seconds of expiry.
743
-
Passage uses the same 5-minute threshold; we use 60s to minimize
744
-
refreshes for short-lived API calls while still tolerating NTP skew
745
-
and request latency. *)
746
-
let refresh_threshold = 60.0
747
-
748
-
type state = {
749
-
access_token : string;
750
-
refresh_token : string option;
751
-
expires_at : float option;
752
-
}
753
-
754
-
type t = {
755
-
http : Requests.t;
756
-
provider : provider;
757
-
client_auth : Client_auth.t;
758
-
clock : float Eio.Time.clock_ty Eio.Resource.t;
759
-
mutex : Eio.Mutex.t;
760
-
mutable state : state;
761
-
}
762
-
763
-
let make http provider ~client_auth ~clock ~access_token ?refresh_token
764
-
?expires_at () =
765
-
{
766
-
http;
767
-
provider;
768
-
client_auth;
769
-
clock :> float Eio.Time.clock_ty Eio.Resource.t;
770
-
mutex = Eio.Mutex.create ();
771
-
state = { access_token; refresh_token; expires_at };
772
-
}
773
-
774
-
let of_response http provider ~client_auth ~clock (tr : token_response) =
775
-
let now = Eio.Time.now clock in
776
-
let expires_at =
777
-
Option.map (fun d -> now +. float_of_int d) tr.expires_in
778
-
in
779
-
make http provider ~client_auth ~clock ~access_token:tr.access_token
780
-
?refresh_token:tr.refresh_token ?expires_at ()
781
-
782
-
let stale_state ~clock ~threshold s =
783
-
match s.expires_at with
784
-
| None -> false
785
-
| Some exp -> Eio.Time.now clock +. threshold >= exp
786
-
787
-
let do_refresh t =
788
-
match t.state.refresh_token with
789
-
| None ->
790
-
Log.warn (fun m ->
791
-
m "Token refresh requested but no refresh_token available");
792
-
Error (Http_error 401)
793
-
| Some rt -> (
794
-
match
795
-
refresh_token t.http t.provider ~client_auth:t.client_auth
796
-
~refresh_token:rt
797
-
with
798
-
| Error _ as e -> e
799
-
| Ok (tr : token_response) ->
800
-
let now = Eio.Time.now t.clock in
801
-
let expires_at =
802
-
Option.map (fun d -> now +. float_of_int d) tr.expires_in
803
-
in
804
-
(* Google and others often omit refresh_token on refresh
805
-
responses; retain the existing one. *)
806
-
let new_refresh =
807
-
match tr.refresh_token with
808
-
| Some _ as v -> v
809
-
| None -> t.state.refresh_token
810
-
in
811
-
t.state <-
812
-
{
813
-
access_token = tr.access_token;
814
-
refresh_token = new_refresh;
815
-
expires_at;
816
-
};
817
-
Ok tr.access_token)
818
-
819
-
let try_access t =
820
-
Eio.Mutex.use_rw ~protect:true t.mutex (fun () ->
821
-
if stale_state ~clock:t.clock ~threshold:refresh_threshold t.state then
822
-
do_refresh t
823
-
else Ok t.state.access_token)
824
-
825
-
let access t =
826
-
match try_access t with
827
-
| Ok s -> s
828
-
| Error e -> Fmt.failwith "Oauth.Token.access: %a" pp_parse_token_error e
829
-
830
-
let force_refresh t =
831
-
Eio.Mutex.use_rw ~protect:true t.mutex (fun () -> do_refresh t)
832
-
833
-
let access_token t = Eio.Mutex.use_ro t.mutex (fun () -> t.state.access_token)
834
-
835
-
let refresh_token t =
836
-
Eio.Mutex.use_ro t.mutex (fun () -> t.state.refresh_token)
837
-
838
-
let expires_at t = Eio.Mutex.use_ro t.mutex (fun () -> t.state.expires_at)
839
-
840
-
let needs_refresh t =
841
-
Eio.Mutex.use_ro t.mutex (fun () ->
842
-
stale_state ~clock:t.clock ~threshold:refresh_threshold t.state)
843
-
844
-
let is_expired t =
845
-
Eio.Mutex.use_ro t.mutex (fun () ->
846
-
stale_state ~clock:t.clock ~threshold:0.0 t.state)
847
-
end
848
-
849
-
(* -- Userinfo Parsing ---------------------------------------------- *)
850
-
851
-
type userinfo = {
96
+
type userinfo = Userinfo.t = {
852
97
uid : string;
853
98
login : string;
854
99
email : string option;
···
857
102
avatar_url : string;
858
103
}
859
104
860
-
let uid u = u.uid
861
-
let login u = u.login
862
-
let email_verified u = u.email_verified
863
-
let name (u : userinfo) = u.name
864
-
let avatar_url u = u.avatar_url
865
-
866
-
(* Convert empty or missing strings to None for optional fields. *)
867
-
let non_empty s = if s = "" then None else Some s
868
-
let opt_to_string = function Some s -> s | None -> ""
869
-
870
-
(* GitHub: {"id":123,"login":"octocat","email":"...","name":"...","avatar_url":"..."}
871
-
email is intentionally dropped -- /user returns the public email which is
872
-
unverified. Use parse_github_emails with /user/emails for the verified one. *)
873
-
let github_userinfo_jsont =
874
-
let open Json.Codec in
875
-
Object.map ~kind:"github_userinfo"
876
-
(fun id login _email name avatar_url : userinfo ->
877
-
{
878
-
uid = string_of_int id;
879
-
login;
880
-
email = None;
881
-
email_verified = false;
882
-
name;
883
-
avatar_url;
884
-
})
885
-
|> Object.member "id" int ~enc:(fun _ -> 0)
886
-
|> Object.member "login" string ~dec_absent:"" ~enc:login
887
-
|> Object.member "email" string ~dec_absent:"" ~enc:(fun u ->
888
-
opt_to_string u.email)
889
-
|> Object.member "name" string ~dec_absent:"" ~enc:name
890
-
|> Object.member "avatar_url" string ~dec_absent:"" ~enc:avatar_url
891
-
|> Object.skip_unknown |> Object.seal
892
-
893
-
(* Google OIDC: {"sub":"118...","email":"...","email_verified":true,"name":"...","picture":"..."}
894
-
Only populate email when email_verified is true. Track the verified flag. *)
895
-
let google_userinfo_jsont =
896
-
let open Json.Codec in
897
-
Object.map ~kind:"google_userinfo"
898
-
(fun sub email email_verified name picture : userinfo ->
899
-
let verified = email_verified = Some true in
900
-
let email = if verified then non_empty email else None in
901
-
{
902
-
uid = sub;
903
-
login = "";
904
-
email;
905
-
email_verified = verified;
906
-
name;
907
-
avatar_url = picture;
908
-
})
909
-
|> Object.member "sub" string ~enc:uid
910
-
|> Object.member "email" string ~dec_absent:"" ~enc:(fun u ->
911
-
opt_to_string u.email)
912
-
|> Object.opt_member "email_verified" bool ~enc:(fun u ->
913
-
Some (email_verified u))
914
-
|> Object.member "name" string ~dec_absent:"" ~enc:name
915
-
|> Object.member "picture" string ~dec_absent:"" ~enc:avatar_url
916
-
|> Object.skip_unknown |> Object.seal
917
-
918
-
(* GitLab: {"id":123,"username":"john","email":"...","confirmed_at":"2024-...",
919
-
"name":"...","avatar_url":"..."}
920
-
confirmed_at is non-null when the user has verified their email. *)
921
-
let gitlab_userinfo_jsont =
922
-
let open Json.Codec in
923
-
Object.map ~kind:"gitlab_userinfo"
924
-
(fun id username email confirmed_at name avatar_url : userinfo ->
925
-
let email_verified = Option.is_some confirmed_at in
926
-
{
927
-
uid = string_of_int id;
928
-
login = username;
929
-
email = (if email_verified then non_empty email else None);
930
-
email_verified;
931
-
name;
932
-
avatar_url;
933
-
})
934
-
|> Object.member "id" int ~enc:(fun _ -> 0)
935
-
|> Object.member "username" string ~dec_absent:"" ~enc:login
936
-
|> Object.member "email" string ~dec_absent:"" ~enc:(fun u ->
937
-
opt_to_string u.email)
938
-
|> Object.opt_member "confirmed_at" string ~enc:(fun u ->
939
-
if email_verified u then Some "" else None)
940
-
|> Object.member "name" string ~dec_absent:"" ~enc:name
941
-
|> Object.member "avatar_url" string ~dec_absent:"" ~enc:avatar_url
942
-
|> Object.skip_unknown |> Object.seal
943
-
944
-
(* Custom: uid extracted from the configured uid_field. Parses the standard
945
-
OIDC email_verified claim (Section 5.1) when present. *)
946
-
let custom_userinfo_jsont ~uid_field =
947
-
let open Json.Codec in
948
-
Object.map ~kind:"custom_userinfo"
949
-
(fun uid email email_verified name : userinfo ->
950
-
let verified = email_verified = Some true in
951
-
let email = if verified then non_empty email else None in
952
-
{
953
-
uid;
954
-
login = "";
955
-
email;
956
-
email_verified = verified;
957
-
name;
958
-
avatar_url = "";
959
-
})
960
-
|> Object.member uid_field string ~enc:uid
961
-
|> Object.member "email" string ~dec_absent:"" ~enc:(fun u ->
962
-
opt_to_string u.email)
963
-
|> Object.opt_member "email_verified" bool ~enc:(fun u ->
964
-
Some (email_verified u))
965
-
|> Object.member "name" string ~dec_absent:"" ~enc:name
966
-
|> Object.skip_unknown |> Object.seal
967
-
968
-
let err_userinfo_parse e =
969
-
Error ("userinfo parse error: " ^ Json.Error.to_string e)
970
-
971
-
let err_userinfo_empty_uid provider =
972
-
Error ("userinfo response from " ^ provider_name provider ^ " has empty uid")
973
-
974
-
let parse_userinfo provider body =
975
-
let jsont =
976
-
match provider with
977
-
| Github -> github_userinfo_jsont
978
-
| Google -> google_userinfo_jsont
979
-
| Gitlab -> gitlab_userinfo_jsont
980
-
| Custom c -> custom_userinfo_jsont ~uid_field:c.uid_field
981
-
in
982
-
match decode jsont body with
983
-
| Error e -> err_userinfo_parse e
984
-
| Ok u when u.uid = "" -> err_userinfo_empty_uid provider
985
-
| Ok u -> Ok u
986
-
987
-
(* -- GitHub Verified Emails --------------------------------------- *)
988
-
989
-
let github_emails_url = "https://api.github.com/user/emails"
990
-
991
-
type github_email = { email : string; primary : bool; verified : bool }
992
-
993
-
let github_email_jsont =
994
-
let open Json.Codec in
995
-
Object.map ~kind:"github_email" (fun email primary verified ->
996
-
{ email; primary; verified })
997
-
|> Object.member "email" string ~enc:(fun e -> e.email)
998
-
|> Object.member "primary" bool ~enc:(fun e -> e.primary)
999
-
|> Object.member "verified" bool ~enc:(fun e -> e.verified)
1000
-
|> Object.skip_unknown |> Object.seal
1001
-
1002
-
let github_emails_jsont = Json.Codec.list github_email_jsont
1003
-
1004
-
let parse_github_emails body =
1005
-
match decode github_emails_jsont body with
1006
-
| Error e -> Error ("github emails parse error: " ^ Json.Error.to_string e)
1007
-
| Ok emails -> (
1008
-
match List.find_opt (fun e -> e.primary && e.verified) emails with
1009
-
| Some e -> Ok e.email
1010
-
| None -> Error "no primary verified email found in GitHub response")
105
+
let parse_userinfo = Userinfo.parse
106
+
let github_emails_url = Userinfo.github_emails_url
107
+
let parse_github_emails = Userinfo.parse_github_emails
+40
-11
lib/oauth.mli
+40
-11
lib/oauth.mli
···
260
260
provider mandates it (GitHub historically required this).
261
261
- [none] is for public clients (installed apps, SPAs) that cannot keep a
262
262
secret.
263
-
264
-
Future variants (not yet implemented): [private_key_jwt] (RFC 7523 section
265
-
2.2 asymmetric), [client_secret_jwt] (RFC 7523 section 2.2 symmetric HMAC).
266
-
*)
263
+
- [client_secret_jwt]
264
+
({{:https://datatracker.ietf.org/doc/html/rfc7523#section-2.2} RFC 7523
265
+
section 2.2}) builds a short-lived HS256 JWT signed with [client_secret]
266
+
and posts it as [client_assertion]. Preferred over [post] when the
267
+
provider accepts it: the secret never crosses the wire, only an HMAC over
268
+
one request's worth of bytes.
269
+
- [private_key_jwt] (same RFC) signs the assertion with an asymmetric key
270
+
the server knows by thumbprint/kid. No shared secret at all. *)
267
271
268
272
module Client_auth : sig
269
273
type t
···
273
277
274
278
val basic : client_id:string -> client_secret:string -> t
275
279
(** HTTP Basic authentication per RFC 6749 section 2.3.1. Emits an
276
-
[Authorization: Basic base64(client_id:client_secret)] header. Both fields
280
+
[Authorization: Basic base64(client_id:client_secret)] header. Both halves
277
281
are percent-encoded before joining, per RFC 6749 section 2.3.1. *)
278
282
279
283
val post : client_id:string -> client_secret:string -> t
280
284
(** Client credentials in the request body per RFC 6749 section 2.3.1. Emits
281
285
[client_id] and [client_secret] as form fields. *)
282
286
287
+
val secret_jwt :
288
+
client_id:string -> client_secret:string -> ?kid:string -> unit -> t
289
+
(** HS256 JWT client assertion per RFC 7523 section 2.2. The assertion is
290
+
signed with [client_secret] as the HMAC key; its claims are
291
+
[iss=sub=client_id], [aud=<endpoint URL>], [jti=128-bit random],
292
+
[iat=now], [exp=now + 60s]. [kid] is an optional key identifier placed in
293
+
the JWS header. *)
294
+
295
+
val private_key_jwt :
296
+
client_id:string -> key:Dpop.key -> ?kid:string -> unit -> t
297
+
(** Asymmetric JWT client assertion per RFC 7523 section 2.2. [key] can be
298
+
shared with DPoP (ES256 P-256 or EdDSA Ed25519). The authorization server
299
+
must know the corresponding public JWK (registered at client creation, or
300
+
derivable from [kid]). *)
301
+
283
302
val client_id : t -> string
284
303
(** The [client_id] bound to this configuration. *)
285
304
286
-
val apply : t -> (string * string) list * (string * string) list
287
-
(** [apply t] produces [(form_fields, headers)] to add to a token-endpoint
288
-
request. Callers append grant-type-specific fields (e.g. [code],
289
-
[refresh_token]) to [form_fields] before form-encoding. For {!none} and
290
-
{!post} [headers] is empty; for {!basic} it carries
305
+
val apply : t -> aud:string -> (string * string) list * (string * string) list
306
+
(** [apply t ~aud] produces [(form_fields, headers)] to add to a request to
307
+
the endpoint at URL [aud]. Callers append grant-type-specific fields (e.g.
308
+
[code], [refresh_token]) to [form_fields] before form-encoding.
309
+
310
+
For {!none} and {!post}, [aud] is ignored and [headers] is empty.
311
+
312
+
For {!basic}, [aud] is ignored; [headers] carries
291
313
[Authorization: Basic base64(pct(client_id):pct(client_secret))] per RFC
292
-
6749 section 2.3.1. *)
314
+
6749 section 2.3.1.
315
+
316
+
For {!secret_jwt} and {!private_key_jwt}, [aud] is the JWT audience claim
317
+
(RFC 7523 section 3): the URL of the endpoint the request is being sent to
318
+
(token endpoint for {!exchange_code}/{!refresh_token}, PAR endpoint for
319
+
{!Par.push}). The library threads the right value through; callers of
320
+
{!Client_auth.apply} directly are responsible for passing the endpoint
321
+
URL. *)
293
322
end
294
323
295
324
(** {1:exchange Token Exchange} *)
+105
lib/par.ml
+105
lib/par.ml
···
1
+
(* Pushed Authorization Requests (RFC 9126). *)
2
+
3
+
let src = Logs.Src.create "oauth.par" ~doc:"Pushed Authorization Requests"
4
+
5
+
module Log = (val Logs.src_log src : Logs.LOG)
6
+
7
+
type response = { request_uri : string; expires_in : int }
8
+
9
+
type error =
10
+
| No_par_endpoint
11
+
| Http_error of int
12
+
| Invalid_json
13
+
| Missing_request_uri
14
+
| Invalid_expires_in
15
+
16
+
let pp_error fmt = function
17
+
| No_par_endpoint -> Fmt.pf fmt "provider has no PAR endpoint"
18
+
| Http_error code -> Fmt.pf fmt "PAR endpoint returned HTTP %d" code
19
+
| Invalid_json -> Fmt.pf fmt "Invalid JSON"
20
+
| Missing_request_uri -> Fmt.pf fmt "Missing request_uri field"
21
+
| Invalid_expires_in -> Fmt.pf fmt "Missing or invalid expires_in field"
22
+
23
+
type raw = { request_uri : string; expires_in : int option }
24
+
25
+
let raw_jsont =
26
+
let open Json.Codec in
27
+
Object.map ~kind:"par_response" (fun request_uri expires_in ->
28
+
{ request_uri; expires_in })
29
+
|> Object.member "request_uri" string ~dec_absent:"" ~enc:(fun r ->
30
+
r.request_uri)
31
+
|> Object.opt_member "expires_in" int ~enc:(fun r -> r.expires_in)
32
+
|> Object.skip_unknown |> Object.seal
33
+
34
+
let parse_response body =
35
+
match Json.of_string raw_jsont body with
36
+
| Error _ -> Error Invalid_json
37
+
| Ok { request_uri = ""; _ } -> Error Missing_request_uri
38
+
| Ok { expires_in = None; _ } -> Error Invalid_expires_in
39
+
| Ok { request_uri; expires_in = Some secs } ->
40
+
Ok ({ request_uri; expires_in = secs } : response)
41
+
42
+
(* Same authorization parameters the non-PAR authorization URL would have
43
+
added to the query string, minus [client_id] which Client_auth carries. *)
44
+
let authz_fields ~redirect_uri ~state ~scope ?code_challenge
45
+
?code_challenge_method () =
46
+
let base =
47
+
[
48
+
("response_type", "code");
49
+
("redirect_uri", Redirect.to_string redirect_uri);
50
+
("state", state);
51
+
]
52
+
in
53
+
let base =
54
+
match scope with
55
+
| [] -> base
56
+
| lst -> base @ [ ("scope", String.concat " " lst) ]
57
+
in
58
+
match code_challenge with
59
+
| None -> base
60
+
| Some cc ->
61
+
let method_ =
62
+
match code_challenge_method with Some m -> m | None -> Pkce.S256
63
+
in
64
+
base
65
+
@ [
66
+
("code_challenge", cc);
67
+
("code_challenge_method", Pkce.method_to_string method_);
68
+
]
69
+
70
+
let push http provider ~client_auth ~redirect_uri ~state ~scope ?code_challenge
71
+
?code_challenge_method ?dpop_proof () =
72
+
match Provider.par_endpoint provider with
73
+
| None -> Error No_par_endpoint
74
+
| Some url ->
75
+
if not (Requests.verify_tls http) then
76
+
invalid_arg
77
+
"Oauth.Par.push: Requests.t handle must have TLS certificate \
78
+
verification enabled";
79
+
let auth_fields, auth_headers = Auth.apply client_auth ~aud:url in
80
+
let fields =
81
+
auth_fields
82
+
@ authz_fields ~redirect_uri ~state ~scope ?code_challenge
83
+
?code_challenge_method ()
84
+
in
85
+
let form_str = Encoding.form_encode fields in
86
+
let dpop_headers =
87
+
match dpop_proof with None -> [] | Some p -> [ ("DPoP", p) ]
88
+
in
89
+
let headers =
90
+
Http.Headers.of_list
91
+
(Encoding.base_token_headers @ auth_headers @ dpop_headers)
92
+
in
93
+
let body = Requests.Body.text form_str in
94
+
let resp = Requests.post http url ~body ~headers in
95
+
let status = Requests.Response.status_code resp in
96
+
if status < 200 || status >= 300 then begin
97
+
Log.warn (fun m -> m "PAR endpoint returned HTTP %d" status);
98
+
Error (Http_error status)
99
+
end
100
+
else parse_response (Requests.Response.text resp)
101
+
102
+
let authorization_url provider ~client_id ~request_uri =
103
+
let uri = Uri.of_string (Provider.authorize_url provider) in
104
+
let q = [ ("client_id", [ client_id ]); ("request_uri", [ request_uri ]) ] in
105
+
Uri.with_query uri q |> Uri.to_string
+36
lib/pkce.ml
+36
lib/pkce.ml
···
1
+
(* PKCE, RFC 7636. *)
2
+
3
+
type method_ = S256 | Plain
4
+
type verifier = string
5
+
6
+
let base64url_encode_no_pad s =
7
+
Base64.encode_exn ~pad:false ~alphabet:Base64.uri_safe_alphabet s
8
+
9
+
let is_unreserved c =
10
+
(c >= 'A' && c <= 'Z')
11
+
|| (c >= 'a' && c <= 'z')
12
+
|| (c >= '0' && c <= '9')
13
+
|| c = '-' || c = '.' || c = '_' || c = '~'
14
+
15
+
let verifier_of_string s =
16
+
let len = String.length s in
17
+
if len < 43 || len > 128 then
18
+
Error (`Msg (Fmt.str "code_verifier must be 43-128 characters, got %d" len))
19
+
else if not (String.for_all is_unreserved s) then
20
+
Error (`Msg "code_verifier contains characters outside [A-Za-z0-9._~-]")
21
+
else Ok s
22
+
23
+
let verifier_to_string s = s
24
+
25
+
let generate_verifier () =
26
+
(* 32 random bytes -> 43 base64url chars (RFC 7636 section 4.1). *)
27
+
base64url_encode_no_pad (Crypto_rng.generate 32)
28
+
29
+
let challenge method_ v =
30
+
match method_ with
31
+
| Plain -> v
32
+
| S256 ->
33
+
let hash = Digestif.SHA256.(digest_string v |> to_raw_string) in
34
+
base64url_encode_no_pad hash
35
+
36
+
let method_to_string = function S256 -> "S256" | Plain -> "plain"
+147
lib/provider.ml
+147
lib/provider.ml
···
1
+
(* Provider configuration and URL dispatch. *)
2
+
3
+
type t = Github | Google | Gitlab | Custom of custom
4
+
5
+
and custom = {
6
+
name : string;
7
+
authorize_url : string;
8
+
token_url : string;
9
+
userinfo_url : string;
10
+
uid_field : string;
11
+
par_endpoint : string option;
12
+
}
13
+
14
+
(* Sanitize a string for use as a URL path segment per RFC 3986 section 3.3:
15
+
lowercase, keep only unreserved chars [a-z0-9-], collapse runs of dashes,
16
+
strip leading/trailing dashes. Non-ASCII bytes (UTF-8) are treated as
17
+
separators (slugified), not percent-encoded, to keep routes readable.
18
+
Falls back to "custom" if the result is empty. *)
19
+
let path_safe s =
20
+
let len = String.length s in
21
+
let buf = Buffer.create len in
22
+
let prev_dash = ref true in
23
+
for i = 0 to len - 1 do
24
+
match Char.lowercase_ascii s.[i] with
25
+
| ('a' .. 'z' | '0' .. '9') as c ->
26
+
Buffer.add_char buf c;
27
+
prev_dash := false
28
+
| _ ->
29
+
if not !prev_dash then Buffer.add_char buf '-';
30
+
prev_dash := true
31
+
done;
32
+
let result = Buffer.contents buf in
33
+
let rlen = String.length result in
34
+
let result =
35
+
if rlen > 0 && result.[rlen - 1] = '-' then String.sub result 0 (rlen - 1)
36
+
else result
37
+
in
38
+
if result = "" then "custom" else result
39
+
40
+
let builtin_slugs = [ "github"; "google"; "gitlab" ]
41
+
42
+
let require_https label url =
43
+
let uri = Uri.of_string url in
44
+
match Uri.scheme uri with
45
+
| Some "https" ->
46
+
if Uri.host uri = None then
47
+
Error (`Msg (Fmt.str "%s has no host: %s" label url))
48
+
else Ok ()
49
+
| Some scheme ->
50
+
Error (`Msg (Fmt.str "%s must use HTTPS, got %s://: %s" label scheme url))
51
+
| None ->
52
+
Error (`Msg (Fmt.str "%s must be an absolute HTTPS URL: %s" label url))
53
+
54
+
let is_valid_json_field_name s =
55
+
String.length s > 0
56
+
&& String.for_all
57
+
(fun c ->
58
+
(c >= 'a' && c <= 'z')
59
+
|| (c >= 'A' && c <= 'Z')
60
+
|| (c >= '0' && c <= '9')
61
+
|| c = '_' || c = '-')
62
+
s
63
+
64
+
let custom_provider ~name ~authorize_url ~token_url ~userinfo_url ~uid_field
65
+
?par_endpoint () =
66
+
if not (is_valid_json_field_name uid_field) then
67
+
Error
68
+
(`Msg
69
+
(Fmt.str
70
+
"uid_field must be a non-empty alphanumeric JSON field name, got %S"
71
+
uid_field))
72
+
else
73
+
let slug = path_safe name in
74
+
if List.mem slug builtin_slugs then
75
+
Error
76
+
(`Msg
77
+
(Fmt.str
78
+
"custom provider name %S produces slug %S which collides with \
79
+
built-in provider"
80
+
name slug))
81
+
else
82
+
let par_check =
83
+
match par_endpoint with
84
+
| None -> Ok ()
85
+
| Some url -> require_https "par_endpoint" url
86
+
in
87
+
match
88
+
( require_https "authorize_url" authorize_url,
89
+
require_https "token_url" token_url,
90
+
require_https "userinfo_url" userinfo_url,
91
+
par_check )
92
+
with
93
+
| Ok (), Ok (), Ok (), Ok () ->
94
+
Ok
95
+
{
96
+
name;
97
+
authorize_url;
98
+
token_url;
99
+
userinfo_url;
100
+
uid_field;
101
+
par_endpoint;
102
+
}
103
+
| (Error _ as e), _, _, _
104
+
| _, (Error _ as e), _, _
105
+
| _, _, (Error _ as e), _
106
+
| _, _, _, (Error _ as e) ->
107
+
e
108
+
109
+
let name = function
110
+
| Github -> "github"
111
+
| Google -> "google"
112
+
| Gitlab -> "gitlab"
113
+
| Custom c -> c.name
114
+
115
+
let slug = function
116
+
| Github -> "github"
117
+
| Google -> "google"
118
+
| Gitlab -> "gitlab"
119
+
| Custom c -> path_safe c.name
120
+
121
+
let authorize_url = function
122
+
| Github -> "https://github.com/login/oauth/authorize"
123
+
| Google -> "https://accounts.google.com/o/oauth2/v2/auth"
124
+
| Gitlab -> "https://gitlab.com/oauth/authorize"
125
+
| Custom c -> c.authorize_url
126
+
127
+
let token_url = function
128
+
| Github -> "https://github.com/login/oauth/access_token"
129
+
| Google -> "https://oauth2.googleapis.com/token"
130
+
| Gitlab -> "https://gitlab.com/oauth/token"
131
+
| Custom c -> c.token_url
132
+
133
+
let userinfo_url = function
134
+
| Github -> "https://api.github.com/user"
135
+
| Google -> "https://www.googleapis.com/oauth2/v3/userinfo"
136
+
| Gitlab -> "https://gitlab.com/api/v4/user"
137
+
| Custom c -> c.userinfo_url
138
+
139
+
let default_scope = function
140
+
| Github -> [ "user:email" ]
141
+
| Google -> [ "openid"; "email"; "profile" ]
142
+
| Gitlab -> [ "read_user" ]
143
+
| Custom _ -> []
144
+
145
+
let par_endpoint = function
146
+
| Github | Google | Gitlab -> None
147
+
| Custom c -> c.par_endpoint
+42
lib/redirect.ml
+42
lib/redirect.ml
···
1
+
(* Validated OAuth redirect URI (RFC 6749 section 10.15). *)
2
+
3
+
type t = string
4
+
5
+
let is_loopback_host = function
6
+
| "localhost" | "127.0.0.1" | "::1" | "[::1]" -> true
7
+
| _ -> false
8
+
9
+
let is_loopback_http uri =
10
+
match Uri.scheme uri with
11
+
| Some "http" -> (
12
+
match Uri.host uri with Some h -> is_loopback_host h | None -> false)
13
+
| _ -> false
14
+
15
+
let validate s =
16
+
let uri = Uri.of_string s in
17
+
match Uri.scheme uri with
18
+
| None -> Error (`Msg "redirect_uri must be an absolute URI with a scheme")
19
+
| Some "https" -> (
20
+
match Uri.fragment uri with
21
+
| Some _ ->
22
+
Error
23
+
(`Msg
24
+
"redirect_uri must not contain a fragment (RFC 6749 section \
25
+
3.1.2)")
26
+
| None -> Ok s)
27
+
| Some "http" when is_loopback_http uri -> (
28
+
match Uri.fragment uri with
29
+
| Some _ ->
30
+
Error
31
+
(`Msg
32
+
"redirect_uri must not contain a fragment (RFC 6749 section \
33
+
3.1.2)")
34
+
| None -> Ok s)
35
+
| Some "http" ->
36
+
Error
37
+
(`Msg
38
+
"redirect_uri must use HTTPS (http:// is only allowed for localhost)")
39
+
| Some scheme ->
40
+
Error (`Msg (Fmt.str "redirect_uri must use HTTPS, got %s://" scheme))
41
+
42
+
let to_string s = s
+109
lib/response.ml
+109
lib/response.ml
···
1
+
(* OAuth token response parsing (RFC 6749 section 5). *)
2
+
3
+
let src = Logs.Src.create "oauth.response" ~doc:"OAuth token response parsing"
4
+
5
+
module Log = (val Logs.src_log src : Logs.LOG)
6
+
7
+
type t = {
8
+
access_token : string;
9
+
expires_in : int option;
10
+
refresh_token : string option;
11
+
refresh_token_expires_in : int option;
12
+
}
13
+
14
+
type error =
15
+
| Invalid_json
16
+
| Missing_access_token
17
+
| Invalid_token_format
18
+
| Unsupported_token_type of string
19
+
| Http_error of int
20
+
21
+
let pp_error fmt = function
22
+
| Invalid_json -> Fmt.pf fmt "Invalid JSON"
23
+
| Missing_access_token -> Fmt.pf fmt "Missing access_token field"
24
+
| Invalid_token_format -> Fmt.pf fmt "Invalid token format"
25
+
| Unsupported_token_type t ->
26
+
Fmt.pf fmt "Unsupported token_type %S (only Bearer is supported)" t
27
+
| Http_error status -> Fmt.pf fmt "HTTP error %d from token endpoint" status
28
+
29
+
type raw = {
30
+
access_token : string;
31
+
token_type : string option;
32
+
expires_in : int option;
33
+
refresh_token : string option;
34
+
refresh_token_expires_in : int option;
35
+
}
36
+
37
+
let raw_jsont =
38
+
let open Json.Codec in
39
+
Object.map ~kind:"token_response"
40
+
(fun
41
+
access_token
42
+
token_type
43
+
expires_in
44
+
refresh_token
45
+
refresh_token_expires_in
46
+
->
47
+
{
48
+
access_token;
49
+
token_type;
50
+
expires_in;
51
+
refresh_token;
52
+
refresh_token_expires_in;
53
+
})
54
+
|> Object.member "access_token" string ~enc:(fun t -> t.access_token)
55
+
|> Object.opt_member "token_type" string ~enc:(fun t -> t.token_type)
56
+
|> Object.opt_member "expires_in" int ~enc:(fun t -> t.expires_in)
57
+
|> Object.opt_member "refresh_token" string ~enc:(fun t -> t.refresh_token)
58
+
|> Object.opt_member "refresh_token_expires_in" int ~enc:(fun t ->
59
+
t.refresh_token_expires_in)
60
+
|> Object.skip_unknown |> Object.seal
61
+
62
+
let has_substring ~sub s =
63
+
let len = String.length sub in
64
+
let rec loop i =
65
+
if i + len > String.length s then false
66
+
else if String.sub s i len = sub then true
67
+
else loop (i + 1)
68
+
in
69
+
loop 0
70
+
71
+
let classify body e =
72
+
let e = Json.Error.to_string e in
73
+
match Json.of_string Json.Codec.Value.t body with
74
+
| Error _ -> Invalid_json
75
+
| Ok _ ->
76
+
if
77
+
has_substring ~sub:"Missing member" e
78
+
&& has_substring ~sub:"access_token" e
79
+
then Missing_access_token
80
+
else Invalid_token_format
81
+
82
+
let is_bearer = function
83
+
| None -> true (* GitHub omits token_type; default is Bearer. *)
84
+
| Some s -> String.lowercase_ascii s = "bearer"
85
+
86
+
let parse body =
87
+
match Json.of_string raw_jsont body with
88
+
| Ok t ->
89
+
if t.access_token = "" then begin
90
+
Log.warn (fun m -> m "Token parse failed: empty access_token");
91
+
Error Missing_access_token
92
+
end
93
+
else if not (is_bearer t.token_type) then begin
94
+
let tt = Option.get t.token_type in
95
+
Log.warn (fun m -> m "Token parse failed: unsupported token_type %S" tt);
96
+
Error (Unsupported_token_type tt)
97
+
end
98
+
else
99
+
Ok
100
+
{
101
+
access_token = t.access_token;
102
+
expires_in = t.expires_in;
103
+
refresh_token = t.refresh_token;
104
+
refresh_token_expires_in = t.refresh_token_expires_in;
105
+
}
106
+
| Error e ->
107
+
let err = classify body e in
108
+
Log.warn (fun m -> m "Token parse failed: %a" pp_error err);
109
+
Error err
+6
lib/state.ml
+6
lib/state.ml
+107
lib/token.ml
+107
lib/token.ml
···
1
+
(* Self-refreshing OAuth token wrapper. Safe to share across Eio fibers --
2
+
internal state is protected by a mutex so only one fiber refreshes at a
3
+
time while others wait. *)
4
+
5
+
let src = Logs.Src.create "oauth.token" ~doc:"OAuth token lifecycle"
6
+
7
+
module Log = (val Logs.src_log src : Logs.LOG)
8
+
9
+
(* Refresh when the access token is within this many seconds of expiry. 60s
10
+
is short enough to tolerate NTP skew and request latency without churning
11
+
on every request. *)
12
+
let refresh_threshold = 60.0
13
+
14
+
type state = {
15
+
access_token : string;
16
+
refresh_token : string option;
17
+
expires_at : float option;
18
+
}
19
+
20
+
type t = {
21
+
http : Requests.t;
22
+
provider : Provider.t;
23
+
client_auth : Auth.t;
24
+
clock : float Eio.Time.clock_ty Eio.Resource.t;
25
+
mutex : Eio.Mutex.t;
26
+
mutable state : state;
27
+
}
28
+
29
+
let make http provider ~client_auth ~clock ~access_token ?refresh_token
30
+
?expires_at () =
31
+
{
32
+
http;
33
+
provider;
34
+
client_auth;
35
+
clock :> float Eio.Time.clock_ty Eio.Resource.t;
36
+
mutex = Eio.Mutex.create ();
37
+
state = { access_token; refresh_token; expires_at };
38
+
}
39
+
40
+
let of_response http provider ~client_auth ~clock (tr : Response.t) =
41
+
let now = Eio.Time.now clock in
42
+
let expires_at = Option.map (fun d -> now +. float_of_int d) tr.expires_in in
43
+
make http provider ~client_auth ~clock ~access_token:tr.access_token
44
+
?refresh_token:tr.refresh_token ?expires_at ()
45
+
46
+
let stale_state ~clock ~threshold s =
47
+
match s.expires_at with
48
+
| None -> false
49
+
| Some exp -> Eio.Time.now clock +. threshold >= exp
50
+
51
+
let do_refresh t =
52
+
match t.state.refresh_token with
53
+
| None ->
54
+
Log.warn (fun m ->
55
+
m "Token refresh requested but no refresh_token available");
56
+
Error (Response.Http_error 401)
57
+
| Some rt -> (
58
+
match
59
+
Exchange.refresh_token t.http t.provider ~client_auth:t.client_auth
60
+
~refresh_token:rt
61
+
with
62
+
| Error _ as e -> e
63
+
| Ok (tr : Response.t) ->
64
+
let now = Eio.Time.now t.clock in
65
+
let expires_at =
66
+
Option.map (fun d -> now +. float_of_int d) tr.expires_in
67
+
in
68
+
(* Google and others often omit refresh_token on refresh responses;
69
+
retain the existing one. *)
70
+
let new_refresh =
71
+
match tr.refresh_token with
72
+
| Some _ as v -> v
73
+
| None -> t.state.refresh_token
74
+
in
75
+
t.state <-
76
+
{
77
+
access_token = tr.access_token;
78
+
refresh_token = new_refresh;
79
+
expires_at;
80
+
};
81
+
Ok tr.access_token)
82
+
83
+
let try_access t =
84
+
Eio.Mutex.use_rw ~protect:true t.mutex (fun () ->
85
+
if stale_state ~clock:t.clock ~threshold:refresh_threshold t.state then
86
+
do_refresh t
87
+
else Ok t.state.access_token)
88
+
89
+
let access t =
90
+
match try_access t with
91
+
| Ok s -> s
92
+
| Error e -> Fmt.failwith "Oauth.Token.access: %a" Response.pp_error e
93
+
94
+
let force_refresh t =
95
+
Eio.Mutex.use_rw ~protect:true t.mutex (fun () -> do_refresh t)
96
+
97
+
let access_token t = Eio.Mutex.use_ro t.mutex (fun () -> t.state.access_token)
98
+
let refresh_token t = Eio.Mutex.use_ro t.mutex (fun () -> t.state.refresh_token)
99
+
let expires_at t = Eio.Mutex.use_ro t.mutex (fun () -> t.state.expires_at)
100
+
101
+
let needs_refresh t =
102
+
Eio.Mutex.use_ro t.mutex (fun () ->
103
+
stale_state ~clock:t.clock ~threshold:refresh_threshold t.state)
104
+
105
+
let is_expired t =
106
+
Eio.Mutex.use_ro t.mutex (fun () ->
107
+
stale_state ~clock:t.clock ~threshold:0.0 t.state)
+156
lib/userinfo.ml
+156
lib/userinfo.ml
···
1
+
(* Userinfo parsing per provider. *)
2
+
3
+
type t = {
4
+
uid : string;
5
+
login : string;
6
+
email : string option;
7
+
email_verified : bool;
8
+
name : string;
9
+
avatar_url : string;
10
+
}
11
+
12
+
let uid u = u.uid
13
+
let login u = u.login
14
+
let email_verified u = u.email_verified
15
+
let name (u : t) = u.name
16
+
let avatar_url u = u.avatar_url
17
+
let non_empty s = if s = "" then None else Some s
18
+
let opt_to_string = function Some s -> s | None -> ""
19
+
20
+
(* GitHub: {"id":123,"login":"octocat","email":"...","name":"...","avatar_url":"..."}
21
+
email is intentionally dropped -- /user returns the public email which is
22
+
unverified. Use parse_github_emails with /user/emails for the verified one. *)
23
+
let github_jsont =
24
+
let make id login _email name avatar_url : t =
25
+
{
26
+
uid = string_of_int id;
27
+
login;
28
+
email = None;
29
+
email_verified = false;
30
+
name;
31
+
avatar_url;
32
+
}
33
+
in
34
+
let open Json.Codec in
35
+
Object.map ~kind:"github_userinfo" make
36
+
|> Object.member "id" int ~enc:(fun _ -> 0)
37
+
|> Object.member "login" string ~dec_absent:"" ~enc:login
38
+
|> Object.member "email" string ~dec_absent:"" ~enc:(fun u ->
39
+
opt_to_string u.email)
40
+
|> Object.member "name" string ~dec_absent:"" ~enc:name
41
+
|> Object.member "avatar_url" string ~dec_absent:"" ~enc:avatar_url
42
+
|> Object.skip_unknown |> Object.seal
43
+
44
+
(* Google OIDC: {"sub":"...","email":"...","email_verified":true,"name":"...","picture":"..."}
45
+
Only populate email when email_verified is true. *)
46
+
let google_jsont =
47
+
let make sub email email_verified name picture : t =
48
+
let verified = email_verified = Some true in
49
+
let email = if verified then non_empty email else None in
50
+
{
51
+
uid = sub;
52
+
login = "";
53
+
email;
54
+
email_verified = verified;
55
+
name;
56
+
avatar_url = picture;
57
+
}
58
+
in
59
+
let open Json.Codec in
60
+
Object.map ~kind:"google_userinfo" make
61
+
|> Object.member "sub" string ~enc:uid
62
+
|> Object.member "email" string ~dec_absent:"" ~enc:(fun u ->
63
+
opt_to_string u.email)
64
+
|> Object.opt_member "email_verified" bool ~enc:(fun u ->
65
+
Some (email_verified u))
66
+
|> Object.member "name" string ~dec_absent:"" ~enc:name
67
+
|> Object.member "picture" string ~dec_absent:"" ~enc:avatar_url
68
+
|> Object.skip_unknown |> Object.seal
69
+
70
+
(* GitLab: {"id":123,"username":"john","email":"...","confirmed_at":"2024-...",
71
+
"name":"...","avatar_url":"..."}
72
+
confirmed_at is non-null when the user has verified their email. *)
73
+
let gitlab_jsont =
74
+
let make id username email confirmed_at name avatar_url : t =
75
+
let email_verified = Option.is_some confirmed_at in
76
+
{
77
+
uid = string_of_int id;
78
+
login = username;
79
+
email = (if email_verified then non_empty email else None);
80
+
email_verified;
81
+
name;
82
+
avatar_url;
83
+
}
84
+
in
85
+
let open Json.Codec in
86
+
Object.map ~kind:"gitlab_userinfo" make
87
+
|> Object.member "id" int ~enc:(fun _ -> 0)
88
+
|> Object.member "username" string ~dec_absent:"" ~enc:login
89
+
|> Object.member "email" string ~dec_absent:"" ~enc:(fun u ->
90
+
opt_to_string u.email)
91
+
|> Object.opt_member "confirmed_at" string ~enc:(fun u ->
92
+
if email_verified u then Some "" else None)
93
+
|> Object.member "name" string ~dec_absent:"" ~enc:name
94
+
|> Object.member "avatar_url" string ~dec_absent:"" ~enc:avatar_url
95
+
|> Object.skip_unknown |> Object.seal
96
+
97
+
(* Custom: uid extracted from the configured uid_field. Parses the standard
98
+
OIDC email_verified claim when present. *)
99
+
let custom_jsont ~uid_field =
100
+
let make uid email email_verified name : t =
101
+
let verified = email_verified = Some true in
102
+
let email = if verified then non_empty email else None in
103
+
{ uid; login = ""; email; email_verified = verified; name; avatar_url = "" }
104
+
in
105
+
let open Json.Codec in
106
+
Object.map ~kind:"custom_userinfo" make
107
+
|> Object.member uid_field string ~enc:uid
108
+
|> Object.member "email" string ~dec_absent:"" ~enc:(fun u ->
109
+
opt_to_string u.email)
110
+
|> Object.opt_member "email_verified" bool ~enc:(fun u ->
111
+
Some (email_verified u))
112
+
|> Object.member "name" string ~dec_absent:"" ~enc:name
113
+
|> Object.skip_unknown |> Object.seal
114
+
115
+
let err_parse e = Error ("userinfo parse error: " ^ Json.Error.to_string e)
116
+
117
+
let err_empty_uid provider =
118
+
Error ("userinfo response from " ^ Provider.name provider ^ " has empty uid")
119
+
120
+
let parse provider body =
121
+
let jsont =
122
+
match (provider : Provider.t) with
123
+
| Github -> github_jsont
124
+
| Google -> google_jsont
125
+
| Gitlab -> gitlab_jsont
126
+
| Custom c -> custom_jsont ~uid_field:c.uid_field
127
+
in
128
+
match Json.of_string jsont body with
129
+
| Error e -> err_parse e
130
+
| Ok u when u.uid = "" -> err_empty_uid provider
131
+
| Ok u -> Ok u
132
+
133
+
(* -- GitHub verified emails --------------------------------------- *)
134
+
135
+
let github_emails_url = "https://api.github.com/user/emails"
136
+
137
+
type github_email = { email : string; primary : bool; verified : bool }
138
+
139
+
let github_email_jsont =
140
+
let open Json.Codec in
141
+
Object.map ~kind:"github_email" (fun email primary verified ->
142
+
{ email; primary; verified })
143
+
|> Object.member "email" string ~enc:(fun e -> e.email)
144
+
|> Object.member "primary" bool ~enc:(fun e -> e.primary)
145
+
|> Object.member "verified" bool ~enc:(fun e -> e.verified)
146
+
|> Object.skip_unknown |> Object.seal
147
+
148
+
let github_emails_jsont = Json.Codec.list github_email_jsont
149
+
150
+
let parse_github_emails body =
151
+
match Json.of_string github_emails_jsont body with
152
+
| Error e -> Error ("github emails parse error: " ^ Json.Error.to_string e)
153
+
| Ok emails -> (
154
+
match List.find_opt (fun e -> e.primary && e.verified) emails with
155
+
| Some e -> Ok e.email
156
+
| None -> Error "no primary verified email found in GitHub response")
+12
-1
test/dune
+12
-1
test/dune
···
1
1
(test
2
2
(name test)
3
-
(libraries oauth requests eio_main alcotest crypto-rng.unix uri)
3
+
(libraries
4
+
oauth
5
+
dpop
6
+
crypto-ec
7
+
digestif
8
+
base64
9
+
fmt
10
+
requests
11
+
eio_main
12
+
alcotest
13
+
crypto-rng.unix
14
+
uri)
4
15
(deps ../README.md ../oauth.opam dune ../fuzz/dune))
+157
-8
test/test_client_auth.ml
+157
-8
test/test_client_auth.ml
···
1
+
let aud = "https://as.example.com/token"
2
+
1
3
let test_none_apply () =
2
4
let a = Oauth.Client_auth.none ~client_id:"cid" in
3
-
let fields, headers = Oauth.Client_auth.apply a in
5
+
let fields, headers = Oauth.Client_auth.apply a ~aud in
4
6
Alcotest.(check (list (pair string string)))
5
7
"fields"
6
8
[ ("client_id", "cid") ]
···
11
13
let a =
12
14
Oauth.Client_auth.post ~client_id:"cid" ~client_secret:"supersecret"
13
15
in
14
-
let fields, headers = Oauth.Client_auth.apply a in
16
+
let fields, headers = Oauth.Client_auth.apply a ~aud in
15
17
Alcotest.(check (list (pair string string)))
16
18
"fields"
17
19
[ ("client_id", "cid"); ("client_secret", "supersecret") ]
···
20
22
21
23
let test_basic_apply () =
22
24
let a = Oauth.Client_auth.basic ~client_id:"cid" ~client_secret:"csec" in
23
-
let fields, headers = Oauth.Client_auth.apply a in
25
+
let fields, headers = Oauth.Client_auth.apply a ~aud in
24
26
Alcotest.(check (list (pair string string)))
25
27
"fields"
26
28
[ ("client_id", "cid") ]
···
32
34
headers
33
35
34
36
let test_basic_percent_encodes_special_chars () =
35
-
(* RFC 6749 §2.3.1: credentials are form-urlencoded before joining with ":"
36
-
so a secret containing ':' or other special chars does not produce an
37
-
ambiguous token. We percent-encode both halves uniformly. *)
37
+
(* Credentials are form-urlencoded before joining with ':' so a secret
38
+
containing ':' does not produce an ambiguous token (RFC 6749 section
39
+
2.3.1). *)
38
40
let a =
39
41
Oauth.Client_auth.basic ~client_id:"id:with:colons"
40
42
~client_secret:"p@ss:wor d"
41
43
in
42
-
let _, headers = Oauth.Client_auth.apply a in
44
+
let _, headers = Oauth.Client_auth.apply a ~aud in
43
45
let auth = List.assoc "Authorization" headers in
44
46
let b64 =
45
47
match String.split_on_char ' ' auth with
···
62
64
Alcotest.(check string)
63
65
"basic" "c"
64
66
(Oauth.Client_auth.client_id
65
-
(Oauth.Client_auth.basic ~client_id:"c" ~client_secret:"x"))
67
+
(Oauth.Client_auth.basic ~client_id:"c" ~client_secret:"x"));
68
+
Alcotest.(check string)
69
+
"secret_jwt" "d"
70
+
(Oauth.Client_auth.client_id
71
+
(Oauth.Client_auth.secret_jwt ~client_id:"d" ~client_secret:"x" ()));
72
+
let k = Dpop.generate ES256 in
73
+
Alcotest.(check string)
74
+
"private_key_jwt" "e"
75
+
(Oauth.Client_auth.client_id
76
+
(Oauth.Client_auth.private_key_jwt ~client_id:"e" ~key:k ()))
77
+
78
+
(* -- RFC 7523 JWT assertion tests --------------------------------- *)
79
+
80
+
let b64url_decode s =
81
+
Base64.decode_exn ~pad:false ~alphabet:Base64.uri_safe_alphabet s
82
+
83
+
let split_jws s =
84
+
match String.split_on_char '.' s with
85
+
| [ h; p; sg ] -> (h, p, sg)
86
+
| _ -> Alcotest.failf "expected three JWS segments, got %S" s
87
+
88
+
let contains sub s =
89
+
let n = String.length sub in
90
+
let rec go i =
91
+
if i + n > String.length s then false
92
+
else if String.sub s i n = sub then true
93
+
else go (i + 1)
94
+
in
95
+
go 0
96
+
97
+
let test_secret_jwt_form_fields () =
98
+
let a =
99
+
Oauth.Client_auth.secret_jwt ~client_id:"cid" ~client_secret:"topsecret" ()
100
+
in
101
+
let fields, headers = Oauth.Client_auth.apply a ~aud in
102
+
Alcotest.(check (list (pair string string))) "no headers" [] headers;
103
+
Alcotest.(check string) "client_id" "cid" (List.assoc "client_id" fields);
104
+
Alcotest.(check string)
105
+
"assertion type" "urn:ietf:params:oauth:client-assertion-type:jwt-bearer"
106
+
(List.assoc "client_assertion_type" fields);
107
+
let assertion = List.assoc "client_assertion" fields in
108
+
let h, p, _ = split_jws assertion in
109
+
let header = b64url_decode h in
110
+
let payload = b64url_decode p in
111
+
Alcotest.(check bool) "alg=HS256" true (contains "\"alg\":\"HS256\"" header);
112
+
Alcotest.(check bool) "typ=JWT" true (contains "\"typ\":\"JWT\"" header);
113
+
Alcotest.(check bool) "iss=cid" true (contains "\"iss\":\"cid\"" payload);
114
+
Alcotest.(check bool) "sub=cid" true (contains "\"sub\":\"cid\"" payload);
115
+
Alcotest.(check bool)
116
+
"aud=endpoint" true
117
+
(contains "\"aud\":\"https://as.example.com/token\"" payload);
118
+
Alcotest.(check bool) "has iat" true (contains "\"iat\":" payload);
119
+
Alcotest.(check bool) "has exp" true (contains "\"exp\":" payload);
120
+
Alcotest.(check bool) "has jti" true (contains "\"jti\":" payload)
121
+
122
+
let test_secret_jwt_signature_is_hmac_sha256 () =
123
+
let secret = "shared-secret" in
124
+
let a =
125
+
Oauth.Client_auth.secret_jwt ~client_id:"cid" ~client_secret:secret ()
126
+
in
127
+
let fields, _ = Oauth.Client_auth.apply a ~aud in
128
+
let assertion = List.assoc "client_assertion" fields in
129
+
let h, p, sg = split_jws assertion in
130
+
let expected =
131
+
Digestif.SHA256.(hmac_string ~key:secret (h ^ "." ^ p) |> to_raw_string)
132
+
in
133
+
Alcotest.(check string) "HMAC matches" expected (b64url_decode sg)
134
+
135
+
let test_secret_jwt_kid_included () =
136
+
let a =
137
+
Oauth.Client_auth.secret_jwt ~client_id:"cid" ~client_secret:"s"
138
+
~kid:"key-1" ()
139
+
in
140
+
let fields, _ = Oauth.Client_auth.apply a ~aud in
141
+
let assertion = List.assoc "client_assertion" fields in
142
+
let h, _, _ = split_jws assertion in
143
+
let header = b64url_decode h in
144
+
Alcotest.(check bool) "kid=key-1" true (contains "\"kid\":\"key-1\"" header)
145
+
146
+
let test_private_key_jwt_form_fields () =
147
+
let k = Dpop.generate ES256 in
148
+
let a = Oauth.Client_auth.private_key_jwt ~client_id:"cid" ~key:k () in
149
+
let fields, headers = Oauth.Client_auth.apply a ~aud in
150
+
Alcotest.(check (list (pair string string))) "no headers" [] headers;
151
+
let assertion = List.assoc "client_assertion" fields in
152
+
let h, _, _ = split_jws assertion in
153
+
let header = b64url_decode h in
154
+
Alcotest.(check bool) "alg=ES256" true (contains "\"alg\":\"ES256\"" header);
155
+
Alcotest.(check bool) "typ=JWT" true (contains "\"typ\":\"JWT\"" header)
156
+
157
+
let test_private_key_jwt_uses_eddsa_when_key_is_ed25519 () =
158
+
let k = Dpop.generate EdDSA in
159
+
let a = Oauth.Client_auth.private_key_jwt ~client_id:"cid" ~key:k () in
160
+
let fields, _ = Oauth.Client_auth.apply a ~aud in
161
+
let assertion = List.assoc "client_assertion" fields in
162
+
let h, _, _ = split_jws assertion in
163
+
let header = b64url_decode h in
164
+
Alcotest.(check bool) "alg=EdDSA" true (contains "\"alg\":\"EdDSA\"" header)
165
+
166
+
let test_private_key_jwt_signature_verifies () =
167
+
let k = Dpop.generate ES256 in
168
+
let a = Oauth.Client_auth.private_key_jwt ~client_id:"cid" ~key:k () in
169
+
let fields, _ = Oauth.Client_auth.apply a ~aud in
170
+
let assertion = List.assoc "client_assertion" fields in
171
+
let h, p, sg = split_jws assertion in
172
+
let sig_bytes = b64url_decode sg in
173
+
Alcotest.(check int) "signature length" 64 (String.length sig_bytes);
174
+
let r = String.sub sig_bytes 0 32 in
175
+
let s = String.sub sig_bytes 32 32 in
176
+
(* Rebuild the public key from the JWK embedded in the DPoP key. *)
177
+
let jwk = Dpop.public_jwk k in
178
+
let find_value label =
179
+
let key = Fmt.str "\"%s\":\"" label in
180
+
let n = String.length key in
181
+
let rec find i =
182
+
if i + n > String.length jwk then -1
183
+
else if String.sub jwk i n = key then i
184
+
else find (i + 1)
185
+
in
186
+
let i = find 0 in
187
+
let start = i + n in
188
+
let j = String.index_from jwk start '"' in
189
+
String.sub jwk start (j - start)
190
+
in
191
+
let x = find_value "x" in
192
+
let y = find_value "y" in
193
+
let pub_octets = "\x04" ^ b64url_decode x ^ b64url_decode y in
194
+
let pub =
195
+
match Crypto_ec.P256.Dsa.pub_of_octets pub_octets with
196
+
| Ok p -> p
197
+
| Error _ -> Alcotest.fail "rebuild P-256 pub"
198
+
in
199
+
let digest = Digestif.SHA256.(digest_string (h ^ "." ^ p) |> to_raw_string) in
200
+
Alcotest.(check bool)
201
+
"ES256 verifies" true
202
+
(Crypto_ec.P256.Dsa.verify ~key:pub (r, s) digest)
66
203
67
204
let suite =
68
205
( "client_auth",
···
73
210
Alcotest.test_case "basic percent-encodes special chars" `Quick
74
211
test_basic_percent_encodes_special_chars;
75
212
Alcotest.test_case "client_id accessor" `Quick test_client_id_accessor;
213
+
Alcotest.test_case "secret_jwt form fields" `Quick
214
+
test_secret_jwt_form_fields;
215
+
Alcotest.test_case "secret_jwt signature is HMAC-SHA256" `Quick
216
+
test_secret_jwt_signature_is_hmac_sha256;
217
+
Alcotest.test_case "secret_jwt kid included" `Quick
218
+
test_secret_jwt_kid_included;
219
+
Alcotest.test_case "private_key_jwt form fields" `Quick
220
+
test_private_key_jwt_form_fields;
221
+
Alcotest.test_case "private_key_jwt uses EdDSA" `Quick
222
+
test_private_key_jwt_uses_eddsa_when_key_is_ed25519;
223
+
Alcotest.test_case "private_key_jwt signature verifies" `Quick
224
+
test_private_key_jwt_signature_verifies;
76
225
] )