objective categorical abstract machine language personal data server
xrpc confirmEmail, updateEmail, createInviteCodes
+143
-6
+9
bin/main.ml
+9
bin/main.ml
···
39
39
, "/xrpc/com.atproto.server.createInviteCode"
40
40
, Api.Server.CreateInviteCode.handler )
41
41
; ( post
42
+
, "/xrpc/com.atproto.server.createInviteCodes"
43
+
, Api.Server.CreateInviteCodes.handler )
44
+
; ( post
42
45
, "/xrpc/com.atproto.server.createAccount"
43
46
, Api.Server.CreateAccount.handler )
44
47
; ( post
···
64
67
, "/xrpc/com.atproto.server.requestEmailUpdate"
65
68
, Api.Server.RequestEmailUpdate.handler )
66
69
; ( post
70
+
, "/xrpc/com.atproto.server.confirmEmail"
71
+
, Api.Server.ConfirmEmail.handler )
72
+
; ( post
67
73
, "/xrpc/com.atproto.server.requestPasswordReset"
68
74
, Api.Server.RequestPasswordReset.handler )
69
75
; ( post
···
87
93
; ( post
88
94
, "/xrpc/com.atproto.identity.updateHandle"
89
95
, Api.Identity.UpdateHandle.handler )
96
+
; ( post
97
+
, "/xrpc/com.atproto.server.updateEmail"
98
+
, Api.Server.UpdateEmail.handler )
90
99
; (* plc *)
91
100
( get
92
101
, "/xrpc/com.atproto.identity.getRecommendedDidCredentials"
+28
pegasus/lib/api/server/confirmEmail.ml
+28
pegasus/lib/api/server/confirmEmail.ml
···
1
+
type request = {email: string; token: string} [@@deriving yojson {strict= false}]
2
+
3
+
let handler =
4
+
Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} ->
5
+
Auth.assert_account_scope auth ~attr:Oauth.Scopes.Email
6
+
~action:Oauth.Scopes.Manage ;
7
+
let did = Auth.get_authed_did_exn auth in
8
+
let%lwt {email; token} = Xrpc.parse_body req request_of_yojson in
9
+
let email = String.lowercase_ascii email in
10
+
match%lwt Data_store.get_actor_by_identifier did db with
11
+
| None ->
12
+
Errors.invalid_request ~name:"AccountNotFound" "account not found"
13
+
| Some actor ->
14
+
if String.lowercase_ascii actor.email <> email then
15
+
Errors.invalid_request ~name:"InvalidEmail" "email does not match"
16
+
else (
17
+
match (actor.auth_code, actor.auth_code_expires_at) with
18
+
| Some auth_code, Some expires_at
19
+
when String.starts_with ~prefix:"eml-" auth_code
20
+
&& auth_code = token
21
+
&& Util.now_ms () < expires_at ->
22
+
let%lwt () = Data_store.confirm_email ~did db in
23
+
Dream.log "email confirmed for %s" did ;
24
+
Dream.empty `OK
25
+
| Some _, Some expires_at when Util.now_ms () >= expires_at ->
26
+
Errors.invalid_request ~name:"ExpiredToken" "token expired"
27
+
| _ ->
28
+
Errors.invalid_request ~name:"InvalidToken" "invalid token" ) )
+6
-6
pegasus/lib/api/server/createInviteCode.ml
+6
-6
pegasus/lib/api/server/createInviteCode.ml
···
5
5
6
6
type response = {code: string} [@@deriving yojson {strict= false}]
7
7
8
+
let generate_code did =
9
+
String.sub
10
+
Digestif.SHA256.(digest_string (did ^ Mist.Tid.now ()) |> to_hex)
11
+
0 8
12
+
8
13
let handler =
9
14
Xrpc.handler ~auth:Admin (fun {req; db; _} ->
10
15
let%lwt {use_count; for_account} =
···
12
17
in
13
18
let remaining = Int.max 1 (Int.min use_count 5) in
14
19
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
20
+
let code = generate_code did in
21
21
let%lwt () = Data_store.create_invite ~code ~did ~remaining db in
22
22
Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {code} )
+36
pegasus/lib/api/server/createInviteCodes.ml
+36
pegasus/lib/api/server/createInviteCodes.ml
···
1
+
type request =
2
+
{ code_count: int [@key "codeCount"] [@default 1]
3
+
; use_count: int [@key "useCount"]
4
+
; for_accounts: string list option [@key "forAccounts"] [@default None] }
5
+
[@@deriving yojson {strict= false}]
6
+
7
+
type account_codes = {account: string; codes: string list} [@@deriving yojson]
8
+
9
+
type response = {codes: account_codes list} [@@deriving yojson]
10
+
11
+
let handler =
12
+
Xrpc.handler ~auth:Admin (fun {req; db; _} ->
13
+
let%lwt {code_count; use_count; for_accounts} =
14
+
Xrpc.parse_body req request_of_yojson
15
+
in
16
+
let code_count = Int.max 1 (Int.min code_count 100) in
17
+
let use_count = Int.max 1 (Int.min use_count 100) in
18
+
let accounts = Option.value for_accounts ~default:["admin"] in
19
+
let%lwt codes =
20
+
Lwt_list.map_s
21
+
(fun account ->
22
+
let%lwt account_codes =
23
+
Lwt_list.map_s
24
+
(fun _ ->
25
+
let code = CreateInviteCode.generate_code account in
26
+
let%lwt () =
27
+
Data_store.create_invite ~code ~did:account
28
+
~remaining:use_count db
29
+
in
30
+
Lwt.return code )
31
+
(List.init code_count (fun i -> i))
32
+
in
33
+
Lwt.return {account; codes= account_codes} )
34
+
accounts
35
+
in
36
+
Dream.json @@ Yojson.Safe.to_string @@ response_to_yojson {codes} )
+43
pegasus/lib/api/server/updateEmail.ml
+43
pegasus/lib/api/server/updateEmail.ml
···
1
+
type request =
2
+
{ email: string
3
+
; email_auth_factor: bool option [@key "emailAuthFactor"] [@default None]
4
+
; token: string option [@default None] }
5
+
[@@deriving yojson {strict= false}]
6
+
7
+
let handler =
8
+
Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} ->
9
+
Auth.assert_account_scope auth ~attr:Oauth.Scopes.Email
10
+
~action:Oauth.Scopes.Manage ;
11
+
let did = Auth.get_authed_did_exn auth in
12
+
let%lwt {email; token; _} = Xrpc.parse_body req request_of_yojson in
13
+
let email = String.lowercase_ascii email in
14
+
match%lwt Data_store.get_actor_by_identifier did db with
15
+
| None ->
16
+
Errors.internal_error ~msg:"actor not found" ()
17
+
| Some actor -> (
18
+
match actor.email_confirmed_at with
19
+
| Some _ -> (
20
+
(* email is confirmed, require valid token *)
21
+
match token with
22
+
| None ->
23
+
Errors.invalid_request ~name:"TokenRequired"
24
+
"confirmation token required"
25
+
| Some token -> (
26
+
match (actor.auth_code, actor.auth_code_expires_at) with
27
+
| Some auth_code, Some expires_at
28
+
when String.starts_with ~prefix:"eml-" auth_code
29
+
&& auth_code = token
30
+
&& Util.now_ms () < expires_at ->
31
+
let%lwt () = Data_store.update_email ~did ~email db in
32
+
Dream.log "email updated for %s to %s" did email ;
33
+
Dream.empty `OK
34
+
| Some _, Some expires_at when Util.now_ms () >= expires_at ->
35
+
Errors.invalid_request ~name:"ExpiredToken" "token expired"
36
+
| _ ->
37
+
Errors.invalid_request ~name:"InvalidToken" "invalid token" )
38
+
)
39
+
| None ->
40
+
(* email not confirmed, no token required *)
41
+
let%lwt () = Data_store.update_email ~did ~email db in
42
+
Dream.log "email updated for %s to %s" did email ;
43
+
Dream.empty `OK ) )
+21
pegasus/lib/data_store.ml
+21
pegasus/lib/data_store.ml
···
196
196
WHERE did = %string{did}
197
197
|sql}]
198
198
199
+
let update_email =
200
+
[%rapper
201
+
execute
202
+
{sql| UPDATE actors SET email = %string{email}, email_confirmed_at = NULL, auth_code = NULL, auth_code_expires_at = NULL
203
+
WHERE did = %string{did}
204
+
|sql}]
205
+
206
+
let confirm_email =
207
+
[%rapper
208
+
execute
209
+
{sql| UPDATE actors SET email_confirmed_at = %int{confirmed_at}, auth_code = NULL, auth_code_expires_at = NULL
210
+
WHERE did = %string{did}
211
+
|sql}]
212
+
199
213
(* firehose *)
200
214
let firehose_insert =
201
215
[%rapper
···
340
354
let update_password ~did ~password conn =
341
355
let password_hash = Bcrypt.hash password |> Bcrypt.string_of_hash in
342
356
Util.use_pool conn @@ Queries.update_password ~did ~password_hash
357
+
358
+
let update_email ~did ~email conn =
359
+
Util.use_pool conn @@ Queries.update_email ~did ~email
360
+
361
+
let confirm_email ~did conn =
362
+
let confirmed_at = Util.now_ms () in
363
+
Util.use_pool conn @@ Queries.confirm_email ~did ~confirmed_at
343
364
344
365
(* firehose helpers *)
345
366
let append_firehose_event conn ~time ~t ~data : int Lwt.t =