objective categorical abstract machine language personal data server
xrpc createInviteCode
+94
-8
+11
-5
bin/main.ml
+11
-5
bin/main.ml
···
11
11
( get
12
12
, "/xrpc/com.atproto.server.describeServer"
13
13
, Api.Server.DescribeServer.handler )
14
+
; (get, "/xrpc/com.atproto.repo.describeRepo", Api.Repo.DescribeRepo.handler)
14
15
; ( get
15
16
, "/xrpc/com.atproto.identity.resolveHandle"
16
17
, Api.Identity.ResolveHandle.handler )
18
+
; (* account *)
19
+
( post
20
+
, "/xrpc/com.atproto.server.createInviteCode"
21
+
, Api.Server.CreateInviteCode.handler )
22
+
; ( post
23
+
, "/xrpc/com.atproto.repo.createAccount"
24
+
, Api.Repo.CreateAccount.handler )
17
25
; ( post
18
26
, "/xrpc/com.atproto.server.createSession"
19
27
, Api.Server.CreateSession.handler )
20
-
; (get, "/xrpc/com.atproto.repo.getRecord", Api.Repo.GetRecord.handler)
21
-
; (get, "/xrpc/com.atproto.repo.listRecords", Api.Repo.ListRecords.handler)
22
-
; (get, "/xrpc/com.atproto.repo.describeRepo", Api.Repo.DescribeRepo.handler)
23
-
; (* account *)
24
-
(get, "/xrpc/com.atproto.server.getSession", Api.Server.GetSession.handler)
28
+
; (get, "/xrpc/com.atproto.server.getSession", Api.Server.GetSession.handler)
25
29
; ( post
26
30
, "/xrpc/com.atproto.server.refreshSession"
27
31
, Api.Server.RefreshSession.handler )
···
35
39
(post, "/xrpc/com.atproto.repo.applyWrites", Api.Repo.ApplyWrites.handler)
36
40
; (post, "/xrpc/com.atproto.repo.createRecord", Api.Repo.CreateRecord.handler)
37
41
; (post, "/xrpc/com.atproto.repo.putRecord", Api.Repo.PutRecord.handler)
42
+
; (get, "/xrpc/com.atproto.repo.getRecord", Api.Repo.GetRecord.handler)
43
+
; (get, "/xrpc/com.atproto.repo.listRecords", Api.Repo.ListRecords.handler)
38
44
; (post, "/xrpc/com.atproto.repo.deleteRecord", Api.Repo.DeleteRecord.handler)
39
45
; (post, "/xrpc/com.atproto.repo.uploadBlob", Api.Repo.UploadBlob.handler)
40
46
; (* sync *)
+27
-3
pegasus/lib/api/repo/createAccount.ml
+27
-3
pegasus/lib/api/repo/createAccount.ml
···
17
17
let handler =
18
18
Xrpc.handler (fun ctx ->
19
19
let%lwt input = Xrpc.parse_body ctx.req request_of_yojson in
20
-
if input.invite_code = None && Env.invite_required = true then
21
-
Errors.invalid_request ~name:"InvalidInviteCode"
22
-
"no invite code provided" ;
20
+
let%lwt () =
21
+
match input.invite_code with
22
+
| None when Env.invite_required = true ->
23
+
Errors.invalid_request ~name:"InvalidInviteCode"
24
+
"no invite code provided"
25
+
| Some code when Env.invite_required = true -> (
26
+
let%lwt invite = Data_store.get_invite ~code ctx.db in
27
+
match invite with
28
+
| Some i when i.remaining > 0 ->
29
+
Lwt.return_unit
30
+
| _ ->
31
+
Errors.invalid_request ~name:"InvalidInviteCode"
32
+
"invalid invite code" )
33
+
| _ ->
34
+
Lwt.return_unit
35
+
in
23
36
let () =
24
37
match Util.validate_handle input.handle with
25
38
| Ok _ ->
···
69
82
Lwt.return did
70
83
| Error e ->
71
84
failwith e )
85
+
in
86
+
let%lwt _ =
87
+
match input.invite_code with
88
+
| Some code -> (
89
+
match%lwt Data_store.use_invite ~code ctx.db with
90
+
| Some _ ->
91
+
Lwt.return ()
92
+
| None ->
93
+
failwith "failed to use invite code" )
94
+
| None ->
95
+
Lwt.return ()
72
96
in
73
97
let sk_priv_mk = Kleidos.P256.privkey_to_multikey signing_key in
74
98
let%lwt () =
+22
pegasus/lib/api/server/createInviteCode.ml
+22
pegasus/lib/api/server/createInviteCode.ml
···
1
+
type request =
2
+
{ use_count: int [@key "useCount"]
3
+
; for_account: string option [@key "forAccount"] }
4
+
[@@deriving yojson]
5
+
6
+
type response = {code: string} [@@deriving yojson]
7
+
8
+
let handler =
9
+
Xrpc.handler ~auth:Auth.Verifiers.admin (fun {req; db; _} ->
10
+
let%lwt {use_count; for_account} =
11
+
Xrpc.parse_body req request_of_yojson
12
+
in
13
+
let remaining = Int.max 1 (Int.min use_count 5) in
14
+
let did = Option.value for_account ~default:"admin" in
15
+
let code =
16
+
String.sub
17
+
Digestif.SHA256.(
18
+
digest_string (did ^ Int.to_string @@ Util.now_ms ()) |> to_hex )
19
+
0 8
20
+
in
21
+
let%lwt () = Data_store.create_invite ~code ~did ~remaining db in
22
+
Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {code} )
+34
pegasus/lib/data_store.ml
+34
pegasus/lib/data_store.ml
···
13
13
; created_at: int
14
14
; deactivated_at: int option }
15
15
16
+
type invite_code = {code: string; did: string; remaining: int}
17
+
16
18
type firehose_event = {seq: int; time: int; t: string; data: bytes}
17
19
end
18
20
···
131
133
{sql| UPDATE actors SET preferences = %Json{preferences} WHERE did = %string{did}
132
134
|sql}]
133
135
136
+
(* invites *)
137
+
let create_invite =
138
+
[%rapper
139
+
execute
140
+
{sql| INSERT INTO invite_codes (code, did, remaining)
141
+
VALUES (%string{code}, %string{did}, %int{remaining})
142
+
|sql}]
143
+
144
+
let get_invite =
145
+
[%rapper
146
+
get_opt
147
+
{sql| SELECT @string{code}, @string{did}, @int{remaining}
148
+
FROM invite_codes WHERE code = %string{code}
149
+
|sql}
150
+
record_out]
151
+
152
+
let use_invite =
153
+
[%rapper
154
+
get_opt
155
+
{sql| UPDATE invite_codes SET remaining = remaining - 1
156
+
WHERE code = %string{code} AND remaining > 0
157
+
RETURNING @int{remaining}
158
+
|sql}]
159
+
134
160
(* firehose *)
135
161
let firehose_insert =
136
162
[%rapper
···
228
254
229
255
let put_preferences ~did ~prefs conn =
230
256
unwrap @@ Queries.put_preferences ~did ~preferences:prefs conn
257
+
258
+
(* invite codes *)
259
+
let create_invite ~code ~did ~remaining conn =
260
+
unwrap @@ Queries.create_invite ~code ~did ~remaining conn
261
+
262
+
let get_invite ~code conn = unwrap @@ Queries.get_invite ~code conn
263
+
264
+
let use_invite ~code conn = unwrap @@ Queries.use_invite ~code conn
231
265
232
266
(* firehose helpers *)
233
267
let append_firehose_event conn ~time ~t ~data : int Lwt.t =