OAuth 2.0 authorization and token exchange
oauth: discovery chain, client metadata, server capabilities
- Oauth.Discovery walks the RFC 9728 + RFC 8414 two-step chain:
GET /.well-known/oauth-protected-resource, follow the first
authorization_servers entry, GET /.well-known/oauth-authorization-server.
Handles the RFC 8414 section 3.1 quirk that the well-known suffix is
inserted between origin and path, not appended.
- Oauth.Client models the RFC 7591 Dynamic Client Registration metadata
document plus the RFC 9449 dpop_bound_access_tokens field.
- Oauth.Server.supports / missing let profiles assert policy against the
metadata record (PAR, PKCE method, DPoP alg, grant type, response
type, auth method, scope).
7 new tests. 100 oauth tests pass.
+481
+124
lib/client.ml
+124
lib/client.ml
···
1
+
(* RFC 7591 Dynamic Client Registration metadata, plus the subset of
2
+
extensions callers most often need:
3
+
- application_type (OIDC Registration)
4
+
- dpop_bound_access_tokens (RFC 9449 section 5.2)
5
+
- token_endpoint_auth_signing_alg (RFC 7591 when using *_jwt auth)
6
+
- jwks / jwks_uri (RFC 7591 section 2)
7
+
8
+
The [client_id] field is optional here because this same record is both
9
+
a client's self-description (published at some URL, where the AS reads
10
+
it) and the AS's response to a registration request (where client_id is
11
+
present). *)
12
+
13
+
type t = {
14
+
client_id : string option;
15
+
client_name : string option;
16
+
client_uri : string option;
17
+
redirect_uris : string list;
18
+
grant_types : string list;
19
+
response_types : string list;
20
+
scope : string option;
21
+
token_endpoint_auth_method : string option;
22
+
token_endpoint_auth_signing_alg : string option;
23
+
application_type : string option;
24
+
dpop_bound_access_tokens : bool;
25
+
jwks_uri : string option;
26
+
jwks : Json.t option;
27
+
contacts : string list;
28
+
logo_uri : string option;
29
+
tos_uri : string option;
30
+
policy_uri : string option;
31
+
software_id : string option;
32
+
software_version : string option;
33
+
}
34
+
35
+
let empty =
36
+
{
37
+
client_id = None;
38
+
client_name = None;
39
+
client_uri = None;
40
+
redirect_uris = [];
41
+
grant_types = [];
42
+
response_types = [];
43
+
scope = None;
44
+
token_endpoint_auth_method = None;
45
+
token_endpoint_auth_signing_alg = None;
46
+
application_type = None;
47
+
dpop_bound_access_tokens = false;
48
+
jwks_uri = None;
49
+
jwks = None;
50
+
contacts = [];
51
+
logo_uri = None;
52
+
tos_uri = None;
53
+
policy_uri = None;
54
+
software_id = None;
55
+
software_version = None;
56
+
}
57
+
58
+
let opt_list = function [] -> None | xs -> Some xs
59
+
60
+
let make client_id client_name client_uri redirect_uris grant_types
61
+
response_types scope token_endpoint_auth_method
62
+
token_endpoint_auth_signing_alg application_type dpop_bound_access_tokens
63
+
jwks_uri jwks contacts logo_uri tos_uri policy_uri software_id
64
+
software_version : t =
65
+
{
66
+
client_id;
67
+
client_name;
68
+
client_uri;
69
+
redirect_uris = Option.value ~default:[] redirect_uris;
70
+
grant_types = Option.value ~default:[] grant_types;
71
+
response_types = Option.value ~default:[] response_types;
72
+
scope;
73
+
token_endpoint_auth_method;
74
+
token_endpoint_auth_signing_alg;
75
+
application_type;
76
+
dpop_bound_access_tokens =
77
+
Option.value ~default:false dpop_bound_access_tokens;
78
+
jwks_uri;
79
+
jwks;
80
+
contacts = Option.value ~default:[] contacts;
81
+
logo_uri;
82
+
tos_uri;
83
+
policy_uri;
84
+
software_id;
85
+
software_version;
86
+
}
87
+
88
+
let json : t Json.codec =
89
+
let open Json.Codec in
90
+
Object.(
91
+
map ~kind:"ClientMetadata" make
92
+
|> opt_member "client_id" string ~enc:(fun r -> r.client_id)
93
+
|> opt_member "client_name" string ~enc:(fun r -> r.client_name)
94
+
|> opt_member "client_uri" string ~enc:(fun r -> r.client_uri)
95
+
|> opt_member "redirect_uris" (list string) ~enc:(fun r ->
96
+
opt_list r.redirect_uris)
97
+
|> opt_member "grant_types" (list string) ~enc:(fun r ->
98
+
opt_list r.grant_types)
99
+
|> opt_member "response_types" (list string) ~enc:(fun r ->
100
+
opt_list r.response_types)
101
+
|> opt_member "scope" string ~enc:(fun r -> r.scope)
102
+
|> opt_member "token_endpoint_auth_method" string ~enc:(fun r ->
103
+
r.token_endpoint_auth_method)
104
+
|> opt_member "token_endpoint_auth_signing_alg" string ~enc:(fun r ->
105
+
r.token_endpoint_auth_signing_alg)
106
+
|> opt_member "application_type" string ~enc:(fun r -> r.application_type)
107
+
|> opt_member "dpop_bound_access_tokens" bool ~enc:(fun r ->
108
+
if r.dpop_bound_access_tokens then Some true else None)
109
+
|> opt_member "jwks_uri" string ~enc:(fun r -> r.jwks_uri)
110
+
|> opt_member "jwks" Value.t ~enc:(fun r -> r.jwks)
111
+
|> opt_member "contacts" (list string) ~enc:(fun r -> opt_list r.contacts)
112
+
|> opt_member "logo_uri" string ~enc:(fun r -> r.logo_uri)
113
+
|> opt_member "tos_uri" string ~enc:(fun r -> r.tos_uri)
114
+
|> opt_member "policy_uri" string ~enc:(fun r -> r.policy_uri)
115
+
|> opt_member "software_id" string ~enc:(fun r -> r.software_id)
116
+
|> opt_member "software_version" string ~enc:(fun r -> r.software_version)
117
+
|> seal)
118
+
119
+
let pp ppf (t : t) =
120
+
match t.client_id with
121
+
| Some id -> Fmt.pf ppf "<ClientMetadata %s>" id
122
+
| None ->
123
+
Fmt.pf ppf "<ClientMetadata %s>"
124
+
(Option.value ~default:"<anonymous>" t.client_name)
+66
lib/discovery.ml
+66
lib/discovery.ml
···
1
+
(* Discovery helpers: fetch the RFC 9728 protected-resource document, follow
2
+
it to the RFC 8414 authorization-server document. *)
3
+
4
+
let src = Logs.Src.create "oauth.discovery" ~doc:"OAuth well-known discovery"
5
+
6
+
module Log = (val Logs.src_log src : Logs.LOG)
7
+
8
+
type error =
9
+
| Http_error of { url : string; status : int }
10
+
| Invalid_json of { url : string; error : string }
11
+
| No_authorization_servers of { url : string }
12
+
13
+
let pp_error ppf = function
14
+
| Http_error { url; status } -> Fmt.pf ppf "%s returned HTTP %d" url status
15
+
| Invalid_json { url; error } -> Fmt.pf ppf "%s: invalid JSON: %s" url error
16
+
| No_authorization_servers { url } ->
17
+
Fmt.pf ppf "%s: protected-resource has no authorization_servers" url
18
+
19
+
(* RFC 8414 section 3.1 / RFC 9728 section 3: the well-known URI is inserted
20
+
between the origin and the path, not appended. Issuer
21
+
"https://as/t1" -> "https://as/.well-known/<suffix>/t1". Issuer with no
22
+
path: "https://as/.well-known/<suffix>". *)
23
+
let well_known_url ~suffix base =
24
+
let uri = Uri.of_string base in
25
+
let path = Uri.path uri in
26
+
let base_path = if path = "" || path = "/" then "/" else path in
27
+
let new_path =
28
+
if base_path = "/" then "/.well-known/" ^ suffix
29
+
else "/.well-known/" ^ suffix ^ base_path
30
+
in
31
+
let stripped = Uri.with_fragment (Uri.with_query uri []) None in
32
+
Uri.with_path stripped new_path |> Uri.to_string
33
+
34
+
let resource_url base = well_known_url ~suffix:"oauth-protected-resource" base
35
+
let server_url base = well_known_url ~suffix:"oauth-authorization-server" base
36
+
37
+
let fetch_json http url codec =
38
+
if not (Requests.verify_tls http) then
39
+
invalid_arg
40
+
"Oauth.Discovery: Requests.t handle must have TLS certificate \
41
+
verification enabled";
42
+
let resp = Requests.get http url in
43
+
let status = Requests.Response.status_code resp in
44
+
if status < 200 || status >= 300 then begin
45
+
Log.warn (fun m -> m "%s returned HTTP %d" url status);
46
+
Error (Http_error { url; status })
47
+
end
48
+
else
49
+
let body = Requests.Response.text resp in
50
+
match Json.of_string codec body with
51
+
| Ok v -> Ok v
52
+
| Error e -> Error (Invalid_json { url; error = Json.Error.to_string e })
53
+
54
+
let fetch_resource http base = fetch_json http (resource_url base) Resource.json
55
+
let fetch_server http base = fetch_json http (server_url base) Server.json
56
+
57
+
let of_resource http ~resource =
58
+
match fetch_resource http resource with
59
+
| Error _ as e -> e
60
+
| Ok (r : Resource.metadata) -> (
61
+
match r.authorization_servers with
62
+
| [] -> Error (No_authorization_servers { url = resource_url resource })
63
+
| as_url :: _ -> (
64
+
match fetch_server http as_url with
65
+
| Error _ as e -> e
66
+
| Ok s -> Ok (r, s)))
+2
lib/oauth.ml
+2
lib/oauth.ml
+93
lib/oauth.mli
+93
lib/oauth.mli
···
97
97
[require_pushed_authorization_requests] defaults to [false]. *)
98
98
99
99
val pp : metadata Fmt.t
100
+
101
+
(** A capability advertised in the metadata. Profiles use these to assert
102
+
policy without reaching into the record. *)
103
+
type capability =
104
+
| Par_supported (** [pushed_authorization_request_endpoint] is present. *)
105
+
| Par_required (** [require_pushed_authorization_requests] is [true]. *)
106
+
| Code_challenge_method of string
107
+
(** [code_challenge_methods_supported] contains the given method. *)
108
+
| Dpop_alg of string
109
+
(** [dpop_signing_alg_values_supported] contains the given algorithm. *)
110
+
| Grant_type of string
111
+
| Response_type of string
112
+
| Auth_method of string
113
+
| Scope of string
114
+
115
+
val supports : metadata -> capability -> bool
116
+
(** [supports m c] is [true] if metadata [m] advertises capability [c]. *)
117
+
118
+
val missing : metadata -> capability list -> capability list
119
+
(** [missing m caps] is the sub-list of [caps] that [m] does not advertise.
120
+
Useful for profile validation. *)
121
+
122
+
val pp_capability : capability Fmt.t
123
+
end
124
+
125
+
(** {2:discovery_chain Discovery chain} *)
126
+
127
+
module Discovery : sig
128
+
type error =
129
+
| Http_error of { url : string; status : int }
130
+
| Invalid_json of { url : string; error : string }
131
+
| No_authorization_servers of { url : string }
132
+
133
+
val pp_error : error Fmt.t
134
+
135
+
val fetch_resource : Requests.t -> string -> (Resource.metadata, error) result
136
+
(** [fetch_resource http base] fetches
137
+
[base/.well-known/oauth-protected-resource] per RFC 9728. *)
138
+
139
+
val fetch_server : Requests.t -> string -> (Server.metadata, error) result
140
+
(** [fetch_server http base] fetches
141
+
[base/.well-known/oauth-authorization-server] per RFC 8414. *)
142
+
143
+
val of_resource :
144
+
Requests.t ->
145
+
resource:string ->
146
+
(Resource.metadata * Server.metadata, error) result
147
+
(** [of_resource http ~resource] walks the two-step discovery chain: GET the
148
+
protected-resource metadata, pick the first entry in
149
+
[authorization_servers], GET the authorization-server metadata. Returns
150
+
[Error (No_authorization_servers _)] if the resource document lists none.
151
+
*)
152
+
end
153
+
154
+
(** {2:client_metadata Client metadata}
155
+
156
+
RFC 7591 Dynamic Client Registration metadata: the JSON document describing
157
+
an OAuth client. Confidential clients publish this at a URL they control;
158
+
the authorization server GETs it during registration or at each
159
+
authorization request. Profiles layer their own rules on which fields must
160
+
be present and what values they must take. *)
161
+
162
+
module Client : sig
163
+
type t = {
164
+
client_id : string option;
165
+
client_name : string option;
166
+
client_uri : string option;
167
+
redirect_uris : string list;
168
+
grant_types : string list;
169
+
response_types : string list;
170
+
scope : string option;
171
+
token_endpoint_auth_method : string option;
172
+
token_endpoint_auth_signing_alg : string option;
173
+
application_type : string option;
174
+
dpop_bound_access_tokens : bool; (** RFC 9449 section 5.2. *)
175
+
jwks_uri : string option;
176
+
jwks : Json.t option;
177
+
contacts : string list;
178
+
logo_uri : string option;
179
+
tos_uri : string option;
180
+
policy_uri : string option;
181
+
software_id : string option;
182
+
software_version : string option;
183
+
}
184
+
185
+
val empty : t
186
+
(** Starting point for building client metadata. All fields [None] or empty.
187
+
*)
188
+
189
+
val json : t Json.codec
190
+
(** Codec. Missing fields decode to [None] or [[]]. *)
191
+
192
+
val pp : t Fmt.t
100
193
end
101
194
102
195
(** {1:providers Providers} *)
+35
lib/server.ml
+35
lib/server.ml
···
105
105
|> seal)
106
106
107
107
let pp ppf (t : metadata) = Fmt.pf ppf "<AuthorizationServer %s>" t.issuer
108
+
109
+
(* A capability advertised in the metadata. Profiles (ATProto, OIDC
110
+
conformance suites, corporate SSO) use these to assert policy without
111
+
reaching into the record. *)
112
+
type capability =
113
+
| Par_supported
114
+
| Par_required
115
+
| Code_challenge_method of string
116
+
| Dpop_alg of string
117
+
| Grant_type of string
118
+
| Response_type of string
119
+
| Auth_method of string
120
+
| Scope of string
121
+
122
+
let supports (t : metadata) = function
123
+
| Par_supported -> Option.is_some t.pushed_authorization_request_endpoint
124
+
| Par_required -> t.require_pushed_authorization_requests
125
+
| Code_challenge_method m -> List.mem m t.code_challenge_methods_supported
126
+
| Dpop_alg a -> List.mem a t.dpop_signing_alg_values_supported
127
+
| Grant_type g -> List.mem g t.grant_types_supported
128
+
| Response_type r -> List.mem r t.response_types_supported
129
+
| Auth_method m -> List.mem m t.token_endpoint_auth_methods_supported
130
+
| Scope s -> List.mem s t.scopes_supported
131
+
132
+
let missing (t : metadata) caps = List.filter (fun c -> not (supports t c)) caps
133
+
134
+
let pp_capability ppf = function
135
+
| Par_supported -> Fmt.string ppf "PAR supported"
136
+
| Par_required -> Fmt.string ppf "PAR required"
137
+
| Code_challenge_method m -> Fmt.pf ppf "PKCE %s" m
138
+
| Dpop_alg a -> Fmt.pf ppf "DPoP alg %s" a
139
+
| Grant_type g -> Fmt.pf ppf "grant_type=%s" g
140
+
| Response_type r -> Fmt.pf ppf "response_type=%s" r
141
+
| Auth_method m -> Fmt.pf ppf "token_auth=%s" m
142
+
| Scope s -> Fmt.pf ppf "scope=%s" s
+1
test/test.ml
+1
test/test.ml
+85
test/test_client.ml
+85
test/test_client.ml
···
1
+
(* RFC 7591 Client Metadata codec tests. *)
2
+
3
+
let decode s = Json.of_string Oauth.Client.json s
4
+
5
+
let ok name s k =
6
+
match decode s with
7
+
| Ok t -> k t
8
+
| Error e -> Alcotest.failf "%s: decode failed: %a" name Json.Error.pp e
9
+
10
+
let test_typical_atproto_shape () =
11
+
(* The kind of client metadata an ATProto confidential client publishes. *)
12
+
let json =
13
+
{|{
14
+
"client_id": "https://app.example.com/client-metadata.json",
15
+
"client_name": "Example",
16
+
"client_uri": "https://app.example.com",
17
+
"redirect_uris": ["https://app.example.com/callback"],
18
+
"grant_types": ["authorization_code", "refresh_token"],
19
+
"response_types": ["code"],
20
+
"scope": "atproto transition:generic",
21
+
"token_endpoint_auth_method": "private_key_jwt",
22
+
"token_endpoint_auth_signing_alg": "ES256",
23
+
"application_type": "web",
24
+
"dpop_bound_access_tokens": true,
25
+
"jwks_uri": "https://app.example.com/jwks.json"
26
+
}|}
27
+
in
28
+
ok "typical" json @@ fun t ->
29
+
Alcotest.(check (option string))
30
+
"client_id" (Some "https://app.example.com/client-metadata.json")
31
+
t.client_id;
32
+
Alcotest.(check (list string))
33
+
"redirect_uris"
34
+
[ "https://app.example.com/callback" ]
35
+
t.redirect_uris;
36
+
Alcotest.(check (list string))
37
+
"grant_types"
38
+
[ "authorization_code"; "refresh_token" ]
39
+
t.grant_types;
40
+
Alcotest.(check (option string))
41
+
"scope" (Some "atproto transition:generic") t.scope;
42
+
Alcotest.(check (option string))
43
+
"token_endpoint_auth_method" (Some "private_key_jwt")
44
+
t.token_endpoint_auth_method;
45
+
Alcotest.(check bool)
46
+
"dpop_bound_access_tokens" true t.dpop_bound_access_tokens
47
+
48
+
let test_empty_decodes () =
49
+
ok "empty" "{}" @@ fun t ->
50
+
Alcotest.(check (option string)) "no client_id" None t.client_id;
51
+
Alcotest.(check (list string)) "no redirect_uris" [] t.redirect_uris;
52
+
Alcotest.(check bool) "dpop default false" false t.dpop_bound_access_tokens
53
+
54
+
let test_roundtrip () =
55
+
let json =
56
+
{|{
57
+
"client_id": "https://app.example.com/cm.json",
58
+
"redirect_uris": ["https://app.example.com/cb"],
59
+
"dpop_bound_access_tokens": true
60
+
}|}
61
+
in
62
+
ok "roundtrip-1" json @@ fun t1 ->
63
+
let encoded = Json.to_string Oauth.Client.json t1 in
64
+
ok "roundtrip-2" encoded @@ fun t2 ->
65
+
Alcotest.(check (option string)) "client_id" t1.client_id t2.client_id;
66
+
Alcotest.(check (list string))
67
+
"redirect_uris" t1.redirect_uris t2.redirect_uris;
68
+
Alcotest.(check bool)
69
+
"dpop" t1.dpop_bound_access_tokens t2.dpop_bound_access_tokens
70
+
71
+
let test_empty_value () =
72
+
let e = Oauth.Client.empty in
73
+
Alcotest.(check (option string)) "client_id none" None e.client_id;
74
+
Alcotest.(check (list string)) "redirect_uris empty" [] e.redirect_uris;
75
+
Alcotest.(check bool) "dpop default false" false e.dpop_bound_access_tokens
76
+
77
+
let suite =
78
+
( "client",
79
+
[
80
+
Alcotest.test_case "typical ATProto shape" `Quick
81
+
test_typical_atproto_shape;
82
+
Alcotest.test_case "empty decodes" `Quick test_empty_decodes;
83
+
Alcotest.test_case "roundtrip" `Quick test_roundtrip;
84
+
Alcotest.test_case "empty value" `Quick test_empty_value;
85
+
] )
+75
test/test_server.ml
+75
test/test_server.ml
···
106
106
"dpop" t1.dpop_signing_alg_values_supported
107
107
t2.dpop_signing_alg_values_supported
108
108
109
+
(* -- Server.supports / missing ----------------------------------- *)
110
+
111
+
let full =
112
+
ok "full"
113
+
{|{
114
+
"issuer": "https://as.example.com",
115
+
"authorization_endpoint": "https://as.example.com/auth",
116
+
"token_endpoint": "https://as.example.com/token",
117
+
"pushed_authorization_request_endpoint": "https://as.example.com/par",
118
+
"require_pushed_authorization_requests": true,
119
+
"code_challenge_methods_supported": ["S256"],
120
+
"grant_types_supported": ["authorization_code", "refresh_token"],
121
+
"response_types_supported": ["code"],
122
+
"token_endpoint_auth_methods_supported": ["none", "private_key_jwt"],
123
+
"dpop_signing_alg_values_supported": ["ES256"],
124
+
"scopes_supported": ["atproto"]
125
+
}|}
126
+
Fun.id
127
+
128
+
let test_supports_positive () =
129
+
Alcotest.(check bool)
130
+
"PAR supported" true
131
+
(Oauth.Server.supports full Oauth.Server.Par_supported);
132
+
Alcotest.(check bool)
133
+
"PAR required" true
134
+
(Oauth.Server.supports full Oauth.Server.Par_required);
135
+
Alcotest.(check bool)
136
+
"S256" true
137
+
(Oauth.Server.supports full (Oauth.Server.Code_challenge_method "S256"));
138
+
Alcotest.(check bool)
139
+
"ES256 DPoP" true
140
+
(Oauth.Server.supports full (Oauth.Server.Dpop_alg "ES256"));
141
+
Alcotest.(check bool)
142
+
"authorization_code grant" true
143
+
(Oauth.Server.supports full (Oauth.Server.Grant_type "authorization_code"));
144
+
Alcotest.(check bool)
145
+
"atproto scope" true
146
+
(Oauth.Server.supports full (Oauth.Server.Scope "atproto"))
147
+
148
+
let test_supports_negative () =
149
+
Alcotest.(check bool)
150
+
"no plain PKCE" false
151
+
(Oauth.Server.supports full (Oauth.Server.Code_challenge_method "plain"));
152
+
Alcotest.(check bool)
153
+
"no RS256 DPoP" false
154
+
(Oauth.Server.supports full (Oauth.Server.Dpop_alg "RS256"));
155
+
Alcotest.(check bool)
156
+
"no client_credentials" false
157
+
(Oauth.Server.supports full (Oauth.Server.Grant_type "client_credentials"));
158
+
Alcotest.(check bool)
159
+
"no openid scope" false
160
+
(Oauth.Server.supports full (Oauth.Server.Scope "openid"))
161
+
162
+
let test_missing () =
163
+
let bare =
164
+
ok "bare"
165
+
{|{
166
+
"issuer": "https://as/a",
167
+
"authorization_endpoint": "https://as/a/auth",
168
+
"token_endpoint": "https://as/a/token"
169
+
}|}
170
+
Fun.id
171
+
in
172
+
let required =
173
+
Oauth.Server.
174
+
[ Par_required; Code_challenge_method "S256"; Dpop_alg "ES256" ]
175
+
in
176
+
let gaps = Oauth.Server.missing bare required in
177
+
Alcotest.(check int) "three missing" 3 (List.length gaps);
178
+
let full_gaps = Oauth.Server.missing full required in
179
+
Alcotest.(check int) "nothing missing on full" 0 (List.length full_gaps)
180
+
109
181
let suite =
110
182
( "server",
111
183
[
···
114
186
Alcotest.test_case "missing token_endpoint" `Quick
115
187
test_missing_token_endpoint;
116
188
Alcotest.test_case "roundtrip" `Quick test_roundtrip;
189
+
Alcotest.test_case "supports: positive" `Quick test_supports_positive;
190
+
Alcotest.test_case "supports: negative" `Quick test_supports_negative;
191
+
Alcotest.test_case "missing" `Quick test_missing;
117
192
] )