atproto libraries implementation in ocaml
gdiazlo.tngl.sh
1(** DID Resolution for AT Protocol.
2
3 This module provides DID resolution for did:plc and did:web methods. DID
4 documents contain:
5 - The signing key (verification method)
6 - The PDS endpoint (service)
7 - The handle (alsoKnownAs)
8
9 Resolution endpoints:
10 - did:plc: https://plc.directory/<did>
11 - did:web: https://<domain>/.well-known/did.json
12
13 This module uses the unified effects from {!Atproto_effects.Effects}. *)
14
15open Atproto_syntax
16module Effects = Atproto_effects.Effects
17
18let get_string_opt = Atproto_json.get_string_opt
19let get_array_opt = Atproto_json.get_array_opt
20
21(** {1 Types} *)
22
23type verification_method = {
24 id : string;
25 type_ : string;
26 controller : string;
27 public_key_multibase : string option;
28}
29(** Verification method in a DID document *)
30
31type service = { id : string; type_ : string; service_endpoint : string }
32(** Service endpoint in a DID document *)
33
34type did_document = {
35 id : string;
36 also_known_as : string list;
37 verification_method : verification_method list;
38 service : service list;
39}
40(** DID Document *)
41
42(** Resolution errors *)
43type error =
44 | Invalid_did of string
45 | Http_error of int * string
46 | Parse_error of string
47 | Unsupported_method of string
48 | Not_found
49
50let error_to_string = function
51 | Invalid_did msg -> Printf.sprintf "Invalid DID: %s" msg
52 | Http_error (status, body) -> Printf.sprintf "HTTP error %d: %s" status body
53 | Parse_error msg -> Printf.sprintf "Parse error: %s" msg
54 | Unsupported_method meth -> Printf.sprintf "Unsupported DID method: %s" meth
55 | Not_found -> "DID not found"
56
57(** {1 HTTP Effect} *)
58
59type http_response = { status : int; body : string }
60(** HTTP GET response - local type for backward compatibility *)
61
62(** Effect for HTTP GET requests.
63
64 Note: This module also supports the unified {!Effects.Http_get} effect.
65 Handlers can match either this local effect or the unified one. *)
66type _ Effect.t += Http_get : Uri.t -> http_response Effect.t
67
68(** Convert unified response to local type *)
69let of_unified_response (resp : Effects.http_response) : http_response =
70 { status = resp.Effects.status; body = resp.Effects.body }
71
72(** {1 JSON Parsing} *)
73
74(** Parse a verification method from JSON *)
75let parse_verification_method json =
76 match Atproto_json.to_object_opt json with
77 | Some pairs ->
78 let id =
79 match get_string_opt "id" pairs with Some s -> s | None -> ""
80 in
81 let type_ =
82 match Atproto_json.get_string_opt "type" pairs with
83 | Some s -> s
84 | None -> ""
85 in
86 let controller =
87 match Atproto_json.get_string_opt "controller" pairs with
88 | Some s -> s
89 | None -> ""
90 in
91 let public_key_multibase =
92 Atproto_json.get_string_opt "publicKeyMultibase" pairs
93 in
94 { id; type_; controller; public_key_multibase }
95 | _ -> { id = ""; type_ = ""; controller = ""; public_key_multibase = None }
96
97(** Parse a service from JSON *)
98let parse_service json =
99 match Atproto_json.to_object_opt json with
100 | Some pairs ->
101 let id =
102 match get_string_opt "id" pairs with Some s -> s | None -> ""
103 in
104 let type_ =
105 match Atproto_json.get_string_opt "type" pairs with
106 | Some s -> s
107 | None -> ""
108 in
109 let service_endpoint =
110 match Atproto_json.get_string_opt "serviceEndpoint" pairs with
111 | Some s -> s
112 | None -> ""
113 in
114 { id; type_; service_endpoint }
115 | _ -> { id = ""; type_ = ""; service_endpoint = "" }
116
117(** Parse a DID document from JSON *)
118let parse_did_document json =
119 match Atproto_json.to_object_opt json with
120 | Some pairs ->
121 let id =
122 match get_string_opt "id" pairs with Some s -> s | None -> ""
123 in
124 let also_known_as =
125 match Atproto_json.get_array_opt "alsoKnownAs" pairs with
126 | Some items -> List.filter_map Atproto_json.to_string_opt items
127 | None -> []
128 in
129 let verification_method =
130 match Atproto_json.get_array_opt "verificationMethod" pairs with
131 | Some items -> List.map parse_verification_method items
132 | None -> []
133 in
134 let service =
135 match Atproto_json.get_array_opt "service" pairs with
136 | Some items -> List.map parse_service items
137 | None -> []
138 in
139 Ok { id; also_known_as; verification_method; service }
140 | _ -> Error (Parse_error "expected object")
141
142(** {1 Resolution} *)
143
144(** PLC directory URL *)
145let plc_directory = "https://plc.directory"
146
147(** Resolve a did:plc DID *)
148let resolve_plc did_str =
149 let uri = Uri.of_string (plc_directory ^ "/" ^ did_str) in
150 let response = Effect.perform (Http_get uri) in
151 if response.status = 404 then Error Not_found
152 else if response.status >= 400 then
153 Error (Http_error (response.status, response.body))
154 else
155 match Atproto_json.decode response.body with
156 | Error msg -> Error (Parse_error msg)
157 | Ok json -> parse_did_document json
158
159(** Resolve a did:web DID *)
160let resolve_web identifier =
161 (* did:web format: did:web:domain or did:web:domain:path:elements *)
162 let parts = String.split_on_char ':' identifier in
163 let domain, path =
164 match parts with
165 | [] -> ("", "")
166 | [ domain ] -> (domain, "/.well-known/did.json")
167 | domain :: path_parts ->
168 (domain, "/" ^ String.concat "/" path_parts ^ "/did.json")
169 in
170 (* URL-decode the domain (replace %3A with :) *)
171 let domain =
172 let buf = Buffer.create (String.length domain) in
173 let len = String.length domain in
174 let rec decode i =
175 if i >= len then ()
176 else if
177 i + 2 < len
178 && domain.[i] = '%'
179 && domain.[i + 1] = '3'
180 && (domain.[i + 2] = 'A' || domain.[i + 2] = 'a')
181 then (
182 Buffer.add_char buf ':';
183 decode (i + 3))
184 else (
185 Buffer.add_char buf domain.[i];
186 decode (i + 1))
187 in
188 decode 0;
189 Buffer.contents buf
190 in
191 let url = Printf.sprintf "https://%s%s" domain path in
192 let uri = Uri.of_string url in
193 let response = Effect.perform (Http_get uri) in
194 if response.status = 404 then Error Not_found
195 else if response.status >= 400 then
196 Error (Http_error (response.status, response.body))
197 else
198 match Atproto_json.decode response.body with
199 | Error msg -> Error (Parse_error msg)
200 | Ok json -> parse_did_document json
201
202(** Resolve any DID *)
203let resolve did =
204 match Did.of_string did with
205 | Error _ -> Error (Invalid_did did)
206 | Ok parsed ->
207 let meth = Did.method_ parsed in
208 if meth = "plc" then resolve_plc did
209 else if meth = "web" then resolve_web (Did.method_specific_id parsed)
210 else if meth = "key" then Error (Unsupported_method "did:key")
211 else Error (Unsupported_method meth)
212
213(** Resolve from a parsed DID *)
214let resolve_did did =
215 let meth = Did.method_ did in
216 if meth = "plc" then resolve_plc (Did.to_string did)
217 else if meth = "web" then resolve_web (Did.method_specific_id did)
218 else if meth = "key" then Error (Unsupported_method "did:key")
219 else Error (Unsupported_method meth)
220
221(** {1 Document Helpers} *)
222
223(** Get the handle from a DID document (from alsoKnownAs) *)
224let get_handle doc =
225 List.find_map
226 (fun aka ->
227 if String.length aka > 5 && String.sub aka 0 5 = "at://" then
228 let handle_str = String.sub aka 5 (String.length aka - 5) in
229 match Handle.of_string handle_str with
230 | Ok h -> Some h
231 | Error _ -> None
232 else None)
233 doc.also_known_as
234
235(** Get the PDS endpoint from a DID document *)
236let get_pds_endpoint doc =
237 List.find_map
238 (fun svc ->
239 if svc.type_ = "AtprotoPersonalDataServer" then
240 Some (Uri.of_string svc.service_endpoint)
241 else None)
242 doc.service
243
244(** Get the signing key from a DID document. Returns the multibase-encoded
245 public key if found. *)
246let get_signing_key doc =
247 List.find_map
248 (fun (vm : verification_method) ->
249 if vm.type_ = "Multikey" then vm.public_key_multibase else None)
250 doc.verification_method
251
252(** Get all verification methods of a specific type *)
253let get_verification_methods ~type_ doc =
254 List.filter
255 (fun (vm : verification_method) -> vm.type_ = type_)
256 doc.verification_method
257
258(** Get all services of a specific type *)
259let get_services ~type_ doc =
260 List.filter (fun (svc : service) -> svc.type_ = type_) doc.service