ATProto OAuth: client, discovery, and session management
atproto-oauth: add discovery-chain sublibrary
New sublibrary atproto-oauth.discovery (module
Atproto_oauth_discovery) composes the full handle-to-AS-metadata
chain:
handle
-> DID (via Atproto_handle_resolve.via_https)
-> DID document (via Did_resolve.resolve)
-> PDS URL (via #atproto_pds service, with type-fallback)
-> Resource metadata (via Oauth.Discovery.fetch_resource)
-> Authorization server URL (first entry)
-> Server metadata (via Oauth.Discovery.fetch_server)
-> validated against Atproto_oauth.Profile
Error type unions the six failure classes along the chain so callers
pattern-match once. Pds_of_document is exposed for callers that cache
the DID document or inject an alternate resolver.
6 tests covering PDS extraction paths, pp_error across every variant,
and pp for the result record. End-to-end HTTP testing lands with the
interop trace.
+353
+68
lib/discovery/atproto_oauth_discovery.ml
+68
lib/discovery/atproto_oauth_discovery.ml
···
1
+
type error =
2
+
| Handle_resolve of Atproto_handle_resolve.error
3
+
| Did_resolve of Did_resolve.error
4
+
| Pds_service_missing of Did.t
5
+
| Oauth_discovery of Oauth.Discovery.error
6
+
| Server_profile of Oauth.Server.capability list
7
+
| Resource_profile of Atproto_oauth.Profile.resource_violation list
8
+
9
+
let pp_error ppf = function
10
+
| Handle_resolve e ->
11
+
Fmt.pf ppf "handle resolution: %a" Atproto_handle_resolve.pp_error e
12
+
| Did_resolve e -> Fmt.pf ppf "DID resolution: %a" Did_resolve.pp_error e
13
+
| Pds_service_missing did ->
14
+
Fmt.pf ppf "DID document for %a has no #atproto_pds service" Did.pp did
15
+
| Oauth_discovery e ->
16
+
Fmt.pf ppf "OAuth discovery: %a" Oauth.Discovery.pp_error e
17
+
| Server_profile missing ->
18
+
Fmt.pf ppf "authorization server missing ATProto capabilities: %a"
19
+
Fmt.(list ~sep:comma Oauth.Server.pp_capability)
20
+
missing
21
+
| Resource_profile vs ->
22
+
Fmt.pf ppf "protected resource violates ATProto profile: %a"
23
+
Fmt.(list ~sep:comma Atproto_oauth.Profile.pp_resource_violation)
24
+
vs
25
+
26
+
type t = {
27
+
did : Did.t;
28
+
pds_url : string;
29
+
resource : Oauth.Resource.metadata;
30
+
server : Oauth.Server.metadata;
31
+
}
32
+
33
+
let pp ppf t =
34
+
Fmt.pf ppf "<Discovery did=%a pds=%s as=%s>" Did.pp t.did t.pds_url
35
+
t.server.issuer
36
+
37
+
let pds_of_document (d : Did.Document.t) =
38
+
match Did.Document.service_by_id d "#atproto_pds" with
39
+
| Some s -> Ok s.service_endpoint
40
+
| None -> (
41
+
match Did.Document.service_by_type d "AtprotoPersonalDataServer" with
42
+
| Some s -> Ok s.service_endpoint
43
+
| None -> Error (Pds_service_missing d.id))
44
+
45
+
let of_did ~sw ~clock ~net ~http ?verify_tls ?plc_registry did =
46
+
match Did_resolve.resolve ~sw ~clock ~net ?verify_tls ?plc_registry did with
47
+
| Error e -> Error (Did_resolve e)
48
+
| Ok doc -> (
49
+
match pds_of_document doc with
50
+
| Error _ as e -> e
51
+
| Ok pds_url -> (
52
+
match Oauth.Discovery.of_resource http ~resource:pds_url with
53
+
| Error e -> Error (Oauth_discovery e)
54
+
| Ok (resource, server) -> (
55
+
match Atproto_oauth.Profile.validate_server server with
56
+
| Error missing -> Error (Server_profile missing)
57
+
| Ok () -> (
58
+
match
59
+
Atproto_oauth.Profile.validate_resource
60
+
~expected_issuer:server.issuer resource
61
+
with
62
+
| Error vs -> Error (Resource_profile vs)
63
+
| Ok () -> Ok { did; pds_url; resource; server }))))
64
+
65
+
let of_handle ~sw ~clock ~net ~http ?verify_tls ?plc_registry handle =
66
+
match Atproto_handle_resolve.via_https ~sw ~clock ~net ?verify_tls handle with
67
+
| Error e -> Error (Handle_resolve e)
68
+
| Ok did -> of_did ~sw ~clock ~net ~http ?verify_tls ?plc_registry did
+87
lib/discovery/atproto_oauth_discovery.mli
+87
lib/discovery/atproto_oauth_discovery.mli
···
1
+
(** ATProto OAuth discovery chain.
2
+
3
+
Walks the full discovery sequence a client must run before launching an
4
+
authorization request:
5
+
6
+
+ Handle -> DID via HTTPS [/.well-known/atproto-did]
7
+
({!Atproto_handle_resolve.via_https}).
8
+
+ DID -> DID document via the appropriate method resolver
9
+
({!Did_resolve.resolve}).
10
+
+ DID document -> PDS URL via the [#atproto_pds] service entry.
11
+
+ PDS URL -> Resource metadata via RFC 9728
12
+
({!Oauth.Discovery.fetch_resource}).
13
+
+ Resource -> Authorization server URL via [authorization_servers].
14
+
+ AS URL -> Server metadata via RFC 8414 ({!Oauth.Discovery.fetch_server}).
15
+
+ Validate Server metadata against the ATProto profile
16
+
({!Atproto_oauth.Profile.validate_server}).
17
+
+ Validate Resource metadata against the ATProto profile
18
+
({!Atproto_oauth.Profile.validate_resource}). *)
19
+
20
+
(** {1:errors Errors} *)
21
+
22
+
type error =
23
+
| Handle_resolve of Atproto_handle_resolve.error
24
+
| Did_resolve of Did_resolve.error
25
+
| Pds_service_missing of Did.t
26
+
(** The DID document has no [#atproto_pds] service and no
27
+
[AtprotoPersonalDataServer] type fallback. *)
28
+
| Oauth_discovery of Oauth.Discovery.error
29
+
| Server_profile of Oauth.Server.capability list
30
+
(** The authorization server does not advertise every capability ATProto
31
+
requires. The list enumerates the missing ones. *)
32
+
| Resource_profile of Atproto_oauth.Profile.resource_violation list
33
+
(** The protected resource document violates the ATProto profile. *)
34
+
35
+
val pp_error : error Fmt.t
36
+
(** [pp_error] formats an error for humans. *)
37
+
38
+
(** {1:result Discovery result} *)
39
+
40
+
type t = {
41
+
did : Did.t;
42
+
pds_url : string;
43
+
resource : Oauth.Resource.metadata;
44
+
server : Oauth.Server.metadata;
45
+
}
46
+
(** Everything a client needs after discovery. [pds_url] is the URL at which the
47
+
PDS hosts [/.well-known/oauth-protected-resource]; [resource] is the
48
+
response and [server] is the downstream AS metadata. *)
49
+
50
+
val pp : t Fmt.t
51
+
(** [pp] prints a short summary. *)
52
+
53
+
(** {1:entry Chain entry points} *)
54
+
55
+
val of_did :
56
+
sw:Eio.Switch.t ->
57
+
clock:_ Eio.Time.clock ->
58
+
net:_ Eio.Net.t ->
59
+
http:Requests.t ->
60
+
?verify_tls:bool ->
61
+
?plc_registry:string ->
62
+
Did.t ->
63
+
(t, error) result
64
+
(** [of_did ~sw ~clock ~net ~http did] starts the chain from a known DID and
65
+
returns the validated discovery result. *)
66
+
67
+
val of_handle :
68
+
sw:Eio.Switch.t ->
69
+
clock:_ Eio.Time.clock ->
70
+
net:_ Eio.Net.t ->
71
+
http:Requests.t ->
72
+
?verify_tls:bool ->
73
+
?plc_registry:string ->
74
+
Atproto_handle.t ->
75
+
(t, error) result
76
+
(** [of_handle ~sw ~clock ~net ~http handle] resolves [handle] to a DID first
77
+
({!Atproto_handle_resolve.via_https}), then delegates to {!of_did}. *)
78
+
79
+
(** {1:pieces Individual steps}
80
+
81
+
Exposed for callers that want to override parts of the chain (cache DID
82
+
documents, inject alternative resolvers, etc.). *)
83
+
84
+
val pds_of_document : Did.Document.t -> (string, error) result
85
+
(** [pds_of_document d] is the [#atproto_pds] [serviceEndpoint] URL, or
86
+
[AtprotoPersonalDataServer] type fallback. Returns
87
+
[Error (Pds_service_missing _)] when neither is present. *)
+15
lib/discovery/dune
+15
lib/discovery/dune
+3
lib/discovery/test/dune
+3
lib/discovery/test/dune
+2
lib/discovery/test/test.ml
+2
lib/discovery/test/test.ml
+174
lib/discovery/test/test_atproto_oauth_discovery.ml
+174
lib/discovery/test/test_atproto_oauth_discovery.ml
···
1
+
(* Tests for the discovery chain glue.
2
+
3
+
The HTTP-backed end-to-end flow will be covered by an oracle trace
4
+
(did-resolver + @atproto/oauth-client) per the interop-testing
5
+
pattern. Here we exercise only the parts that compose without
6
+
network: PDS extraction from a DID document and error rendering. *)
7
+
8
+
let contains ~needle hay =
9
+
let nlen = String.length needle and hlen = String.length hay in
10
+
if nlen > hlen then false
11
+
else
12
+
let rec loop i =
13
+
if i > hlen - nlen then false
14
+
else if String.sub hay i nlen = needle then true
15
+
else loop (i + 1)
16
+
in
17
+
loop 0
18
+
19
+
(* ------------------------------------------------------------------------ *)
20
+
(* pds_of_document *)
21
+
(* ------------------------------------------------------------------------ *)
22
+
23
+
let pds_fragment_id () =
24
+
let doc =
25
+
Did.Document.v
26
+
~service:
27
+
[
28
+
{
29
+
id = "#atproto_pds";
30
+
type_ = [ "AtprotoPersonalDataServer" ];
31
+
service_endpoint = "https://bsky.social";
32
+
};
33
+
]
34
+
(Did.of_string_exn "did:plc:z72i7hdynmk6r22z27h6tvur")
35
+
in
36
+
match Atproto_oauth_discovery.pds_of_document doc with
37
+
| Ok u -> Alcotest.(check string) "by-fragment" "https://bsky.social" u
38
+
| Error e ->
39
+
Alcotest.failf "expected Ok, got: %a" Atproto_oauth_discovery.pp_error e
40
+
41
+
let pds_by_type_fallback () =
42
+
let doc =
43
+
Did.Document.v
44
+
~service:
45
+
[
46
+
{
47
+
id = "#something-else";
48
+
type_ = [ "AtprotoPersonalDataServer" ];
49
+
service_endpoint = "https://pds.example.com";
50
+
};
51
+
]
52
+
(Did.of_string_exn "did:web:example.com")
53
+
in
54
+
match Atproto_oauth_discovery.pds_of_document doc with
55
+
| Ok u -> Alcotest.(check string) "by-type" "https://pds.example.com" u
56
+
| Error e ->
57
+
Alcotest.failf "expected Ok, got: %a" Atproto_oauth_discovery.pp_error e
58
+
59
+
let pds_missing () =
60
+
let doc =
61
+
Did.Document.v
62
+
~service:
63
+
[
64
+
{
65
+
id = "#something";
66
+
type_ = [ "LinkedDomains" ];
67
+
service_endpoint = "https://example.com";
68
+
};
69
+
]
70
+
(Did.of_string_exn "did:web:example.com")
71
+
in
72
+
match Atproto_oauth_discovery.pds_of_document doc with
73
+
| Ok u -> Alcotest.failf "expected Error, got %S" u
74
+
| Error (Pds_service_missing did) ->
75
+
Alcotest.(check string)
76
+
"reports-did" "did:web:example.com" (Did.to_string did)
77
+
| Error e ->
78
+
Alcotest.failf "wrong error: %a" Atproto_oauth_discovery.pp_error e
79
+
80
+
let pds_no_services () =
81
+
let doc = Did.Document.v (Did.of_string_exn "did:web:example.com") in
82
+
match Atproto_oauth_discovery.pds_of_document doc with
83
+
| Ok _ -> Alcotest.fail "expected Error"
84
+
| Error (Pds_service_missing _) -> ()
85
+
| Error e ->
86
+
Alcotest.failf "wrong error: %a" Atproto_oauth_discovery.pp_error e
87
+
88
+
(* ------------------------------------------------------------------------ *)
89
+
(* Error rendering *)
90
+
(* ------------------------------------------------------------------------ *)
91
+
92
+
let pp_error_covers_all_variants () =
93
+
let s1 =
94
+
Fmt.str "%a" Atproto_oauth_discovery.pp_error
95
+
(Handle_resolve (`Msg "dns lookup failed"))
96
+
in
97
+
Alcotest.(check bool) "handle-error" true (contains ~needle:"handle" s1);
98
+
Alcotest.(check bool) "handle-msg" true (contains ~needle:"dns" s1);
99
+
let s2 =
100
+
Fmt.str "%a" Atproto_oauth_discovery.pp_error
101
+
(Did_resolve (`Unsupported_method "key"))
102
+
in
103
+
Alcotest.(check bool) "did-msg" true (contains ~needle:"DID" s2);
104
+
Alcotest.(check bool) "did-method" true (contains ~needle:"key" s2);
105
+
let s3 =
106
+
Fmt.str "%a" Atproto_oauth_discovery.pp_error
107
+
(Pds_service_missing (Did.of_string_exn "did:plc:abc"))
108
+
in
109
+
Alcotest.(check bool) "pds-msg" true (contains ~needle:"atproto_pds" s3);
110
+
let s4 =
111
+
Fmt.str "%a" Atproto_oauth_discovery.pp_error
112
+
(Server_profile [ Par_required; Code_challenge_method "S256" ])
113
+
in
114
+
Alcotest.(check bool) "server-profile" true (contains ~needle:"ATProto" s4);
115
+
let s5 =
116
+
Fmt.str "%a" Atproto_oauth_discovery.pp_error
117
+
(Resource_profile [ Bearer_method_dpop_missing ])
118
+
in
119
+
Alcotest.(check bool) "resource-profile" true (contains ~needle:"resource" s5)
120
+
121
+
(* ------------------------------------------------------------------------ *)
122
+
(* pp for the result record *)
123
+
(* ------------------------------------------------------------------------ *)
124
+
125
+
let pp_discovery () =
126
+
let did = Did.of_string_exn "did:plc:z72i7hdynmk6r22z27h6tvur" in
127
+
let resource : Oauth.Resource.metadata =
128
+
{
129
+
resource = "https://bsky.social";
130
+
authorization_servers = [ "https://bsky.social" ];
131
+
scopes_supported = [];
132
+
bearer_methods_supported = [ "DPoP" ];
133
+
}
134
+
in
135
+
let server : Oauth.Server.metadata =
136
+
{
137
+
issuer = "https://bsky.social";
138
+
authorization_endpoint = "https://bsky.social/oauth/authorize";
139
+
token_endpoint = "https://bsky.social/oauth/token";
140
+
pushed_authorization_request_endpoint = None;
141
+
require_pushed_authorization_requests = false;
142
+
introspection_endpoint = None;
143
+
revocation_endpoint = None;
144
+
jwks_uri = None;
145
+
response_types_supported = [];
146
+
grant_types_supported = [];
147
+
code_challenge_methods_supported = [];
148
+
token_endpoint_auth_methods_supported = [];
149
+
token_endpoint_auth_signing_alg_values_supported = [];
150
+
scopes_supported = [];
151
+
dpop_signing_alg_values_supported = [];
152
+
}
153
+
in
154
+
let t : Atproto_oauth_discovery.t =
155
+
{ did; pds_url = "https://bsky.social"; resource; server }
156
+
in
157
+
let s = Fmt.str "%a" Atproto_oauth_discovery.pp t in
158
+
Alcotest.(check bool)
159
+
"has-did" true
160
+
(contains ~needle:"did:plc:z72i7hdynmk6r22z27h6tvur" s);
161
+
Alcotest.(check bool)
162
+
"has-pds" true
163
+
(contains ~needle:"https://bsky.social" s)
164
+
165
+
let suite : string * unit Alcotest.test_case list =
166
+
( "atproto-oauth-discovery",
167
+
[
168
+
Alcotest.test_case "pds/fragment-id" `Quick pds_fragment_id;
169
+
Alcotest.test_case "pds/by-type-fallback" `Quick pds_by_type_fallback;
170
+
Alcotest.test_case "pds/missing" `Quick pds_missing;
171
+
Alcotest.test_case "pds/no-services" `Quick pds_no_services;
172
+
Alcotest.test_case "error/pp" `Quick pp_error_covers_all_variants;
173
+
Alcotest.test_case "discovery/pp" `Quick pp_discovery;
174
+
] )