objective categorical abstract machine language personal data server
xrpc updateHandle
millipds parity achieved, apart from all the repo stuff
+273
-75
+96
pegasus/lib/api/identity/updateHandle.ml
+96
pegasus/lib/api/identity/updateHandle.ml
···
1
+
type request = {handle: string} [@@deriving yojson {strict= false}]
2
+
3
+
let validate_handle handle =
4
+
if not @@ String.ends_with ~suffix:("." ^ Env.hostname) handle then
5
+
Error (Errors.InvalidRequestError ("InvalidHandle", "invalid handle suffix"))
6
+
else
7
+
let front =
8
+
String.sub handle 0
9
+
(String.length handle - (String.length Env.hostname + 1))
10
+
in
11
+
if String.contains front '.' then
12
+
Error
13
+
(Errors.InvalidRequestError
14
+
("InvalidHandle", "invalid characters in handle") )
15
+
else
16
+
match String.length front with
17
+
| l when l < 3 ->
18
+
Error
19
+
(Errors.InvalidRequestError ("InvalidHandle", "handle too short"))
20
+
| l when l > 18 ->
21
+
Error (Errors.InvalidRequestError ("InvalidHandle", "handle too long"))
22
+
| _ ->
23
+
Ok ()
24
+
25
+
let handler =
26
+
Xrpc.handler ~auth:Auth.Verifiers.access (fun {req; auth; db} ->
27
+
let did = Auth.get_authed_did_exn auth in
28
+
let%lwt body = Dream.body req in
29
+
let handle =
30
+
match Yojson.Safe.from_string body |> request_of_yojson with
31
+
| Ok {handle} ->
32
+
handle
33
+
| Error _ ->
34
+
Errors.invalid_request "invalid request body"
35
+
in
36
+
match validate_handle handle with
37
+
| Error e ->
38
+
raise e
39
+
| Ok () -> (
40
+
match%lwt Data_store.get_actor_by_identifier handle db with
41
+
| Some _ ->
42
+
Errors.invalid_request ~name:"InvalidHandle"
43
+
"handle already in use"
44
+
| None ->
45
+
let%lwt () = Data_store.update_actor_handle ~did ~handle db in
46
+
let%lwt _ =
47
+
if String.starts_with ~prefix:"did:plc:" did then
48
+
match%lwt Plc.get_audit_log did with
49
+
| Error e ->
50
+
Dream.error (fun log -> log ~request:req "%s" e) ;
51
+
Errors.internal_error ~msg:"failed to fetch did doc" ()
52
+
| Ok log -> (
53
+
let latest = List.rev log |> List.hd in
54
+
let aka =
55
+
match
56
+
List.mem ("at://" ^ handle)
57
+
latest.operation.also_known_as
58
+
with
59
+
| true ->
60
+
latest.operation.also_known_as
61
+
| false ->
62
+
("at://" ^ handle) :: latest.operation.also_known_as
63
+
in
64
+
let%lwt signing_key =
65
+
match%lwt Data_store.get_actor_by_identifier did db with
66
+
| Some {signing_key; _} ->
67
+
Lwt.return @@ Kleidos.parse_multikey_str signing_key
68
+
| _ ->
69
+
Errors.internal_error ()
70
+
in
71
+
let signed =
72
+
Plc.sign_operation signing_key
73
+
(Operation
74
+
{ type'= "plc_operation"
75
+
; prev= Some latest.cid
76
+
; also_known_as= aka
77
+
; rotation_keys= latest.operation.rotation_keys
78
+
; verification_methods=
79
+
latest.operation.verification_methods
80
+
; services= latest.operation.services } )
81
+
in
82
+
match%lwt Plc.submit_operation did signed with
83
+
| Ok _ ->
84
+
Lwt.return_unit
85
+
| Error (status, msg) ->
86
+
Dream.error (fun log ->
87
+
log ~request:req "%d %s" status msg ) ;
88
+
Errors.internal_error
89
+
~msg:"failed to submit plc operation" () )
90
+
else Lwt.return_unit
91
+
in
92
+
let () =
93
+
Ttl_cache.String_cache.remove Id_resolver.Did.cache did
94
+
in
95
+
let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in
96
+
Dream.empty `OK ) )
+9
pegasus/lib/data_store.ml
+9
pegasus/lib/data_store.ml
···
108
108
record_out]
109
109
id
110
110
111
+
let update_actor_handle =
112
+
[%rapper
113
+
execute
114
+
{sql| UPDATE actors SET handle = %string{handle} WHERE did = %string{did}
115
+
|sql}]
116
+
111
117
let list_actors =
112
118
[%rapper
113
119
get_many
···
196
202
197
203
let get_actor_by_identifier id conn =
198
204
unwrap @@ Queries.get_actor_by_identifier ~id conn
205
+
206
+
let update_actor_handle ~did ~handle conn =
207
+
unwrap @@ Queries.update_actor_handle ~did ~handle conn
199
208
200
209
let try_login ~id ~password conn =
201
210
match%lwt get_actor_by_identifier id conn with
+8
-1
pegasus/lib/errors.ml
+8
-1
pegasus/lib/errors.ml
···
4
4
5
5
exception AuthError of (string * string)
6
6
7
+
let is_xrpc_error = function
8
+
| InvalidRequestError _ | InternalServerError _ | AuthError _ ->
9
+
true
10
+
| _ ->
11
+
false
12
+
7
13
let invalid_request ?(name = "InvalidRequest") msg =
8
14
raise (InvalidRequestError (name, msg))
9
15
···
29
35
format_response "InternalServerError" "Internal server error"
30
36
`Internal_Server_Error
31
37
32
-
let log_exn exn = Dream.error (fun log -> log "%s" (Printexc.to_string exn))
38
+
let log_exn ?req exn =
39
+
Dream.error (fun log -> log ?request:req "%s" (Printexc.to_string exn))
+1
-65
pegasus/lib/id_resolver.ml
+1
-65
pegasus/lib/id_resolver.ml
···
79
79
end
80
80
81
81
module Did = struct
82
-
open struct
83
-
type string_or_strings = [`String of string | `Strings of string list]
84
-
85
-
let string_or_strings_to_yojson = function
86
-
| `String c ->
87
-
`String c
88
-
| `Strings cs ->
89
-
`List (List.map (fun c -> `String c) cs)
90
-
91
-
let string_or_strings_of_yojson = function
92
-
| `String c ->
93
-
Ok (`Strings [c])
94
-
| `List cs ->
95
-
Ok (`Strings (Yojson.Safe.Util.filter_string cs))
96
-
| _ ->
97
-
Error "invalid field value"
98
-
99
-
type string_or_string_map =
100
-
[`String of string | `StringMap of (string * string) list]
101
-
102
-
let string_or_string_map_to_yojson = function
103
-
| `String c ->
104
-
`String c
105
-
| `StringMap m ->
106
-
`Assoc (List.map (fun (k, v) -> (k, `String v)) m)
107
-
108
-
let string_or_string_map_of_yojson = function
109
-
| `String c ->
110
-
Ok (`StringMap [(c, "")])
111
-
| `Assoc m ->
112
-
Ok
113
-
(`StringMap
114
-
(List.map (fun (k, v) -> (k, Yojson.Safe.Util.to_string v)) m) )
115
-
| _ ->
116
-
Error "invalid field value"
117
-
118
-
type string_or_string_map_or_either_list =
119
-
[ `String of string
120
-
| `StringMap of (string * string) list
121
-
| `List of string_or_string_map list ]
122
-
123
-
let string_or_string_map_or_either_list_to_yojson = function
124
-
| `String c ->
125
-
`String c
126
-
| `StringMap m ->
127
-
`Assoc (List.map (fun (k, v) -> (k, `String v)) m)
128
-
| `List l ->
129
-
`List (List.map string_or_string_map_to_yojson l)
130
-
131
-
let string_or_string_map_or_either_list_of_yojson = function
132
-
| `String c ->
133
-
Ok (`StringMap [(c, "")])
134
-
| `Assoc m ->
135
-
Ok
136
-
(`StringMap
137
-
(List.map (fun (k, v) -> (k, Yojson.Safe.Util.to_string v)) m) )
138
-
| `List l ->
139
-
Ok
140
-
(`List
141
-
( List.map string_or_string_map_of_yojson l
142
-
|> List.filter_map (function Ok x -> Some x | Error _ -> None) )
143
-
)
144
-
| _ ->
145
-
Error "invalid field value"
146
-
end
82
+
open Util.Did_doc_types
147
83
148
84
module Document = struct
149
85
type service =
+68
-8
pegasus/lib/plc.ml
+68
-8
pegasus/lib/plc.ml
···
1
+
open Cohttp
2
+
open Cohttp_lwt
3
+
open Cohttp_lwt_unix
4
+
open Util.Did_doc_types
5
+
6
+
let default_endpoint = "https://plc.directory"
7
+
1
8
type t = {did: string; rotation_key: Kleidos.key; endpoint: string}
2
9
3
10
type service = {type': string [@key "type"]; endpoint: string}
4
-
[@@deriving yojson]
11
+
[@@deriving yojson {strict= false}]
5
12
6
13
type unsigned_operation =
7
14
| Operation of
···
13
20
; services: (string * service) list
14
21
; prev: string option }
15
22
| Tombstone of {type': string [@key "type"]; prev: string}
16
-
[@@deriving yojson]
23
+
[@@deriving yojson {strict= false}]
17
24
18
25
let unsigned_operation_to_yojson = function
19
26
| Operation
···
95
102
; signature: string [@key "sig"] }
96
103
| Tombstone of
97
104
{type': string [@key "type"]; prev: string; signature: string [@key "sig"]}
98
-
[@@deriving yojson]
105
+
[@@deriving yojson {strict= false}]
99
106
100
107
let signed_operation_to_yojson = function
101
108
| Operation
···
127
134
| _ ->
128
135
failwith "unexpected json structure" )
129
136
137
+
type audit_log_operation =
138
+
{ signature: string [@key "sig"]
139
+
; prev: string option
140
+
; type': string [@key "type"]
141
+
; services: (string * service) list
142
+
[@to_yojson
143
+
fun l -> `Assoc (List.map (fun (k, v) -> (k, service_to_yojson v)) l)]
144
+
[@of_yojson
145
+
function
146
+
| `Assoc fields ->
147
+
Ok
148
+
(List.filter_map
149
+
(fun (k, v) ->
150
+
match service_of_yojson v with
151
+
| Ok service ->
152
+
Some (k, service)
153
+
| _ ->
154
+
None )
155
+
fields )
156
+
| _ ->
157
+
Error "Expected object for services"]
158
+
; also_known_as: string list [@key "alsoKnownAs"]
159
+
; rotation_keys: string list [@key "rotationKeys"]
160
+
; verification_methods: string_map [@key "verificationMethods"] }
161
+
[@@deriving yojson {strict= false}]
162
+
163
+
type audit_log_entry =
164
+
{ did: string
165
+
; operation: audit_log_operation
166
+
; cid: string
167
+
; nullified: bool
168
+
; created_at: string [@key "createdAt"] }
169
+
[@@deriving yojson {strict= false}]
170
+
171
+
type audit_log = audit_log_entry list [@@deriving yojson {strict= false}]
172
+
130
173
let sign_operation (key : Kleidos.key) operation : signed_operation =
131
174
let sig_privkey, (module Sig_curve) = key in
132
175
let cbor = unsigned_operation_to_yojson operation |> Dag_cbor.encode_yojson in
···
149
192
| Tombstone {type'; prev} ->
150
193
Tombstone {type'; prev; signature= sig_str}
151
194
152
-
let submit_operation ?(endpoint = "https://plc.directory") did operation :
195
+
let submit_operation ?(endpoint = default_endpoint) did operation :
153
196
(unit, int * string) Lwt_result.t =
154
-
let open Cohttp in
155
-
let open Cohttp_lwt_unix in
156
197
let endpoint = Uri.(with_path (of_string endpoint) did) in
157
198
let headers = Header.of_list [("Content-Type", "application/json")] in
158
199
let body =
159
200
operation |> signed_operation_to_yojson |> Yojson.Safe.to_string
160
-
|> Cohttp_lwt.Body.of_string
201
+
|> Body.of_string
161
202
in
162
203
let%lwt res, body = Client.post ~headers ~body endpoint in
163
204
match res.status with
164
205
| `OK ->
165
206
Lwt.return_ok ()
166
207
| _ ->
167
-
let%lwt body_str = Cohttp_lwt.Body.to_string body in
208
+
let%lwt body_str = Body.to_string body in
168
209
Lwt.return_error (Http.Status.to_int res.status, body_str)
169
210
170
211
let did_of_operation operation : string =
···
213
254
| Error (status, error) ->
214
255
Lwt.return_error
215
256
@@ Format.sprintf "error %d while submitting operation; %s" status error
257
+
258
+
let get_audit_log ?endpoint did : (audit_log, string) Lwt_result.t =
259
+
let uri =
260
+
Uri.of_string
261
+
@@ Format.sprintf "%s/%s/log/audit"
262
+
(Option.value endpoint ~default:"https://plc.directory")
263
+
did
264
+
in
265
+
let headers = Http.Header.init_with "Accept" "application/json" in
266
+
let%lwt res, body = Client.get ~headers uri in
267
+
match res.status with
268
+
| `OK ->
269
+
let%lwt body = Body.to_string body in
270
+
Lwt.return @@ audit_log_of_yojson @@ Yojson.Safe.from_string body
271
+
| s ->
272
+
let%lwt body_str = Body.to_string body in
273
+
Lwt.return_error
274
+
@@ Format.sprintf "error %d while fetching audit log; %s"
275
+
(Http.Status.to_int s) body_str
+84
pegasus/lib/util.ml
+84
pegasus/lib/util.ml
···
71
71
end
72
72
end
73
73
74
+
module Did_doc_types = struct
75
+
type string_or_strings = [`String of string | `Strings of string list]
76
+
77
+
let string_or_strings_to_yojson = function
78
+
| `String c ->
79
+
`String c
80
+
| `Strings cs ->
81
+
`List (List.map (fun c -> `String c) cs)
82
+
83
+
let string_or_strings_of_yojson = function
84
+
| `String c ->
85
+
Ok (`Strings [c])
86
+
| `List cs ->
87
+
Ok (`Strings (Yojson.Safe.Util.filter_string cs))
88
+
| _ ->
89
+
Error "invalid field value"
90
+
91
+
type string_map = (string * string) list
92
+
93
+
let string_map_to_yojson = function
94
+
| [] ->
95
+
`Assoc []
96
+
| m ->
97
+
`Assoc (List.map (fun (k, v) -> (k, `String v)) m)
98
+
99
+
let string_map_of_yojson = function
100
+
| `Null ->
101
+
Ok []
102
+
| `Assoc m ->
103
+
Ok
104
+
(List.filter_map
105
+
(fun (k, v) ->
106
+
match (k, v) with _, `String s -> Some (k, s) | _, _ -> None )
107
+
m )
108
+
| _ ->
109
+
Error "invalid field value"
110
+
111
+
type string_or_string_map = [`String of string | `StringMap of string_map]
112
+
113
+
let string_or_string_map_to_yojson = function
114
+
| `String c ->
115
+
`String c
116
+
| `StringMap m ->
117
+
`Assoc (List.map (fun (k, v) -> (k, `String v)) m)
118
+
119
+
let string_or_string_map_of_yojson = function
120
+
| `String c ->
121
+
Ok (`StringMap [(c, "")])
122
+
| `Assoc m ->
123
+
Ok
124
+
(`StringMap
125
+
(List.map (fun (k, v) -> (k, Yojson.Safe.Util.to_string v)) m) )
126
+
| _ ->
127
+
Error "invalid field value"
128
+
129
+
type string_or_string_map_or_either_list =
130
+
[ `String of string
131
+
| `StringMap of string_map
132
+
| `List of string_or_string_map list ]
133
+
134
+
let string_or_string_map_or_either_list_to_yojson = function
135
+
| `String c ->
136
+
`String c
137
+
| `StringMap m ->
138
+
`Assoc (List.map (fun (k, v) -> (k, `String v)) m)
139
+
| `List l ->
140
+
`List (List.map string_or_string_map_to_yojson l)
141
+
142
+
let string_or_string_map_or_either_list_of_yojson = function
143
+
| `String c ->
144
+
Ok (`StringMap [(c, "")])
145
+
| `Assoc m ->
146
+
Ok
147
+
(`StringMap
148
+
(List.map (fun (k, v) -> (k, Yojson.Safe.Util.to_string v)) m) )
149
+
| `List l ->
150
+
Ok
151
+
(`List
152
+
( List.map string_or_string_map_of_yojson l
153
+
|> List.filter_map (function Ok x -> Some x | Error _ -> None) ) )
154
+
| _ ->
155
+
Error "invalid field value"
156
+
end
157
+
74
158
(* turns a caqti error into an exception *)
75
159
let caqti_result_exn = function
76
160
| Ok x ->
+7
-1
pegasus/lib/xrpc.ml
+7
-1
pegasus/lib/xrpc.ml
···
13
13
match%lwt auth init with
14
14
| Ok creds -> (
15
15
try%lwt hdlr {req= init.req; db= init.db; auth= creds}
16
-
with e -> log_exn e ; exn_to_response e )
16
+
with e ->
17
+
( match is_xrpc_error e with
18
+
| true ->
19
+
()
20
+
| false ->
21
+
log_exn ~req:init.req e ) ;
22
+
exn_to_response e )
17
23
| Error e ->
18
24
exn_to_response e
19
25