objective categorical abstract machine language personal data server
Update migration logic to use hermes
+648
-896
+12
hermes/lib/credential_manager.ml
+12
hermes/lib/credential_manager.ml
···
25
25
-> unit
26
26
-> Client.t Lwt.t
27
27
28
+
val login_client :
29
+
t
30
+
-> Client.t
31
+
-> identifier:string
32
+
-> password:string
33
+
-> ?auth_factor_token:string
34
+
-> unit
35
+
-> Client.t Lwt.t
36
+
28
37
val resume : t -> session:Types.session -> unit -> Client.t Lwt.t
29
38
30
39
val logout : t -> unit Lwt.t
···
68
77
69
78
let rec login t ~identifier ~password ?auth_factor_token () =
70
79
let client = make_raw_client t in
80
+
login_client t client ~identifier ~password ?auth_factor_token ()
81
+
82
+
and login_client t client ~identifier ~password ?auth_factor_token () =
71
83
let input =
72
84
Types.login_request_to_yojson
73
85
{Types.identifier; password; auth_factor_token}
+10
-12
pegasus/lib/api/account_/identity.ml
+10
-12
pegasus/lib/api/account_/identity.ml
···
21
21
let is_plc = String.starts_with ~prefix:"did:plc:" did in
22
22
let%lwt credentials_json =
23
23
if is_plc then
24
-
match%lwt
25
-
Identity.GetRecommendedDidCredentials.get_credentials did ctx.db
26
-
with
27
-
| Ok credentials ->
24
+
match%lwt Data_store.get_actor_by_identifier did ctx.db with
25
+
| Some {handle; signing_key; _} ->
28
26
Lwt.return_some
29
-
( Plc.credentials_to_yojson credentials
27
+
( Plc.get_recommended_credentials ~handle ~signing_key ()
28
+
|> Plc.credentials_to_yojson
30
29
|> Yojson.Safe.pretty_to_string )
31
-
| Error _ ->
30
+
| None ->
32
31
Lwt.return_none
33
32
else Lwt.return_none
34
33
in
···
118
117
(Yojson.Safe.to_string
119
118
(post_response_to_yojson {error= Some e}) )
120
119
| Ok () -> (
121
-
match%lwt
122
-
Plc.submit_operation did signed_op
123
-
with
120
+
match%lwt Plc.submit_operation did signed_op with
124
121
| Ok () ->
125
122
let%lwt _ =
126
123
Sequencer.sequence_identity ctx.db ~did ()
···
136
133
{ error=
137
134
Some
138
135
( "The directory returned an \
139
-
error: " ^ msg ) } ) ) ) )
140
-
) ) )
136
+
error: " ^ msg ) } ) ) ) ) )
137
+
) )
141
138
| _ ->
142
139
Dream.json ~status:`Bad_Request
143
140
(Yojson.Safe.to_string
144
-
(post_response_to_yojson {error= Some "Invalid action"}) ) )
141
+
(post_response_to_yojson
142
+
{error= Some "Invalid action"} ) ) )
145
143
| _ ->
146
144
Dream.json ~status:`Bad_Request
147
145
(Yojson.Safe.to_string
+467
-474
pegasus/lib/api/account_/migrate/migrate.ml
+467
-474
pegasus/lib/api/account_/migrate/migrate.ml
···
1
1
(* account migration handlers *)
2
+
open Lexicons
3
+
4
+
(* helper to serialize session with pds_uri guaranteed to be set *)
5
+
let session_to_yojson_with_pds ~old_pds session =
6
+
let session_with_pds =
7
+
match session.Hermes.pds_uri with
8
+
| Some _ ->
9
+
session
10
+
| None ->
11
+
{session with pds_uri= Some old_pds}
12
+
in
13
+
Hermes.session_to_yojson session_with_pds
2
14
3
15
let make_props ~csrf_token ~invite_required ~hostname
4
16
?(step = "enter_credentials") ?did ?handle ?old_pds ?identifier ?invite_code
···
41
53
-> string
42
54
-> Dream.response Lwt.t
43
55
56
+
let resume_from_state ~old_pds session_json =
57
+
match Hermes.session_of_yojson session_json with
58
+
| Error e ->
59
+
Lwt.return_error ("Invalid session state: " ^ e)
60
+
| Ok session ->
61
+
let manager = Hermes.make_credential_manager ~service:old_pds () in
62
+
let%lwt client = Hermes.resume manager ~session () in
63
+
Lwt.return_ok client
64
+
44
65
(* transition to plc token step after data import *)
45
-
let transition_to_plc_token_step ctx ~did ~handle ~old_pds ~access_jwt
46
-
~refresh_jwt ~email ~blobs_imported ~blobs_failed =
66
+
let transition_to_plc_token_step ctx ~old_client ~old_pds ~did ~handle ~email
67
+
~blobs_imported ~blobs_failed =
47
68
let csrf_token = Dream.csrf_token ctx.Xrpc.req in
48
69
let invite_required = Env.invite_required in
49
70
let hostname = Env.hostname in
71
+
let session = Hermes.get_session old_client in
50
72
(* import preferences before transitioning *)
51
73
let%lwt () =
52
-
match%lwt Remote.fetch_preferences ~pds_endpoint:old_pds ~access_jwt with
74
+
match%lwt Remote.fetch_preferences old_client with
53
75
| Ok prefs ->
54
-
Data_store.put_preferences ~did ~prefs ctx.db
76
+
Data_store.put_preferences ~did
77
+
~prefs:(App_bsky_actor_defs.preferences_to_yojson prefs)
78
+
ctx.db
55
79
| _ ->
56
80
Lwt.return_unit
57
81
in
···
61
85
| Ok true ->
62
86
let%lwt () = Ops.activate_account did ctx.db in
63
87
let%lwt () = Session.log_in_did ctx.req did in
64
-
let%lwt deactivation_result =
65
-
Remote.deactivate_account ~pds_endpoint:old_pds ~access_jwt
66
-
in
88
+
let%lwt deactivation_result = Remote.deactivate_account old_client in
67
89
let old_account_deactivated, old_account_deactivation_error =
68
90
match deactivation_result with
69
91
| Ok () ->
···
99
121
Env.host_endpoint )
100
122
() )
101
123
else
102
-
match%lwt
103
-
Remote.request_plc_signature ~pds_endpoint:old_pds ~access_jwt
104
-
with
105
-
| Error e ->
106
-
Dream.warning (fun log ->
107
-
log "migration %s: failed to request PLC signature: %s" did e ) ;
108
-
let%lwt () =
109
-
State.set ctx.req
110
-
{ did
111
-
; handle
112
-
; old_pds
113
-
; access_jwt
114
-
; refresh_jwt
115
-
; email
116
-
; blobs_imported
117
-
; blobs_failed
118
-
; blobs_cursor= ""
119
-
; plc_requested= true }
120
-
in
121
-
Util.render_html ~title:"Migrate Account"
122
-
(module Frontend.MigratePage)
123
-
~props:
124
-
(make_props ~csrf_token ~invite_required ~hostname
125
-
~step:"enter_plc_token" ~did ~handle ~old_pds ~blobs_imported
126
-
~blobs_failed
127
-
~message:
128
-
"Data import complete! Check your email for a PLC \
129
-
confirmation code."
130
-
~error:
131
-
( "Note: Could not automatically request PLC signature: " ^ e
132
-
^ ". You may need to request it manually from your old PDS." )
133
-
() )
134
-
| Ok () ->
135
-
let%lwt () =
136
-
State.set ctx.req
137
-
{ did
138
-
; handle
139
-
; old_pds
140
-
; access_jwt
141
-
; refresh_jwt
142
-
; email
143
-
; blobs_imported
144
-
; blobs_failed
145
-
; blobs_cursor= ""
146
-
; plc_requested= true }
147
-
in
148
-
Util.render_html ~title:"Migrate Account"
124
+
match session with
125
+
| None ->
126
+
Util.render_html ~status:`Internal_Server_Error ~title:"Migrate Account"
149
127
(module Frontend.MigratePage)
150
128
~props:
151
-
(make_props ~csrf_token ~invite_required ~hostname
152
-
~step:"enter_plc_token" ~did ~handle ~old_pds ~blobs_imported
153
-
~blobs_failed
154
-
~message:
155
-
"Data import complete! Check your email for a PLC \
156
-
confirmation code."
157
-
() )
158
-
159
-
(* try to deactivate old account, refreshing token if needed *)
160
-
let deactivate_old_account_with_refresh ~old_pds ~access_jwt ~refresh_jwt =
161
-
match%lwt Remote.deactivate_account ~pds_endpoint:old_pds ~access_jwt with
162
-
| Ok () ->
163
-
Lwt.return_ok ()
164
-
| Error e
165
-
when Util.str_contains ~affix:"401" e
166
-
|| Util.str_contains ~affix:"Unauthorized" e -> (
167
-
match%lwt Remote.refresh_session ~pds_endpoint:old_pds ~refresh_jwt with
168
-
| Ok tokens ->
169
-
Remote.deactivate_account ~pds_endpoint:old_pds
170
-
~access_jwt:tokens.access_jwt
171
-
| Error refresh_err ->
172
-
Lwt.return_error
173
-
(Printf.sprintf "Token expired and refresh failed: %s" refresh_err) )
174
-
| Error e ->
175
-
Lwt.return_error e
129
+
(make_props ~csrf_token ~invite_required ~hostname ~step:"error"
130
+
~did ~handle ~error:"Internal error: session not found" () )
131
+
| Some session -> (
132
+
match%lwt Remote.request_plc_signature old_client with
133
+
| Error e ->
134
+
Dream.warning (fun log ->
135
+
log "migration %s: failed to request PLC signature: %s" did e ) ;
136
+
let%lwt () =
137
+
State.set ctx.req
138
+
{ did
139
+
; handle
140
+
; old_pds
141
+
; session= session_to_yojson_with_pds ~old_pds session
142
+
; email
143
+
; blobs_imported
144
+
; blobs_failed
145
+
; blobs_cursor= ""
146
+
; plc_requested= true }
147
+
in
148
+
Util.render_html ~title:"Migrate Account"
149
+
(module Frontend.MigratePage)
150
+
~props:
151
+
(make_props ~csrf_token ~invite_required ~hostname
152
+
~step:"enter_plc_token" ~did ~handle ~old_pds ~blobs_imported
153
+
~blobs_failed
154
+
~message:
155
+
"Data import complete! Check your email for a PLC \
156
+
confirmation code."
157
+
~error:
158
+
( "Note: Could not automatically request PLC signature: " ^ e
159
+
^ ". You may need to request it manually from your old PDS."
160
+
)
161
+
() )
162
+
| Ok () ->
163
+
let%lwt () =
164
+
State.set ctx.req
165
+
{ did
166
+
; handle
167
+
; old_pds
168
+
; session= session_to_yojson_with_pds ~old_pds session
169
+
; email
170
+
; blobs_imported
171
+
; blobs_failed
172
+
; blobs_cursor= ""
173
+
; plc_requested= true }
174
+
in
175
+
Util.render_html ~title:"Migrate Account"
176
+
(module Frontend.MigratePage)
177
+
~props:
178
+
(make_props ~csrf_token ~invite_required ~hostname
179
+
~step:"enter_plc_token" ~did ~handle ~old_pds ~blobs_imported
180
+
~blobs_failed
181
+
~message:
182
+
"Data import complete! Check your email for a PLC \
183
+
confirmation code."
184
+
() ) )
176
185
177
186
let rec handle_start_migration ctx ~csrf_token ~invite_required ~hostname
178
187
~(render_err : render_err) fields =
···
219
228
220
229
and handle_debug_step (ctx : Xrpc.context) ~csrf_token ~invite_required
221
230
~hostname step =
231
+
let mock_session =
232
+
Hermes.session_to_yojson
233
+
{ access_jwt= "test_access_jwt"
234
+
; refresh_jwt= "test_refresh_jwt"
235
+
; did= "did:plc:a1b2c3"
236
+
; handle= "test.user"
237
+
; pds_uri= None
238
+
; email= None
239
+
; email_confirmed= None
240
+
; email_auth_factor= None
241
+
; active= None
242
+
; status= None }
243
+
in
222
244
match step with
223
245
| "resume_available" ->
224
246
Util.render_html ~title:"Migrate Account"
···
226
248
~props:
227
249
(make_props ~csrf_token ~invite_required ~hostname
228
250
~step:"resume_available" ~did:"did:plc:a1b2c3" ~handle:"test.user"
229
-
~old_pds:"https://bsky.social" () )
251
+
~old_pds:"https://pegasus.dev" () )
230
252
| "importing_data" ->
231
253
let%lwt () =
232
254
State.set ctx.req
233
255
{ did= "did:plc:a1b2c3"
234
256
; handle= "test.user"
235
-
; old_pds= "https://bsky.social"
236
-
; access_jwt= "test_access_jwt"
237
-
; refresh_jwt= "test_refresh_jwt"
257
+
; old_pds= "https://pegasus.dev"
258
+
; session= mock_session
238
259
; email= "test@example.com"
239
260
; blobs_imported= 42
240
261
; blobs_failed= 3
···
246
267
~props:
247
268
(make_props ~csrf_token ~invite_required ~hostname
248
269
~step:"importing_data" ~did:"did:plc:a1b2c3" ~handle:"test.user"
249
-
~old_pds:"https://bsky.social" ~blobs_imported:42 ~blobs_failed:3
270
+
~old_pds:"https://pegasus.dev" ~blobs_imported:42 ~blobs_failed:3
250
271
() )
251
272
| "enter_plc_token" ->
252
273
let%lwt () =
253
274
State.set ctx.req
254
275
{ did= "did:plc:a1b2c3"
255
276
; handle= "test.user"
256
-
; old_pds= "https://bsky.social"
257
-
; access_jwt= "test_access_jwt"
258
-
; refresh_jwt= "test_refresh_jwt"
277
+
; old_pds= "https://pegasus.dev"
278
+
; session= mock_session
259
279
; email= "test@example.com"
260
280
; blobs_imported= 100
261
281
; blobs_failed= 0
···
267
287
~props:
268
288
(make_props ~csrf_token ~invite_required ~hostname
269
289
~step:"enter_plc_token" ~did:"did:plc:testuser123"
270
-
~handle:"test.user" ~old_pds:"https://bsky.social"
290
+
~handle:"test.user" ~old_pds:"https://pegasus.dev"
271
291
~blobs_imported:100 ~blobs_failed:0
272
292
~message:
273
293
"Data import complete! Check your email for a PLC confirmation \
···
304
324
render_err e
305
325
| Ok (did, handle, old_pds) -> (
306
326
match%lwt
307
-
Remote.create_session ~pds_endpoint:old_pds ~identifier ~password ()
327
+
Remote.create_session ~service:old_pds ~identifier ~password ()
308
328
with
309
329
| Remote.AuthError e ->
310
330
render_err e
···
314
334
~props:
315
335
(make_props ~csrf_token ~invite_required ~hostname ~step:"enter_2fa"
316
336
~identifier ~old_pds ?invite_code () )
317
-
| Remote.AuthSuccess session -> (
318
-
match%lwt
319
-
Remote.get_session ~pds_endpoint:old_pds ~access_jwt:session.access_jwt
320
-
with
321
-
| Error e ->
322
-
render_err ("Failed to get account info: " ^ e)
323
-
| Ok session_info -> (
337
+
| Remote.AuthSuccess old_client -> (
338
+
match Hermes.get_session old_client with
339
+
| None ->
340
+
render_err "Internal error: session not found after login"
341
+
| Some session -> (
324
342
let is_active =
325
-
match session_info.active with Some false -> false | _ -> true
343
+
match session.active with Some false -> false | _ -> true
326
344
in
327
345
if not is_active then
328
346
render_err
329
347
"This account is already deactivated. Cannot migrate a \
330
348
deactivated account."
331
349
else
332
-
match%lwt
333
-
Remote.get_service_auth ~pds_endpoint:old_pds
334
-
~access_jwt:session.access_jwt
335
-
with
350
+
match%lwt Remote.get_service_auth old_client with
336
351
| Error e ->
337
352
render_err ("Failed to get service authorization: " ^ e)
338
353
| Ok service_auth_token -> (
339
354
let email =
340
-
match session_info.email with
355
+
match session.email with
341
356
| Some e when String.length e > 0 ->
342
357
e
343
358
| _ ->
···
348
363
~service_auth_token ?invite_code ctx.db
349
364
with
350
365
| Error e when String.starts_with ~prefix:"RESUMABLE:" e ->
351
-
handle_resumable_migration ctx ~csrf_token ~invite_required
352
-
~hostname ~render_err ~did ~handle ~old_pds ~session
353
-
~email
366
+
handle_resumable_migration ctx ~old_client ~csrf_token
367
+
~invite_required ~hostname ~render_err ~did ~handle
368
+
~old_pds ~email
354
369
| Error e ->
355
370
render_err e
356
371
| Ok _signing_key_did ->
357
-
perform_data_import ctx ~csrf_token ~invite_required
358
-
~hostname ~render_err ~did ~handle ~old_pds ~session
359
-
~email ) ) ) )
372
+
perform_data_import ctx ~old_client ~csrf_token
373
+
~invite_required ~hostname ~render_err ~did ~handle
374
+
~old_pds ~email ) ) ) )
360
375
361
-
and handle_resumable_migration ctx ~csrf_token ~invite_required ~hostname
362
-
~(render_err : render_err) ~did ~handle ~old_pds ~session ~email =
376
+
and handle_resumable_migration ctx ~old_client ~csrf_token ~invite_required
377
+
~hostname ~(render_err : render_err) ~did ~handle ~old_pds ~email =
363
378
match%lwt State.check_resume_state ~did ctx.db with
364
379
| Error e ->
365
380
render_err ~did ~handle ~old_pds e
···
375
390
| Ok State.NeedsActivation ->
376
391
let%lwt () = Ops.activate_account did ctx.db in
377
392
let%lwt () = Session.log_in_did ctx.req did in
378
-
let%lwt deactivation_result =
379
-
deactivate_old_account_with_refresh ~old_pds
380
-
~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt
381
-
in
393
+
let%lwt deactivation_result = Remote.deactivate_account old_client in
382
394
let old_account_deactivated, old_account_deactivation_error =
383
395
match deactivation_result with
384
396
| Ok () ->
···
399
411
this PDS."
400
412
() )
401
413
| Ok State.NeedsPlcUpdate ->
402
-
transition_to_plc_token_step ctx ~did ~handle ~old_pds
403
-
~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt ~email
414
+
transition_to_plc_token_step ctx ~old_client ~old_pds ~did ~handle ~email
404
415
~blobs_imported:0 ~blobs_failed:0
405
416
| Ok State.NeedsRepoImport | Ok State.NeedsBlobImport -> (
406
-
match%lwt
407
-
Remote.fetch_repo ~pds_endpoint:old_pds ~access_jwt:session.access_jwt
408
-
~did
409
-
with
417
+
match%lwt Remote.fetch_repo old_client ~did with
410
418
| Error err ->
411
419
render_err ~did ~handle ~old_pds ("Failed to fetch repository: " ^ err)
412
420
| Ok car_data -> (
413
-
match%lwt Ops.import_repo ~did ~car_data with
421
+
match%lwt
422
+
Ops.import_repo ~did ~car_data:(Bytes.of_string (fst car_data))
423
+
with
414
424
| Error err ->
415
425
render_err ~did ~handle ~old_pds err
416
426
| Ok () ->
417
-
transition_to_plc_token_step ctx ~did ~handle ~old_pds
418
-
~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt
427
+
transition_to_plc_token_step ctx ~old_client ~old_pds ~did ~handle
419
428
~email ~blobs_imported:0 ~blobs_failed:0 ) )
420
429
421
-
and perform_data_import ctx ~csrf_token ~invite_required ~hostname ~render_err
422
-
~did ~handle ~old_pds ~session ~email =
423
-
match%lwt
424
-
Remote.fetch_repo ~pds_endpoint:old_pds ~access_jwt:session.access_jwt ~did
425
-
with
430
+
and perform_data_import ctx ~old_client ~csrf_token ~invite_required ~hostname
431
+
~render_err ~did ~handle ~old_pds ~email =
432
+
match%lwt Remote.fetch_repo old_client ~did with
426
433
| Error e ->
427
434
render_err ("Failed to fetch repository: " ^ e)
428
435
| Ok car_data -> (
429
-
match%lwt Ops.import_repo ~did ~car_data with
436
+
match%lwt
437
+
Ops.import_repo ~did ~car_data:(Bytes.of_string (fst car_data))
438
+
with
430
439
| Error e ->
431
440
render_err e
432
441
| Ok () -> (
···
448
457
| Error e ->
449
458
Dream.warning (fun log ->
450
459
log "migration %s: failed to list missing blobs: %s" did e ) ;
451
-
transition_to_plc_token_step ctx ~did ~handle ~old_pds
452
-
~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt
460
+
transition_to_plc_token_step ctx ~old_client ~old_pds ~did ~handle
453
461
~email ~blobs_imported:0 ~blobs_failed:0
454
-
| Ok (missing_cids, next_cursor) ->
462
+
| Ok (missing_cids, next_cursor) -> (
455
463
if List.length missing_cids = 0 then
456
-
transition_to_plc_token_step ctx ~did ~handle ~old_pds
457
-
~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt
464
+
transition_to_plc_token_step ctx ~old_client ~old_pds ~did ~handle
458
465
~email ~blobs_imported:0 ~blobs_failed:0
459
466
else
460
467
let%lwt imported, failed =
461
-
Ops.import_blobs_batch ~pds_endpoint:old_pds
462
-
~access_jwt:session.access_jwt ~did ~cids:missing_cids
468
+
Ops.import_blobs_batch old_client ~did ~cids:missing_cids
463
469
in
464
470
let cursor = Option.value ~default:"" next_cursor in
465
471
if String.length cursor = 0 then
466
-
transition_to_plc_token_step ctx ~did ~handle ~old_pds
467
-
~access_jwt:session.access_jwt
468
-
~refresh_jwt:session.refresh_jwt ~email
469
-
~blobs_imported:imported ~blobs_failed:failed
472
+
transition_to_plc_token_step ctx ~old_client ~old_pds ~did
473
+
~handle ~email ~blobs_imported:imported ~blobs_failed:failed
470
474
else
471
-
let%lwt () =
472
-
State.set ctx.req
473
-
{ did
474
-
; handle
475
-
; old_pds
476
-
; access_jwt= session.access_jwt
477
-
; refresh_jwt= session.refresh_jwt
478
-
; email
479
-
; blobs_imported= imported
480
-
; blobs_failed= failed
481
-
; blobs_cursor= cursor
482
-
; plc_requested= false }
483
-
in
484
-
Util.render_html ~title:"Migrate Account"
485
-
(module Frontend.MigratePage)
486
-
~props:
487
-
(make_props ~csrf_token ~invite_required ~hostname
488
-
~step:"importing_data" ~did ~handle ~old_pds
489
-
~blobs_imported:imported ~blobs_failed:failed () ) ) )
475
+
match Hermes.get_session old_client with
476
+
| None ->
477
+
render_err "Internal error: session not found"
478
+
| Some session ->
479
+
let%lwt () =
480
+
State.set ctx.req
481
+
{ did
482
+
; handle
483
+
; old_pds
484
+
; session= session_to_yojson_with_pds ~old_pds session
485
+
; email
486
+
; blobs_imported= imported
487
+
; blobs_failed= failed
488
+
; blobs_cursor= cursor
489
+
; plc_requested= false }
490
+
in
491
+
Util.render_html ~title:"Migrate Account"
492
+
(module Frontend.MigratePage)
493
+
~props:
494
+
(make_props ~csrf_token ~invite_required ~hostname
495
+
~step:"importing_data" ~did ~handle ~old_pds
496
+
~blobs_imported:imported ~blobs_failed:failed () ) )
497
+
) )
490
498
491
499
and handle_continue_blobs (ctx : Xrpc.context) ~csrf_token ~invite_required
492
500
~hostname ~render_err =
···
494
502
| None ->
495
503
render_err "Migration state not found. Please start over."
496
504
| Some state -> (
497
-
let%lwt state =
498
-
if Remote.jwt_needs_refresh state.access_jwt then (
499
-
match%lwt
500
-
Remote.refresh_session ~pds_endpoint:state.old_pds
501
-
~refresh_jwt:state.refresh_jwt
502
-
with
503
-
| Ok tokens ->
504
-
let new_state =
505
-
{ state with
506
-
access_jwt= tokens.access_jwt
507
-
; refresh_jwt= tokens.refresh_jwt }
508
-
in
509
-
let%lwt () = State.set ctx.req new_state in
510
-
Lwt.return new_state
511
-
| Error e ->
512
-
Dream.warning (fun log ->
513
-
log
514
-
"migration %s: token refresh failed, continuing with old \
515
-
token: %s"
516
-
state.did e ) ;
517
-
Lwt.return state )
518
-
else Lwt.return state
519
-
in
520
505
let cursor =
521
506
if String.length state.blobs_cursor > 0 then Some state.blobs_cursor
522
507
else None
523
508
in
524
-
match%lwt Ops.list_missing_blobs ~did:state.did ~limit:50 ?cursor () with
509
+
match%lwt resume_from_state ~old_pds:state.old_pds state.session with
525
510
| Error e ->
526
-
Dream.warning (fun log ->
527
-
log "migration %s: failed to list missing blobs: %s" state.did e ) ;
528
-
transition_to_plc_token_step ctx ~did:state.did ~handle:state.handle
529
-
~old_pds:state.old_pds ~access_jwt:state.access_jwt
530
-
~refresh_jwt:state.refresh_jwt ~email:state.email
531
-
~blobs_imported:state.blobs_imported
532
-
~blobs_failed:state.blobs_failed
533
-
| Ok (missing_cids, next_cursor) ->
534
-
if List.length missing_cids = 0 then
535
-
transition_to_plc_token_step ctx ~did:state.did ~handle:state.handle
536
-
~old_pds:state.old_pds ~access_jwt:state.access_jwt
537
-
~refresh_jwt:state.refresh_jwt ~email:state.email
511
+
render_err e
512
+
| Ok old_client -> (
513
+
match%lwt
514
+
Ops.list_missing_blobs ~did:state.did ~limit:50 ?cursor ()
515
+
with
516
+
| Error e ->
517
+
Dream.warning (fun log ->
518
+
log "migration %s: failed to list missing blobs: %s" state.did e ) ;
519
+
transition_to_plc_token_step ctx ~old_client ~old_pds:state.old_pds
520
+
~did:state.did ~handle:state.handle ~email:state.email
538
521
~blobs_imported:state.blobs_imported
539
522
~blobs_failed:state.blobs_failed
540
-
else
541
-
let%lwt imported, failed =
542
-
Ops.import_blobs_batch ~pds_endpoint:state.old_pds
543
-
~access_jwt:state.access_jwt ~did:state.did ~cids:missing_cids
544
-
in
545
-
let new_imported = state.blobs_imported + imported in
546
-
let new_failed = state.blobs_failed + failed in
547
-
let new_cursor = Option.value ~default:"" next_cursor in
548
-
if String.length new_cursor = 0 then
549
-
transition_to_plc_token_step ctx ~did:state.did
550
-
~handle:state.handle ~old_pds:state.old_pds
551
-
~access_jwt:state.access_jwt ~refresh_jwt:state.refresh_jwt
552
-
~email:state.email ~blobs_imported:new_imported
553
-
~blobs_failed:new_failed
523
+
| Ok (missing_cids, next_cursor) ->
524
+
if List.length missing_cids = 0 then
525
+
transition_to_plc_token_step ctx ~old_client
526
+
~old_pds:state.old_pds ~did:state.did ~handle:state.handle
527
+
~email:state.email ~blobs_imported:state.blobs_imported
528
+
~blobs_failed:state.blobs_failed
554
529
else
555
-
let%lwt () =
556
-
State.set ctx.req
557
-
{ state with
558
-
blobs_imported= new_imported
559
-
; blobs_failed= new_failed
560
-
; blobs_cursor= new_cursor }
530
+
let%lwt imported, failed =
531
+
Ops.import_blobs_batch old_client ~did:state.did
532
+
~cids:missing_cids
561
533
in
562
-
Util.render_html ~title:"Migrate Account"
563
-
(module Frontend.MigratePage)
564
-
~props:
565
-
(make_props ~csrf_token ~invite_required ~hostname
566
-
~step:"importing_data" ~did:state.did ~handle:state.handle
567
-
~old_pds:state.old_pds ~blobs_imported:new_imported
568
-
~blobs_failed:new_failed () ) )
534
+
let new_imported = state.blobs_imported + imported in
535
+
let new_failed = state.blobs_failed + failed in
536
+
let new_cursor = Option.value ~default:"" next_cursor in
537
+
if String.length new_cursor = 0 then
538
+
transition_to_plc_token_step ctx ~old_client
539
+
~old_pds:state.old_pds ~did:state.did ~handle:state.handle
540
+
~email:state.email ~blobs_imported:new_imported
541
+
~blobs_failed:new_failed
542
+
else
543
+
let%lwt () =
544
+
State.set ctx.req
545
+
{ state with
546
+
blobs_imported= new_imported
547
+
; blobs_failed= new_failed
548
+
; blobs_cursor= new_cursor }
549
+
in
550
+
Util.render_html ~title:"Migrate Account"
551
+
(module Frontend.MigratePage)
552
+
~props:
553
+
(make_props ~csrf_token ~invite_required ~hostname
554
+
~step:"importing_data" ~did:state.did
555
+
~handle:state.handle ~old_pds:state.old_pds
556
+
~blobs_imported:new_imported ~blobs_failed:new_failed () )
557
+
) )
569
558
570
559
and handle_submit_plc_token (ctx : Xrpc.context) ~csrf_token ~invite_required
571
560
~hostname ~(render_err : render_err) fields =
···
581
570
render_err ~step:"enter_plc_token" ~did:state.did ~handle:state.handle
582
571
~old_pds:state.old_pds "Please enter the PLC token from your email"
583
572
else
584
-
let%lwt old_pds_keys =
585
-
match%lwt
586
-
Remote.get_recommended_credentials ~pds_endpoint:state.old_pds
587
-
~access_jwt:state.access_jwt
588
-
with
589
-
| Ok creds ->
590
-
Lwt.return creds.rotation_keys
591
-
| Error e ->
592
-
Dream.warning (fun log ->
593
-
log "migration %s: failed to get old PDS credentials: %s"
594
-
state.did e ) ;
595
-
Lwt.return []
596
-
in
597
-
let%lwt current_keys =
598
-
match%lwt Remote.get_plc_rotation_keys ~did:state.did with
599
-
| Ok keys ->
600
-
Lwt.return keys
601
-
| Error _ ->
602
-
Lwt.return []
603
-
in
604
-
let keys_to_preserve =
605
-
List.filter (fun k -> not (List.mem k old_pds_keys)) current_keys
606
-
in
607
-
match%lwt
608
-
Ops.get_recommended_did_credentials state.did ctx.db
609
-
~extra_rotation_keys:keys_to_preserve
610
-
with
573
+
match%lwt resume_from_state ~old_pds:state.old_pds state.session with
611
574
| Error e ->
612
-
render_err ~step:"enter_plc_token" ~did:state.did
613
-
~handle:state.handle ~old_pds:state.old_pds
614
-
("Failed to get credentials: " ^ e)
615
-
| Ok credentials -> (
616
-
match%lwt
617
-
Remote.sign_plc_operation ~pds_endpoint:state.old_pds
618
-
~access_jwt:state.access_jwt ~token:plc_token ~credentials
619
-
with
620
-
| Error e ->
621
-
render_err ~step:"enter_plc_token" ~did:state.did
622
-
~handle:state.handle ~old_pds:state.old_pds
623
-
("Failed to sign PLC operation: " ^ e)
624
-
| Ok signed_operation -> (
625
-
match%lwt
626
-
Ops.submit_plc_operation ~did:state.did ~handle:state.handle
627
-
~operation:signed_operation ctx.db
628
-
with
629
-
| Error e ->
575
+
render_err e
576
+
| Ok old_client -> (
577
+
let%lwt old_pds_keys =
578
+
match%lwt Remote.get_recommended_credentials old_client with
579
+
| Ok {rotation_keys= Some keys; _} ->
580
+
Lwt.return keys
581
+
| Ok _ ->
582
+
Lwt.return []
583
+
| Error e ->
584
+
Dream.warning (fun log ->
585
+
log "migration %s: failed to get old PDS credentials: %s"
586
+
state.did e ) ;
587
+
Lwt.return []
588
+
in
589
+
let%lwt current_keys =
590
+
match%lwt Remote.get_plc_rotation_keys ~did:state.did with
591
+
| Ok keys ->
592
+
Lwt.return keys
593
+
| Error _ ->
594
+
Lwt.return []
595
+
in
596
+
let keys_to_preserve =
597
+
List.filter (fun k -> not (List.mem k old_pds_keys)) current_keys
598
+
in
599
+
match%lwt Data_store.get_actor_by_identifier state.did ctx.db with
600
+
| None ->
630
601
render_err ~step:"enter_plc_token" ~did:state.did
631
602
~handle:state.handle ~old_pds:state.old_pds
632
-
("Failed to submit PLC operation: " ^ e)
633
-
| Ok () ->
634
-
let%lwt () =
635
-
match%lwt Ops.check_account_status ~did:state.did with
636
-
| Ok status ->
637
-
Dream.info (fun log ->
638
-
log
639
-
"migration %s: activating account, \
640
-
imported_blobs=%d/%d"
641
-
state.did status.imported_blobs
642
-
status.expected_blobs ) ;
643
-
Lwt.return_unit
644
-
| Error e ->
645
-
Dream.warning (fun log ->
646
-
log
647
-
"migration %s: failed to check status before \
648
-
activation: %s"
649
-
state.did e ) ;
650
-
Lwt.return_unit
651
-
in
652
-
let%lwt () = Ops.activate_account state.did ctx.db in
653
-
let%lwt () = Session.log_in_did ctx.req state.did in
654
-
let%lwt () = State.clear ctx.req in
655
-
let%lwt deactivation_result =
656
-
deactivate_old_account_with_refresh ~old_pds:state.old_pds
657
-
~access_jwt:state.access_jwt ~refresh_jwt:state.refresh_jwt
603
+
"Failed to get credentials: account not found"
604
+
| Some actor -> (
605
+
let credentials =
606
+
Plc.get_recommended_credentials ~handle:actor.handle
607
+
~signing_key:actor.signing_key
608
+
~extra_rotation_keys:keys_to_preserve ()
658
609
in
659
-
let old_account_deactivated, old_account_deactivation_error =
660
-
match deactivation_result with
610
+
match%lwt
611
+
Remote.sign_plc_operation old_client ~token:plc_token
612
+
~credentials
613
+
with
614
+
| Error e ->
615
+
render_err ~step:"enter_plc_token" ~did:state.did
616
+
~handle:state.handle ~old_pds:state.old_pds
617
+
("Failed to sign PLC operation: " ^ e)
618
+
| Ok signed_operation -> (
619
+
match%lwt
620
+
Plc.signed_operation_of_yojson signed_operation
621
+
|> Lwt_result.lift
622
+
|> fun r ->
623
+
Lwt_result.bind r (fun op ->
624
+
Ops.submit_plc_operation ~did:state.did
625
+
~handle:state.handle ~operation:op ctx.db )
626
+
with
627
+
| Error e ->
628
+
render_err ~step:"enter_plc_token" ~did:state.did
629
+
~handle:state.handle ~old_pds:state.old_pds
630
+
("Failed to submit PLC operation: " ^ e)
661
631
| Ok () ->
662
-
(true, None)
663
-
| Error e ->
664
-
Dream.warning (fun log ->
665
-
log
666
-
"migration %s: failed to deactivate old account: %s"
667
-
state.did e ) ;
668
-
(false, Some e)
669
-
in
670
-
Util.render_html ~title:"Migrate Account"
671
-
(module Frontend.MigratePage)
672
-
~props:
673
-
(make_props ~csrf_token ~invite_required ~hostname
674
-
~step:"complete" ~did:state.did ~handle:state.handle
675
-
~blobs_imported:state.blobs_imported
676
-
~blobs_failed:state.blobs_failed ~old_account_deactivated
677
-
?old_account_deactivation_error
678
-
~message:"Your account has been successfully migrated!"
679
-
() ) ) ) )
632
+
let%lwt () =
633
+
match%lwt Ops.check_account_status ~did:state.did with
634
+
| Ok status ->
635
+
Dream.info (fun log ->
636
+
log
637
+
"migration %s: activating account, \
638
+
imported_blobs=%d/%d"
639
+
state.did status.imported_blobs
640
+
status.expected_blobs ) ;
641
+
Lwt.return_unit
642
+
| Error e ->
643
+
Dream.warning (fun log ->
644
+
log
645
+
"migration %s: failed to check status before \
646
+
activation: %s"
647
+
state.did e ) ;
648
+
Lwt.return_unit
649
+
in
650
+
let%lwt () = Ops.activate_account state.did ctx.db in
651
+
let%lwt () = Session.log_in_did ctx.req state.did in
652
+
let%lwt () = State.clear ctx.req in
653
+
let%lwt deactivation_result =
654
+
Remote.deactivate_account old_client
655
+
in
656
+
let ( old_account_deactivated
657
+
, old_account_deactivation_error ) =
658
+
match deactivation_result with
659
+
| Ok () ->
660
+
(true, None)
661
+
| Error e ->
662
+
Dream.warning (fun log ->
663
+
log
664
+
"migration %s: failed to deactivate old \
665
+
account: %s"
666
+
state.did e ) ;
667
+
(false, Some e)
668
+
in
669
+
Util.render_html ~title:"Migrate Account"
670
+
(module Frontend.MigratePage)
671
+
~props:
672
+
(make_props ~csrf_token ~invite_required ~hostname
673
+
~step:"complete" ~did:state.did
674
+
~handle:state.handle
675
+
~blobs_imported:state.blobs_imported
676
+
~blobs_failed:state.blobs_failed
677
+
~old_account_deactivated
678
+
?old_account_deactivation_error
679
+
~message:
680
+
"Your account has been successfully migrated!"
681
+
() ) ) ) ) )
680
682
681
683
and handle_resend_plc_token (ctx : Xrpc.context) ~csrf_token ~invite_required
682
684
~hostname =
···
685
687
render_error ~csrf_token ~invite_required ~hostname
686
688
"Migration state not found. Please start over."
687
689
| Some state -> (
688
-
match%lwt
689
-
Remote.request_plc_signature ~pds_endpoint:state.old_pds
690
-
~access_jwt:state.access_jwt
691
-
with
690
+
match%lwt resume_from_state ~old_pds:state.old_pds state.session with
692
691
| Error e ->
693
-
Util.render_html ~title:"Migrate Account"
694
-
(module Frontend.MigratePage)
695
-
~props:
696
-
(make_props ~csrf_token ~invite_required ~hostname
697
-
~step:"enter_plc_token" ~did:state.did ~handle:state.handle
698
-
~old_pds:state.old_pds ~error:("Failed to resend: " ^ e) () )
699
-
| Ok () ->
700
-
Util.render_html ~title:"Migrate Account"
701
-
(module Frontend.MigratePage)
702
-
~props:
703
-
(make_props ~csrf_token ~invite_required ~hostname
704
-
~step:"enter_plc_token" ~did:state.did ~handle:state.handle
705
-
~old_pds:state.old_pds
706
-
~message:"Confirmation code resent! Check your email." () ) )
692
+
render_error ~csrf_token ~invite_required ~hostname e
693
+
| Ok old_client -> (
694
+
match%lwt Remote.request_plc_signature old_client with
695
+
| Error e ->
696
+
Util.render_html ~title:"Migrate Account"
697
+
(module Frontend.MigratePage)
698
+
~props:
699
+
(make_props ~csrf_token ~invite_required ~hostname
700
+
~step:"enter_plc_token" ~did:state.did ~handle:state.handle
701
+
~old_pds:state.old_pds ~error:("Failed to resend: " ^ e) () )
702
+
| Ok () ->
703
+
Util.render_html ~title:"Migrate Account"
704
+
(module Frontend.MigratePage)
705
+
~props:
706
+
(make_props ~csrf_token ~invite_required ~hostname
707
+
~step:"enter_plc_token" ~did:state.did ~handle:state.handle
708
+
~old_pds:state.old_pds
709
+
~message:"Confirmation code resent! Check your email." () ) ) )
707
710
708
-
and handle_submit_2fa (ctx : Xrpc.context) ~(render_err : render_err) fields =
711
+
and handle_submit_2fa (ctx : Xrpc.context) ~(render_err : render_err)
712
+
~csrf_token ~invite_required ~hostname fields =
709
713
let identifier =
710
714
List.assoc_opt "identifier" fields
711
715
|> Option.value ~default:"" |> String.trim
···
733
737
if String.length old_pds > 0 then old_pds else resolved_pds
734
738
in
735
739
match%lwt
736
-
Remote.create_session ~pds_endpoint ~identifier ~password
740
+
Remote.create_session ~service:pds_endpoint ~identifier ~password
737
741
~auth_factor_token ()
738
742
with
739
743
| Remote.AuthError e ->
···
742
746
| Remote.AuthNeeds2FA ->
743
747
render_err ~step:"enter_2fa" ~identifier ~old_pds:pds_endpoint
744
748
?invite_code "Invalid authentication code. Please try again."
745
-
| Remote.AuthSuccess session -> (
746
-
match%lwt
747
-
Remote.get_session ~pds_endpoint ~access_jwt:session.access_jwt
748
-
with
749
-
| Error e ->
750
-
render_err ("Failed to get account info: " ^ e)
751
-
| Ok session_info -> (
749
+
| Remote.AuthSuccess client -> (
750
+
match Hermes.get_session client with
751
+
| None ->
752
+
render_err "Internal error: session not found after login"
753
+
| Some session -> (
752
754
let is_active =
753
-
match session_info.active with Some false -> false | _ -> true
755
+
match session.active with Some false -> false | _ -> true
754
756
in
755
757
if not is_active then
756
758
render_err
757
759
"This account is already deactivated. Cannot migrate a \
758
760
deactivated account."
759
761
else
760
-
match%lwt
761
-
Remote.get_service_auth ~pds_endpoint
762
-
~access_jwt:session.access_jwt
763
-
with
762
+
match%lwt Remote.get_service_auth client with
764
763
| Error e ->
765
764
render_err ("Failed to get service authorization: " ^ e)
766
765
| Ok service_auth_token -> (
767
766
let email =
768
-
match session_info.email with
767
+
match session.email with
769
768
| Some e when String.length e > 0 ->
770
769
e
771
770
| _ ->
···
775
774
Ops.create_account ~email ~handle ~password ~did
776
775
~service_auth_token ?invite_code ctx.db
777
776
with
777
+
| Error e when String.starts_with ~prefix:"RESUMABLE:" e ->
778
+
handle_resumable_migration ctx ~old_client:client
779
+
~csrf_token ~invite_required ~hostname ~render_err
780
+
~did ~handle ~old_pds ~email
778
781
| Error e ->
779
782
render_err e
780
783
| Ok _signing_key_did -> (
781
-
match%lwt
782
-
Remote.fetch_repo ~pds_endpoint
783
-
~access_jwt:session.access_jwt ~did
784
-
with
784
+
match%lwt Remote.fetch_repo client ~did with
785
785
| Error e ->
786
786
render_err ("Failed to fetch repository: " ^ e)
787
787
| Ok car_data -> (
788
-
match%lwt Ops.import_repo ~did ~car_data with
788
+
match%lwt
789
+
Ops.import_repo ~did
790
+
~car_data:(Bytes.of_string @@ fst car_data)
791
+
with
789
792
| Error e ->
790
793
render_err e
791
794
| Ok () ->
792
-
transition_to_plc_token_step ctx ~did ~handle
793
-
~old_pds:pds_endpoint
794
-
~access_jwt:session.access_jwt
795
-
~refresh_jwt:session.refresh_jwt ~email
795
+
transition_to_plc_token_step ctx ~old_client:client
796
+
~old_pds:pds_endpoint ~did ~handle ~email
796
797
~blobs_imported:0 ~blobs_failed:0 ) ) ) ) ) )
797
798
798
799
and handle_resume_migration (ctx : Xrpc.context) ~csrf_token ~invite_required
···
812
813
render_err ~step:"resume_available" e
813
814
| Ok (did, handle, old_pds) -> (
814
815
match%lwt
815
-
Remote.create_session ~pds_endpoint:old_pds ~identifier ~password ()
816
+
Remote.create_session ~service:old_pds ~identifier ~password ()
816
817
with
817
818
| Remote.AuthError e ->
818
819
render_err ~step:"resume_available" e
···
822
823
~props:
823
824
(make_props ~csrf_token ~invite_required ~hostname
824
825
~step:"enter_2fa" ~identifier ~old_pds () )
825
-
| Remote.AuthSuccess session -> (
826
-
let%lwt email =
827
-
match%lwt
828
-
Remote.get_session ~pds_endpoint:old_pds
829
-
~access_jwt:session.access_jwt
830
-
with
831
-
| Ok info ->
832
-
Lwt.return
833
-
( match info.email with
834
-
| Some e when String.length e > 0 ->
835
-
e
836
-
| _ ->
837
-
Printf.sprintf "%s@%s" did Env.hostname )
838
-
| Error _ ->
839
-
Lwt.return (Printf.sprintf "%s@%s" did Env.hostname)
840
-
in
841
-
match%lwt State.check_resume_state ~did ctx.db with
842
-
| Error e ->
843
-
render_err ~step:"resume_available" ~did ~handle ~old_pds e
844
-
| Ok State.AlreadyActive ->
845
-
let%lwt () = Session.log_in_did ctx.req did in
846
-
Util.render_html ~title:"Migrate Account"
847
-
(module Frontend.MigratePage)
848
-
~props:
849
-
(make_props ~csrf_token ~invite_required ~hostname
850
-
~step:"complete" ~did ~handle
851
-
~message:
852
-
"Your account is already active! You have been logged \
853
-
in."
854
-
() )
855
-
| Ok State.NeedsActivation ->
856
-
let%lwt () = Ops.activate_account did ctx.db in
857
-
let%lwt () = Session.log_in_did ctx.req did in
858
-
let%lwt deactivation_result =
859
-
deactivate_old_account_with_refresh ~old_pds
860
-
~access_jwt:session.access_jwt
861
-
~refresh_jwt:session.refresh_jwt
862
-
in
863
-
let old_account_deactivated, old_account_deactivation_error =
864
-
match deactivation_result with
865
-
| Ok () ->
866
-
(true, None)
867
-
| Error e ->
868
-
Dream.warning (fun log ->
869
-
log "migration %s: failed to deactivate old account: %s"
870
-
did e ) ;
871
-
(false, Some e)
872
-
in
873
-
Util.render_html ~title:"Migrate Account"
874
-
(module Frontend.MigratePage)
875
-
~props:
876
-
(make_props ~csrf_token ~invite_required ~hostname
877
-
~step:"complete" ~did ~handle ~old_account_deactivated
878
-
?old_account_deactivation_error
879
-
~message:
880
-
"Your account has been activated! Your identity is \
881
-
pointing to this PDS."
882
-
() )
883
-
| Ok State.NeedsPlcUpdate ->
884
-
transition_to_plc_token_step ctx ~did ~handle ~old_pds
885
-
~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt
886
-
~email ~blobs_imported:0 ~blobs_failed:0
887
-
| Ok State.NeedsRepoImport | Ok State.NeedsBlobImport -> (
888
-
match%lwt
889
-
Remote.fetch_repo ~pds_endpoint:old_pds
890
-
~access_jwt:session.access_jwt ~did
891
-
with
826
+
| Remote.AuthSuccess client -> (
827
+
match Hermes.get_session client with
828
+
| None ->
829
+
render_err ~step:"resume_available"
830
+
"Internal error: session not found after login"
831
+
| Some session -> (
832
+
let email =
833
+
match session.email with
834
+
| Some e when String.length e > 0 ->
835
+
e
836
+
| _ ->
837
+
Printf.sprintf "%s@%s" did Env.hostname
838
+
in
839
+
match%lwt State.check_resume_state ~did ctx.db with
892
840
| Error e ->
893
-
render_err ~did ~handle ~old_pds
894
-
("Failed to fetch repository: " ^ e)
895
-
| Ok car_data -> (
896
-
match%lwt Ops.import_repo ~did ~car_data with
841
+
render_err ~step:"resume_available" ~did ~handle ~old_pds e
842
+
| Ok State.AlreadyActive ->
843
+
let%lwt () = Session.log_in_did ctx.req did in
844
+
Util.render_html ~title:"Migrate Account"
845
+
(module Frontend.MigratePage)
846
+
~props:
847
+
(make_props ~csrf_token ~invite_required ~hostname
848
+
~step:"complete" ~did ~handle
849
+
~message:
850
+
"Your account is already active! You have been logged \
851
+
in."
852
+
() )
853
+
| Ok State.NeedsActivation ->
854
+
let%lwt () = Ops.activate_account did ctx.db in
855
+
let%lwt () = Session.log_in_did ctx.req did in
856
+
let%lwt deactivation_result =
857
+
Remote.deactivate_account client
858
+
in
859
+
let old_account_deactivated, old_account_deactivation_error =
860
+
match deactivation_result with
861
+
| Ok () ->
862
+
(true, None)
863
+
| Error e ->
864
+
Dream.warning (fun log ->
865
+
log
866
+
"migration %s: failed to deactivate old account: %s"
867
+
did e ) ;
868
+
(false, Some e)
869
+
in
870
+
Util.render_html ~title:"Migrate Account"
871
+
(module Frontend.MigratePage)
872
+
~props:
873
+
(make_props ~csrf_token ~invite_required ~hostname
874
+
~step:"complete" ~did ~handle ~old_account_deactivated
875
+
?old_account_deactivation_error
876
+
~message:
877
+
"Your account has been activated! Your identity is \
878
+
pointing to this PDS."
879
+
() )
880
+
| Ok State.NeedsPlcUpdate ->
881
+
transition_to_plc_token_step ctx ~old_client:client ~old_pds
882
+
~did ~handle ~email ~blobs_imported:0 ~blobs_failed:0
883
+
| Ok State.NeedsRepoImport | Ok State.NeedsBlobImport -> (
884
+
match%lwt Remote.fetch_repo client ~did with
897
885
| Error e ->
898
-
render_err ~did ~handle ~old_pds e
899
-
| Ok () -> (
900
-
match%lwt Ops.list_missing_blobs ~did ~limit:50 () with
886
+
render_err ~did ~handle ~old_pds
887
+
("Failed to fetch repository: " ^ e)
888
+
| Ok car_data -> (
889
+
match%lwt
890
+
Ops.import_repo ~did
891
+
~car_data:(Bytes.of_string @@ fst car_data)
892
+
with
901
893
| Error e ->
902
-
Dream.warning (fun log ->
903
-
log "migration %s: failed to list missing blobs: %s" did
904
-
e ) ;
905
-
transition_to_plc_token_step ctx ~did ~handle ~old_pds
906
-
~access_jwt:session.access_jwt
907
-
~refresh_jwt:session.refresh_jwt ~email ~blobs_imported:0
908
-
~blobs_failed:0
909
-
| Ok (missing_cids, next_cursor) ->
910
-
if List.length missing_cids = 0 then
911
-
transition_to_plc_token_step ctx ~did ~handle ~old_pds
912
-
~access_jwt:session.access_jwt
913
-
~refresh_jwt:session.refresh_jwt ~email
914
-
~blobs_imported:0 ~blobs_failed:0
915
-
else
916
-
let%lwt imported, failed =
917
-
Ops.import_blobs_batch ~pds_endpoint:old_pds
918
-
~access_jwt:session.access_jwt ~did ~cids:missing_cids
919
-
in
920
-
let cursor = Option.value ~default:"" next_cursor in
921
-
if String.length cursor = 0 then
922
-
transition_to_plc_token_step ctx ~did ~handle ~old_pds
923
-
~access_jwt:session.access_jwt
924
-
~refresh_jwt:session.refresh_jwt ~email
925
-
~blobs_imported:imported ~blobs_failed:failed
894
+
render_err ~did ~handle ~old_pds e
895
+
| Ok () -> (
896
+
match%lwt Ops.list_missing_blobs ~did ~limit:50 () with
897
+
| Error e ->
898
+
Dream.warning (fun log ->
899
+
log "migration %s: failed to list missing blobs: %s"
900
+
did e ) ;
901
+
transition_to_plc_token_step ctx ~old_client:client
902
+
~old_pds ~did ~handle ~email ~blobs_imported:0
903
+
~blobs_failed:0
904
+
| Ok (missing_cids, next_cursor) ->
905
+
if List.length missing_cids = 0 then
906
+
transition_to_plc_token_step ctx ~old_client:client
907
+
~old_pds ~did ~handle ~email ~blobs_imported:0
908
+
~blobs_failed:0
926
909
else
927
-
let%lwt () =
928
-
State.set ctx.req
929
-
{ did
930
-
; handle
931
-
; old_pds
932
-
; access_jwt= session.access_jwt
933
-
; refresh_jwt= session.refresh_jwt
934
-
; email
935
-
; blobs_imported= imported
936
-
; blobs_failed= failed
937
-
; blobs_cursor= cursor
938
-
; plc_requested= false }
910
+
let%lwt imported, failed =
911
+
Ops.import_blobs_batch client ~did ~cids:missing_cids
939
912
in
940
-
Util.render_html ~title:"Migrate Account"
941
-
(module Frontend.MigratePage)
942
-
~props:
943
-
(make_props ~csrf_token ~invite_required ~hostname
944
-
~step:"importing_data" ~did ~handle ~old_pds
945
-
~blobs_imported:imported ~blobs_failed:failed () )
946
-
) ) ) ) )
913
+
let cursor = Option.value ~default:"" next_cursor in
914
+
if String.length cursor = 0 then
915
+
transition_to_plc_token_step ctx ~old_client:client
916
+
~old_pds ~did ~handle ~email
917
+
~blobs_imported:imported ~blobs_failed:failed
918
+
else
919
+
let%lwt () =
920
+
State.set ctx.req
921
+
{ did
922
+
; handle
923
+
; old_pds
924
+
; session=
925
+
session_to_yojson_with_pds ~old_pds session
926
+
; email
927
+
; blobs_imported= imported
928
+
; blobs_failed= failed
929
+
; blobs_cursor= cursor
930
+
; plc_requested= false }
931
+
in
932
+
Util.render_html ~title:"Migrate Account"
933
+
(module Frontend.MigratePage)
934
+
~props:
935
+
(make_props ~csrf_token ~invite_required ~hostname
936
+
~step:"importing_data" ~did ~handle ~old_pds
937
+
~blobs_imported:imported ~blobs_failed:failed
938
+
() ) ) ) ) ) ) )
947
939
948
940
let get_handler =
949
941
Xrpc.handler (fun ctx ->
···
997
989
| "resend_plc_token" ->
998
990
handle_resend_plc_token ctx ~csrf_token ~invite_required ~hostname
999
991
| "submit_2fa" ->
1000
-
handle_submit_2fa ctx ~render_err fields
992
+
handle_submit_2fa ctx ~render_err ~csrf_token ~invite_required
993
+
~hostname fields
1001
994
| "resume_migration" ->
1002
995
handle_resume_migration ctx ~csrf_token ~invite_required ~hostname
1003
996
~render_err fields
+6
-12
pegasus/lib/api/account_/migrate/ops.ml
+6
-12
pegasus/lib/api/account_/migrate/ops.ml
···
1
1
(* local migration operations *)
2
2
3
-
type check_account_status_response = Server.CheckAccountStatus.response
4
-
[@@deriving yojson {strict= false}]
5
-
6
3
let get_account_status = Server.CheckAccountStatus.get_account_status
7
-
8
-
let get_recommended_did_credentials =
9
-
Identity.GetRecommendedDidCredentials.get_credentials
10
4
11
5
let create_account ~email ~handle ~password ~did ~service_auth_token
12
6
?invite_code db =
···
116
110
with exn ->
117
111
Lwt.return_error ("Failed to import repository: " ^ Printexc.to_string exn)
118
112
119
-
let import_blobs_batch ~pds_endpoint ~access_jwt ~did ~cids =
113
+
let import_blobs_batch ~did ~cids client =
120
114
let%lwt user_db = User_store.connect ~create:true did in
121
115
let%lwt results =
122
116
Lwt_list.map_p
123
117
(fun cid_str ->
124
-
match%lwt
125
-
Remote.fetch_blob ~pds_endpoint ~access_jwt ~did ~cid:cid_str
126
-
with
118
+
match%lwt Remote.fetch_blob ~did ~cid:cid_str client with
127
119
| Error e ->
128
120
Dream.warning (fun log ->
129
121
log "migration %s: failed to fetch blob %s: %s" did cid_str e ) ;
130
122
Lwt.return_error cid_str
131
-
| Ok (mimetype, data) -> (
123
+
| Ok (data, mimetype) -> (
132
124
match Cid.of_string cid_str with
133
125
| Error _ ->
134
126
Lwt.return_error cid_str
135
127
| Ok cid ->
136
-
let%lwt _ = User_store.put_blob user_db cid mimetype data in
128
+
let%lwt _ =
129
+
User_store.put_blob user_db cid mimetype (Bytes.of_string data)
130
+
in
137
131
Lwt.return_ok cid_str ) )
138
132
cids
139
133
in
+137
-378
pegasus/lib/api/account_/migrate/remote.ml
+137
-378
pegasus/lib/api/account_/migrate/remote.ml
···
1
1
(* remote pds xrpc calls for account migration *)
2
-
3
-
type create_session_response = Server.CreateSession.response
4
-
[@@deriving yojson {strict= false}]
5
-
6
-
type get_session_response = Server.GetSession.response
7
-
[@@deriving yojson {strict= false}]
8
-
9
-
type refresh_session_response = Server.RefreshSession.response
10
-
[@@deriving yojson {strict= false}]
11
-
12
-
type service_auth_response = Server.GetServiceAuth.response
13
-
[@@deriving yojson {strict= false}]
14
-
15
-
type list_blobs_response = Repo.ListMissingBlobs.response
16
-
[@@deriving yojson {strict= false}]
17
-
18
-
type get_preferences_response = Proxy.AppBskyActorGetPreferences.response
19
-
[@@deriving yojson {strict= false}]
20
-
21
-
type sign_plc_operation_response = Identity.SignPlcOperation.response
22
-
[@@deriving yojson {strict= false}]
23
-
24
-
type remote_credentials_response =
25
-
Identity.GetRecommendedDidCredentials.response
26
-
[@@deriving yojson {strict= false}]
27
-
2
+
open Lexicons
28
3
open Cohttp_lwt
29
4
30
5
type auth_result =
31
-
| AuthSuccess of create_session_response
6
+
| AuthSuccess of Hermes.client
32
7
| AuthNeeds2FA
33
8
| AuthError of string
34
9
35
-
let post_json ~uri ~headers ~body =
36
-
let headers = Http.Header.add headers "Content-Type" "application/json" in
37
-
Cohttp_lwt_unix.Client.post ~headers
38
-
~body:(Body.of_string (Yojson.Safe.to_string body))
39
-
uri
40
-
41
-
let post_empty ~uri ~headers =
42
-
Cohttp_lwt_unix.Client.post ~headers ~body:Body.empty uri
43
-
44
10
let resolve_identity identifier =
45
11
let%lwt did =
46
12
if String.starts_with ~prefix:"did:" identifier then
···
79
45
in
80
46
Lwt.return_ok (did, handle, pds_endpoint) ) )
81
47
82
-
let create_session ~pds_endpoint ~identifier ~password ?auth_factor_token () =
83
-
let uri =
84
-
Uri.with_path
85
-
(Uri.of_string pds_endpoint)
86
-
"/xrpc/com.atproto.server.createSession"
87
-
in
88
-
let body =
89
-
let base =
90
-
[("identifier", `String identifier); ("password", `String password)]
48
+
let create_session ~service ~identifier ~password ?auth_factor_token () =
49
+
try%lwt
50
+
let%lwt client =
51
+
Hermes.login
52
+
(Hermes.make_credential_manager ~service ())
53
+
~identifier ~password ?auth_factor_token ()
91
54
in
92
-
match auth_factor_token with
93
-
| Some token ->
94
-
`Assoc (("authFactorToken", `String token) :: base)
95
-
| None ->
96
-
`Assoc base
97
-
in
98
-
let headers = Http.Header.init () in
99
-
try%lwt
100
-
let%lwt res, body = post_json ~uri ~headers ~body in
101
-
match res.status with
102
-
| `OK -> (
103
-
let%lwt body_str = Body.to_string body in
104
-
match
105
-
create_session_response_of_yojson (Yojson.Safe.from_string body_str)
106
-
with
107
-
| Ok session ->
108
-
Lwt.return (AuthSuccess session)
109
-
| Error e ->
110
-
Lwt.return (AuthError ("Invalid session response: " ^ e)) )
111
-
| `Unauthorized -> (
112
-
let%lwt body_str = Body.to_string body in
113
-
try
114
-
let json = Yojson.Safe.from_string body_str in
115
-
let open Yojson.Safe.Util in
116
-
let error = json |> member "error" |> to_string_option in
117
-
match error with
118
-
| Some "AuthFactorTokenRequired" ->
119
-
Lwt.return AuthNeeds2FA
120
-
| _ ->
121
-
Lwt.return (AuthError "Invalid credentials")
122
-
with _ -> Lwt.return (AuthError "Invalid credentials") )
123
-
| status ->
124
-
let%lwt body_str = Body.to_string body in
125
-
Lwt.return
126
-
(AuthError
127
-
(Printf.sprintf "Authentication failed (%s): %s"
128
-
(Http.Status.to_string status)
129
-
body_str ) )
130
-
with exn ->
131
-
Lwt.return (AuthError ("Network error: " ^ Printexc.to_string exn))
55
+
Lwt.return (AuthSuccess client)
56
+
with
57
+
| Hermes.Xrpc_error {status; error; _}
58
+
when Http.Status.of_int status = `Unauthorized -> (
59
+
match error with
60
+
| "AuthFactorTokenRequired" ->
61
+
Lwt.return AuthNeeds2FA
62
+
| _ ->
63
+
Lwt.return (AuthError "Invalid credentials") )
64
+
| Hermes.Xrpc_error {status; error; _} ->
65
+
Lwt.return
66
+
(AuthError (Printf.sprintf "Authentication failed: %d %s" status error))
67
+
| exn ->
68
+
Lwt.return (AuthError ("Network error: " ^ Printexc.to_string exn))
132
69
133
-
let get_session ~pds_endpoint ~access_jwt =
134
-
let uri =
135
-
Uri.with_path
136
-
(Uri.of_string pds_endpoint)
137
-
"/xrpc/com.atproto.server.getSession"
138
-
in
139
-
let headers =
140
-
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
141
-
in
70
+
let get_session client =
142
71
try%lwt
143
-
let%lwt res, body = Util.http_get uri ~headers in
144
-
match res.status with
145
-
| `OK -> (
146
-
let%lwt body_str = Body.to_string body in
147
-
match
148
-
get_session_response_of_yojson (Yojson.Safe.from_string body_str)
149
-
with
150
-
| Ok session ->
151
-
Lwt.return_ok session
152
-
| Error e ->
153
-
Lwt.return_error ("Invalid session response: " ^ e) )
154
-
| status ->
155
-
let%lwt body_str = Body.to_string body in
156
-
Lwt.return_error
157
-
(Printf.sprintf "Failed to get session info (%s): %s"
158
-
(Http.Status.to_string status)
159
-
body_str )
160
-
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
72
+
let%lwt res = [%xrpc get "com.atproto.server.getSession"] client in
73
+
Lwt.return_ok res
74
+
with
75
+
| Hermes.Xrpc_error {status; error; _} ->
76
+
Lwt.return_error
77
+
(Printf.sprintf "Failed to get session info: %d %s" status error)
78
+
| exn ->
79
+
Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
161
80
162
81
let jwt_needs_refresh ?(delta_s = 60) access_jwt =
163
-
match Jwt.decode_jwt access_jwt with
164
-
| Error _ ->
165
-
true
166
-
| Ok (_header, payload) -> (
167
-
try
168
-
let open Yojson.Safe.Util in
169
-
let exp = payload |> member "exp" |> to_int in
170
-
let now = int_of_float (Unix.gettimeofday ()) in
171
-
exp - now < delta_s
172
-
with _ -> true )
82
+
Hermes.Jwt.is_expired ~buffer_seconds:delta_s access_jwt
173
83
174
-
let refresh_session ~pds_endpoint ~refresh_jwt =
175
-
let uri =
176
-
Uri.with_path
177
-
(Uri.of_string pds_endpoint)
178
-
"/xrpc/com.atproto.server.refreshSession"
179
-
in
180
-
let headers =
181
-
Http.Header.of_list [("Authorization", "Bearer " ^ refresh_jwt)]
182
-
in
84
+
let refresh_session client =
183
85
try%lwt
184
-
let%lwt res, body = post_empty ~uri ~headers in
185
-
match res.status with
186
-
| `OK -> (
187
-
let%lwt body_str = Body.to_string body in
188
-
match
189
-
refresh_session_response_of_yojson (Yojson.Safe.from_string body_str)
190
-
with
191
-
| Ok tokens ->
192
-
Lwt.return_ok tokens
193
-
| Error e ->
194
-
Lwt.return_error ("Invalid refresh response: " ^ e) )
195
-
| status ->
196
-
let%lwt body_str = Body.to_string body in
197
-
Lwt.return_error
198
-
(Printf.sprintf "Failed to refresh session (%s): %s"
199
-
(Http.Status.to_string status)
200
-
body_str )
201
-
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
86
+
let%lwt res = [%xrpc post "com.atproto.server.refreshSession"] client in
87
+
Lwt.return_ok res
88
+
with
89
+
| Hermes.Xrpc_error {status; error; _} ->
90
+
Lwt.return_error
91
+
(Printf.sprintf "Failed to refresh session: %d %s" status error)
92
+
| exn ->
93
+
Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
202
94
203
-
let get_service_auth ~pds_endpoint ~access_jwt =
204
-
let uri =
205
-
Uri.with_path
206
-
(Uri.of_string pds_endpoint)
207
-
"/xrpc/com.atproto.server.getServiceAuth"
208
-
|> fun u ->
209
-
Uri.add_query_params' u
210
-
[ ("aud", Env.did)
211
-
; ("lxm", "com.atproto.server.createAccount")
212
-
; ("exp", string_of_int (int_of_float (Unix.gettimeofday ()) + 300)) ]
213
-
in
214
-
let headers =
215
-
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
216
-
in
95
+
let get_service_auth client =
217
96
try%lwt
218
-
let%lwt res, body = Util.http_get uri ~headers in
219
-
match res.status with
220
-
| `OK -> (
221
-
let%lwt body_str = Body.to_string body in
222
-
match
223
-
service_auth_response_of_yojson (Yojson.Safe.from_string body_str)
224
-
with
225
-
| Ok {token} ->
226
-
Lwt.return_ok token
227
-
| Error e ->
228
-
Lwt.return_error ("Invalid service auth response: " ^ e) )
229
-
| status ->
230
-
let%lwt body_str = Body.to_string body in
231
-
Lwt.return_error
232
-
(Printf.sprintf "Failed to get service auth (%s): %s"
233
-
(Http.Status.to_string status)
234
-
body_str )
235
-
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
97
+
let%lwt res =
98
+
[%xrpc get "com.atproto.server.getServiceAuth"]
99
+
~aud:Env.did ~lxm:"com.atproto.server.createAccount"
100
+
~exp:(int_of_float (Unix.gettimeofday ()) + 300)
101
+
client
102
+
in
103
+
Lwt.return_ok res.token
104
+
with
105
+
| Hermes.Xrpc_error {status; error; _} ->
106
+
Lwt.return_error
107
+
(Printf.sprintf "Failed to get service auth: %d %s" status error)
108
+
| exn ->
109
+
Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
236
110
237
-
let get_recommended_credentials ~pds_endpoint ~access_jwt =
238
-
let uri =
239
-
Uri.with_path
240
-
(Uri.of_string pds_endpoint)
241
-
"/xrpc/com.atproto.identity.getRecommendedDidCredentials"
242
-
in
243
-
let headers =
244
-
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
245
-
in
111
+
let get_recommended_credentials client =
246
112
try%lwt
247
-
let%lwt res, body = Cohttp_lwt_unix.Client.get ~headers uri in
248
-
match res.status with
249
-
| `OK -> (
250
-
let%lwt body_str = Body.to_string body in
251
-
match
252
-
remote_credentials_response_of_yojson
253
-
(Yojson.Safe.from_string body_str)
254
-
with
255
-
| Ok creds ->
256
-
Lwt.return_ok creds
257
-
| Error e ->
258
-
Lwt.return_error ("Invalid credentials response: " ^ e) )
259
-
| status ->
260
-
let%lwt body_str = Body.to_string body in
261
-
Lwt.return_error
262
-
(Printf.sprintf "Failed to get remote credentials (%s): %s"
263
-
(Http.Status.to_string status)
264
-
body_str )
265
-
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
113
+
let%lwt res =
114
+
[%xrpc get "com.atproto.identity.getRecommendedDidCredentials"] client
115
+
in
116
+
Lwt.return_ok res
117
+
with
118
+
| Hermes.Xrpc_error {status; error; _} ->
119
+
Lwt.return_error
120
+
(Printf.sprintf "Failed to get recommended credentials: %d %s" status
121
+
error )
122
+
| exn ->
123
+
Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
266
124
267
-
let request_plc_signature ~pds_endpoint ~access_jwt =
268
-
let uri =
269
-
Uri.with_path
270
-
(Uri.of_string pds_endpoint)
271
-
"/xrpc/com.atproto.identity.requestPlcOperationSignature"
272
-
in
273
-
let headers =
274
-
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
275
-
in
125
+
let request_plc_signature client =
276
126
try%lwt
277
-
let%lwt res, body = post_empty ~uri ~headers in
278
-
match res.status with
279
-
| `OK ->
280
-
let%lwt () = Body.drain_body body in
281
-
Lwt.return_ok ()
282
-
| status ->
283
-
let%lwt body_str = Body.to_string body in
284
-
Lwt.return_error
285
-
(Printf.sprintf "Failed to request PLC signature (%s): %s"
286
-
(Http.Status.to_string status)
287
-
body_str )
288
-
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
127
+
let%lwt () =
128
+
[%xrpc post "com.atproto.identity.requestPlcOperationSignature"] client
129
+
in
130
+
Lwt.return_ok ()
131
+
with
132
+
| Hermes.Xrpc_error {status; error; _} ->
133
+
Lwt.return_error
134
+
(Printf.sprintf "Failed to request PLC signature: %d %s" status error)
135
+
| exn ->
136
+
Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
289
137
290
-
let sign_plc_operation ~pds_endpoint ~access_jwt ~token
291
-
~(credentials : Plc.credentials) =
292
-
let uri =
293
-
Uri.with_path
294
-
(Uri.of_string pds_endpoint)
295
-
"/xrpc/com.atproto.identity.signPlcOperation"
296
-
in
297
-
let headers =
298
-
Http.Header.of_list
299
-
[ ("Authorization", "Bearer " ^ access_jwt)
300
-
; ("Content-Type", "application/json") ]
301
-
in
302
-
let body =
303
-
`Assoc
304
-
[ ("token", `String token)
305
-
; ( "rotationKeys"
306
-
, `List (List.map (fun s -> `String s) credentials.rotation_keys) )
307
-
; ( "verificationMethods"
308
-
, `Assoc
309
-
(List.map
310
-
(fun (k, v) -> (k, `String v))
311
-
credentials.verification_methods ) )
312
-
; ( "alsoKnownAs"
313
-
, `List (List.map (fun s -> `String s) credentials.also_known_as) )
314
-
; ("services", Plc.service_map_to_yojson credentials.services) ]
315
-
in
138
+
let sign_plc_operation ~token ~(credentials : Plc.credentials) client =
316
139
try%lwt
317
-
let%lwt res, body =
318
-
Cohttp_lwt_unix.Client.post ~headers
319
-
~body:(Body.of_string (Yojson.Safe.to_string body))
320
-
uri
140
+
let verification_methods =
141
+
`Assoc
142
+
(List.map
143
+
(fun (k, v) -> (k, `String v))
144
+
credentials.verification_methods )
321
145
in
322
-
match res.status with
323
-
| `OK -> (
324
-
let%lwt body_str = Body.to_string body in
325
-
match
326
-
sign_plc_operation_response_of_yojson
327
-
(Yojson.Safe.from_string body_str)
328
-
with
329
-
| Ok resp ->
330
-
Lwt.return_ok resp.operation
331
-
| Error e ->
332
-
Lwt.return_error ("Invalid sign operation response: " ^ e) )
333
-
| status ->
334
-
let%lwt body_str = Body.to_string body in
335
-
Lwt.return_error
336
-
(Printf.sprintf "Failed to sign PLC operation (%s): %s"
337
-
(Http.Status.to_string status)
338
-
body_str )
339
-
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
146
+
let services = Plc.service_map_to_yojson credentials.services in
147
+
let%lwt res =
148
+
[%xrpc post "com.atproto.identity.signPlcOperation"]
149
+
~token ~rotation_keys:credentials.rotation_keys ~verification_methods
150
+
~also_known_as:credentials.also_known_as ~services client
151
+
in
152
+
Lwt.return_ok res.operation
153
+
with
154
+
| Hermes.Xrpc_error {status; error; _} ->
155
+
Lwt.return_error
156
+
(Printf.sprintf "Failed to sign PLC operation: %d %s" status error)
157
+
| exn ->
158
+
Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
340
159
341
-
let fetch_repo ~pds_endpoint ~access_jwt ~did =
342
-
let uri =
343
-
Uri.with_path (Uri.of_string pds_endpoint) "/xrpc/com.atproto.sync.getRepo"
344
-
|> fun u -> Uri.add_query_param' u ("did", did)
345
-
in
346
-
let headers =
347
-
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
348
-
in
160
+
let fetch_repo ~did client =
349
161
try%lwt
350
-
let%lwt res, body = Util.http_get uri ~headers in
351
-
match res.status with
352
-
| `OK ->
353
-
let%lwt body_bytes = Body.to_string body in
354
-
Lwt.return_ok (Bytes.of_string body_bytes)
355
-
| status ->
356
-
let%lwt () = Body.drain_body body in
357
-
Lwt.return_error
358
-
(Printf.sprintf "Failed to fetch repo (%s)"
359
-
(Http.Status.to_string status) )
360
-
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
162
+
let%lwt res = [%xrpc get "com.atproto.sync.getRepo"] ~did client in
163
+
Lwt.return_ok res
164
+
with
165
+
| Hermes.Xrpc_error {status; error; _} ->
166
+
Lwt.return_error
167
+
(Printf.sprintf "Failed to fetch repo: %d %s" status error)
168
+
| exn ->
169
+
Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
361
170
362
-
let fetch_blob ~pds_endpoint ~access_jwt ~did ~cid =
363
-
let uri =
364
-
Uri.with_path (Uri.of_string pds_endpoint) "/xrpc/com.atproto.sync.getBlob"
365
-
|> fun u -> Uri.add_query_params' u [("did", did); ("cid", cid)]
366
-
in
367
-
let headers =
368
-
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
369
-
in
171
+
let fetch_blob ~did ~cid client =
370
172
try%lwt
371
-
let%lwt res, body = Util.http_get uri ~headers in
372
-
match res.status with
373
-
| `OK ->
374
-
let content_type =
375
-
Http.Header.get res.headers "Content-Type"
376
-
|> Option.value ~default:"application/octet-stream"
377
-
in
378
-
let%lwt body_bytes = Body.to_string body in
379
-
Lwt.return_ok (content_type, Bytes.of_string body_bytes)
380
-
| status ->
381
-
let%lwt () = Body.drain_body body in
382
-
Lwt.return_error
383
-
(Printf.sprintf "Failed to fetch blob %s (%s)" cid
384
-
(Http.Status.to_string status) )
385
-
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
173
+
let%lwt res = [%xrpc get "com.atproto.sync.getBlob"] ~did ~cid client in
174
+
Lwt.return_ok res
175
+
with
176
+
| Hermes.Xrpc_error {status; error; _} ->
177
+
Lwt.return_error
178
+
(Printf.sprintf "Failed to fetch blob %s: %d %s" cid status error)
179
+
| exn ->
180
+
Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
386
181
387
-
let fetch_preferences ~pds_endpoint ~access_jwt =
388
-
let uri =
389
-
Uri.with_path
390
-
(Uri.of_string pds_endpoint)
391
-
"/xrpc/app.bsky.actor.getPreferences"
392
-
in
393
-
let headers =
394
-
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
395
-
in
182
+
let fetch_preferences client =
396
183
try%lwt
397
-
let%lwt res, body = Util.http_get uri ~headers in
398
-
match res.status with
399
-
| `OK -> (
400
-
let%lwt body_str = Body.to_string body in
401
-
match
402
-
get_preferences_response_of_yojson (Yojson.Safe.from_string body_str)
403
-
with
404
-
| Ok resp ->
405
-
Lwt.return_ok resp.preferences
406
-
| Error e ->
407
-
Dream.warning (fun log ->
408
-
log "migration: failed to parse preferences response: %s" e ) ;
409
-
Lwt.return_ok (`List []) )
410
-
| status ->
411
-
let%lwt () = Body.drain_body body in
412
-
Dream.warning (fun log ->
413
-
log "migration: failed to fetch preferences: %s"
414
-
(Http.Status.to_string status) ) ;
415
-
Lwt.return_ok (`List [])
416
-
with exn ->
417
-
Dream.warning (fun log ->
418
-
log "migration: exception fetching preferences: %s"
419
-
(Printexc.to_string exn) ) ;
420
-
Lwt.return_ok (`List [])
184
+
let%lwt res = [%xrpc get "app.bsky.actor.getPreferences"] client in
185
+
Lwt.return_ok res.preferences
186
+
with
187
+
| Hermes.Xrpc_error {status; error; _} ->
188
+
Dream.warning (fun log ->
189
+
log "migration: failed to fetch preferences: %d %s" status error ) ;
190
+
Lwt.return_ok []
191
+
| exn ->
192
+
Dream.warning (fun log ->
193
+
log "migration: exception fetching preferences: %s"
194
+
(Printexc.to_string exn) ) ;
195
+
Lwt.return_ok []
421
196
422
-
let deactivate_account ~pds_endpoint ~access_jwt =
423
-
let uri =
424
-
Uri.with_path
425
-
(Uri.of_string pds_endpoint)
426
-
"/xrpc/com.atproto.server.deactivateAccount"
427
-
in
428
-
let headers =
429
-
Http.Header.of_list
430
-
[ ("Authorization", "Bearer " ^ access_jwt)
431
-
; ("Content-Type", "application/json") ]
432
-
in
197
+
let deactivate_account client =
433
198
try%lwt
434
-
let%lwt res, body =
435
-
Cohttp_lwt_unix.Client.post ~headers ~body:(Body.of_string "{}") uri
436
-
in
437
-
match res.status with
438
-
| `OK ->
439
-
let%lwt () = Body.drain_body body in
440
-
Lwt.return_ok ()
441
-
| status ->
442
-
let%lwt body_str = Body.to_string body in
443
-
Lwt.return_error
444
-
(Printf.sprintf "Failed to deactivate account (%s): %s"
445
-
(Http.Status.to_string status)
446
-
body_str )
447
-
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
199
+
let%lwt () = [%xrpc post "com.atproto.server.deactivateAccount"] client in
200
+
Lwt.return_ok ()
201
+
with
202
+
| Hermes.Xrpc_error {status; error; _} ->
203
+
Lwt.return_error
204
+
(Printf.sprintf "Failed to deactivate account: %d %s" status error)
205
+
| exn ->
206
+
Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
448
207
449
208
let get_plc_rotation_keys ~did =
450
209
if not (String.starts_with ~prefix:"did:plc:" did) then Lwt.return_ok []
+1
-2
pegasus/lib/api/account_/migrate/state.ml
+1
-2
pegasus/lib/api/account_/migrate/state.ml
+6
-18
pegasus/lib/api/identity/getRecommendedDidCredentials.ml
+6
-18
pegasus/lib/api/identity/getRecommendedDidCredentials.ml
···
1
-
let get_credentials did ?(extra_rotation_keys = []) db =
2
-
match%lwt Data_store.get_actor_by_identifier did db with
3
-
| None ->
4
-
Lwt.return_error "actor not found"
5
-
| Some actor ->
6
-
actor.signing_key |> Kleidos.parse_multikey_str |> Kleidos.derive_pubkey
7
-
|> Kleidos.pubkey_to_did_key
8
-
|> (fun did_key ->
9
-
Plc.create_did_credentials Env.rotation_key did_key actor.handle
10
-
~rotation_did_keys:extra_rotation_keys )
11
-
|> Lwt.return_ok
12
-
13
1
let handler =
14
2
Xrpc.handler ~auth:Authorization (fun {auth; db; _} ->
15
3
let did = Auth.get_authed_did_exn auth in
16
-
match%lwt get_credentials did db with
17
-
| Error msg ->
18
-
Errors.internal_error ~msg ()
19
-
| Ok credentials ->
20
-
credentials |> Plc.credentials_to_yojson |> Yojson.Safe.to_string
21
-
|> Dream.json )
4
+
match%lwt Data_store.get_actor_by_identifier did db with
5
+
| None ->
6
+
Errors.internal_error ~msg:"actor not found" ()
7
+
| Some {handle; signing_key; _} ->
8
+
Plc.get_recommended_credentials ~signing_key ~handle ()
9
+
|> Plc.credentials_to_yojson |> Yojson.Safe.to_string |> Dream.json )
+9
pegasus/lib/plc.ml
+9
pegasus/lib/plc.ml
···
225
225
, {type'= "AtprotoPersonalDataServer"; endpoint= Env.host_endpoint} ) ]
226
226
}
227
227
228
+
let get_recommended_credentials ~signing_key ~handle ?(extra_rotation_keys = [])
229
+
() =
230
+
let did_key =
231
+
signing_key |> Kleidos.parse_multikey_str |> Kleidos.derive_pubkey
232
+
|> Kleidos.pubkey_to_did_key
233
+
in
234
+
create_did_credentials Env.rotation_key did_key handle
235
+
~rotation_did_keys:extra_rotation_keys
236
+
228
237
let create_did (pds_rotation_key : Kleidos.key) (signing_did_key : string)
229
238
?(rotation_did_keys : string list option) handle : string * signed_operation
230
239
=