objective categorical abstract machine language personal data server
xrpc applyWrites, createRecord
+160
-32
+6
bin/main.ml
+6
bin/main.ml
···
28
28
; ( post
29
29
, "/xrpc/com.atproto.server.deleteSession"
30
30
, Api.Server.DeleteSession.handler )
31
+
; ( post
32
+
, "/xrpc/com.atproto.identity.updateHandle"
33
+
, Api.Identity.UpdateHandle.handler )
34
+
; (* repo *)
35
+
(post, "/xrpc/com.atproto.repo.applyWrites", Api.Repo.ApplyWrites.handler)
36
+
; (post, "/xrpc/com.atproto.repo.createRecord", Api.Repo.CreateRecord.handler)
31
37
; (* preferences *)
32
38
( get
33
39
, "/xrpc/com.atproto.actor.getPreferences"
+1
-1
pegasus/lib/api/identity/updateHandle.ml
+1
-1
pegasus/lib/api/identity/updateHandle.ml
+42
pegasus/lib/api/repo/applyWrites.ml
+42
pegasus/lib/api/repo/applyWrites.ml
···
1
+
type request =
2
+
{ repo: string
3
+
; validate: bool option
4
+
; writes: Repository.repo_write list
5
+
; swap_commit: Cid.t option [@key "swapCommit"] }
6
+
[@@deriving yojson]
7
+
8
+
type response =
9
+
{commit: res_commit option; results: Repository.apply_writes_result list}
10
+
[@@deriving yojson]
11
+
12
+
and res_commit = {cid: Cid.t; rev: string} [@@deriving yojson]
13
+
14
+
let handler =
15
+
Xrpc.handler ~auth:Auth.Verifiers.authorization (fun ctx ->
16
+
let%lwt input = Xrpc.parse_body ctx.req request_of_yojson in
17
+
let%lwt input_did =
18
+
if String.starts_with ~prefix:"did:" input.repo then
19
+
Lwt.return input.repo
20
+
else
21
+
match%lwt Data_store.get_actor_by_identifier input.repo ctx.db with
22
+
| Some {did; _} ->
23
+
Lwt.return did
24
+
| None ->
25
+
Errors.invalid_request "target repository not found"
26
+
in
27
+
let did =
28
+
match ctx.auth with
29
+
| Access {did} when did = input_did ->
30
+
did
31
+
| Admin ->
32
+
input_did
33
+
| _ ->
34
+
Errors.auth_required
35
+
"authentication does not match target repository"
36
+
in
37
+
let%lwt repo = Repository.load did in
38
+
let%lwt {commit= commit_cid, {rev; _}; results} =
39
+
Repository.apply_writes repo input.writes input.swap_commit
40
+
in
41
+
Dream.json @@ Yojson.Safe.to_string
42
+
@@ response_to_yojson {commit= Some {cid= commit_cid; rev}; results} )
+76
pegasus/lib/api/repo/createRecord.ml
+76
pegasus/lib/api/repo/createRecord.ml
···
1
+
type request =
2
+
{ repo: string
3
+
; collection: string
4
+
; rkey: string option
5
+
; validate: bool option
6
+
; record: Mist.Lex.repo_record
7
+
; swap_record: Cid.t option [@key "swapRecord"]
8
+
; swap_commit: Cid.t option [@key "swapCommit"] }
9
+
[@@deriving yojson]
10
+
11
+
type response =
12
+
{ uri: string
13
+
; cid: Cid.t
14
+
; commit: res_commit option
15
+
; validation_status: string option [@key "validationStatus"] }
16
+
[@@deriving yojson]
17
+
18
+
and res_commit = {cid: Cid.t; rev: string} [@@deriving yojson]
19
+
20
+
let handler =
21
+
Xrpc.handler ~auth:Auth.Verifiers.authorization (fun ctx ->
22
+
let%lwt input = Xrpc.parse_body ctx.req request_of_yojson in
23
+
let%lwt input_did =
24
+
if String.starts_with ~prefix:"did:" input.repo then
25
+
Lwt.return input.repo
26
+
else
27
+
match%lwt Data_store.get_actor_by_identifier input.repo ctx.db with
28
+
| Some {did; _} ->
29
+
Lwt.return did
30
+
| None ->
31
+
Errors.invalid_request "target repository not found"
32
+
in
33
+
let did =
34
+
match ctx.auth with
35
+
| Access {did} when did = input_did ->
36
+
did
37
+
| Admin ->
38
+
input_did
39
+
| _ ->
40
+
Errors.auth_required
41
+
"authentication does not match target repository"
42
+
in
43
+
let%lwt repo = Repository.load did in
44
+
let write : Repository.repo_write =
45
+
match input.swap_record with
46
+
| Some swap_record -> (
47
+
match input.rkey with
48
+
| Some rkey ->
49
+
Update
50
+
{ type'= Repository.Write_op.update
51
+
; collection= input.collection
52
+
; rkey
53
+
; value= input.record
54
+
; swap_record= Some swap_record }
55
+
| None ->
56
+
Errors.invalid_request "rkey is required for swap_record" )
57
+
| None ->
58
+
Create
59
+
{ type'= Repository.Write_op.create
60
+
; collection= input.collection
61
+
; rkey= input.rkey
62
+
; value= input.record }
63
+
in
64
+
let%lwt {commit= commit_cid, {rev; _}; results} =
65
+
Repository.apply_writes repo [write] input.swap_commit
66
+
in
67
+
match List.hd results with
68
+
| Create {uri; cid; _} | Update {uri; cid; _} ->
69
+
Dream.json @@ Yojson.Safe.to_string
70
+
@@ response_to_yojson
71
+
{ uri
72
+
; cid
73
+
; commit= Some {cid= commit_cid; rev}
74
+
; validation_status= Some "valid" }
75
+
| _ ->
76
+
Errors.invalid_request "unexpected delete result" )
+35
-31
pegasus/lib/repository.ml
+35
-31
pegasus/lib/repository.ml
···
4
4
module StringMap = Lex.StringMap
5
5
module Tid = Mist.Tid
6
6
7
+
module Write_op = struct
8
+
let create = "com.atproto.repo.applyWrites#create"
9
+
10
+
let update = "com.atproto.repo.applyWrites#update"
11
+
12
+
let delete = "com.atproto.repo.applyWrites#delete"
13
+
end
14
+
7
15
type signing_key = P256 of bytes | K256 of bytes
8
16
9
17
type repo_write =
10
18
| Create of
11
-
{ type': string [@key "$type"]
19
+
{ type': string [@key "$type"] [@default Write_op.create]
12
20
; collection: string
13
21
; rkey: string option
14
22
; value: Lex.repo_record }
15
23
| Update of
16
-
{ type': string [@key "$type"]
24
+
{ type': string [@key "$type"] [@default Write_op.update]
17
25
; collection: string
18
26
; rkey: string
19
27
; value: Lex.repo_record
20
28
; swap_record: Cid.t option [@key "swapRecord"] }
21
29
| Delete of
22
-
{ type': string [@key "$type"]
30
+
{ type': string [@key "$type"] [@default Write_op.delete]
23
31
; collection: string
24
32
; rkey: string
25
33
; swap_record: Cid.t option [@key "swapRecord"] }
26
-
[@@deriving yojson]
34
+
[@@deriving yojson {strict= false}]
27
35
28
36
let repo_write_of_yojson (json : Yojson.Safe.t) =
29
37
let open Yojson.Safe.Util in
···
42
50
let value =
43
51
member "value" json |> Lex.repo_record_of_yojson |> Result.get_ok
44
52
in
45
-
Create {type'; collection; rkey; value}
53
+
Ok (Create {type'; collection; rkey; value})
46
54
| "com.atproto.repo.applyWrites#update" ->
47
55
let value =
48
56
member "value" json |> Lex.repo_record_of_yojson |> Result.get_ok
49
57
in
50
-
Update {type'; collection; rkey= Option.get rkey; value; swap_record}
58
+
Ok (Update {type'; collection; rkey= Option.get rkey; value; swap_record})
51
59
| "com.atproto.repo.applyWrites#delete" ->
52
-
Delete {type'; collection; rkey= Option.get rkey; swap_record}
60
+
Ok (Delete {type'; collection; rkey= Option.get rkey; swap_record})
53
61
| _ ->
54
-
raise (Invalid_argument "invalid applyWrites write $type")
62
+
Error "invalid applyWrites write $type"
55
63
56
64
let repo_write_to_yojson = function
57
65
| Create {type'; collection; rkey; value} ->
···
99
107
let cid =
100
108
member "cid" json |> to_string |> Cid.of_string |> Result.get_ok
101
109
in
102
-
Create {type'; uri; cid}
110
+
Ok (Create {type'; uri; cid})
103
111
| "com.atproto.repo.applyWrites#updateResult" ->
104
112
let uri = member "uri" json |> to_string in
105
113
let cid =
106
114
member "cid" json |> to_string |> Cid.of_string |> Result.get_ok
107
115
in
108
-
Update {type'; uri; cid}
116
+
Ok (Update {type'; uri; cid})
109
117
| "com.atproto.repo.applyWrites#deleteResult" ->
110
-
Delete {type'}
118
+
Ok (Delete {type'})
111
119
| _ ->
112
-
failwith "invalid applyWrites result $type"
120
+
Error "invalid applyWrites result $type"
113
121
114
122
let apply_writes_result_to_yojson = function
115
123
| Create {type'; uri; cid} ->
···
243
251
failwith ("failed to retrieve commit for " ^ t.did)
244
252
in
245
253
if swap_commit <> None && swap_commit <> t.commit then
246
-
raise
247
-
(Errors.invalid_request ~name:"InvalidSwap"
248
-
(Format.sprintf "swapCommit cid %s did not match last commit cid %s"
249
-
(Cid.to_string (Option.get swap_commit))
250
-
(match t.commit with Some c -> Cid.to_string c | None -> "null") ) ) ;
254
+
Errors.invalid_request ~name:"InvalidSwap"
255
+
(Format.sprintf "swapCommit cid %s did not match last commit cid %s"
256
+
(Cid.to_string (Option.get swap_commit))
257
+
(match t.commit with Some c -> Cid.to_string c | None -> "null") ) ;
251
258
let%lwt block_map = Lwt.map ref (get_map t) in
252
259
let%lwt results =
253
260
List.map
···
260
267
let%lwt () =
261
268
match StringMap.find_opt path !block_map with
262
269
| Some cid ->
263
-
raise
264
-
(Errors.invalid_request ~name:"InvalidSwap"
265
-
(Format.sprintf
266
-
"attempted to write record %s that already exists \
267
-
with cid %s"
268
-
path (Cid.to_string cid) ) )
270
+
Errors.invalid_request ~name:"InvalidSwap"
271
+
(Format.sprintf
272
+
"attempted to write record %s that already exists with \
273
+
cid %s"
274
+
path (Cid.to_string cid) )
269
275
| None ->
270
276
Lwt.return ()
271
277
in
···
307
313
| None ->
308
314
"null"
309
315
in
310
-
raise
311
-
(Errors.invalid_request ~name:"InvalidSwap"
312
-
(Format.sprintf "attempted to update record %s with cid %s"
313
-
path cid_str ) ) ) ;
316
+
Errors.invalid_request ~name:"InvalidSwap"
317
+
(Format.sprintf "attempted to update record %s with cid %s"
318
+
path cid_str ) ) ;
314
319
let%lwt () =
315
320
match old_cid with
316
321
| Some _ -> (
···
351
356
| None ->
352
357
"null"
353
358
in
354
-
raise
355
-
(Errors.invalid_request ~name:"InvalidSwap"
356
-
(Format.sprintf "attempted to delete record %s with cid %s"
357
-
path cid_str ) ) ) ;
359
+
Errors.invalid_request ~name:"InvalidSwap"
360
+
(Format.sprintf "attempted to delete record %s with cid %s"
361
+
path cid_str ) ) ;
358
362
let%lwt () =
359
363
match%lwt User_store.get_record_by_path t.db path with
360
364
| Some record ->