futur.blue
+3
bin/main.ml
+3
bin/main.ml
···
40
40
; ( get
41
41
, "/account/signup/check-handle"
42
42
, Api.Account_.Signup.check_handle_handler )
43
+
; (get, "/account/migrate", Api.Account_.Migrate.get_handler)
44
+
; (post, "/account/migrate", Api.Account_.Migrate.post_handler)
43
45
; (post, "/account/switch", Api.Account_.Login.switch_account_handler)
44
46
; (get, "/account/logout", Api.Account_.Logout.handler)
45
47
; (* admin ui *)
···
203
205
204
206
let serve () =
205
207
Printexc.record_backtrace true ;
208
+
Printexc.register_printer Errors.printer ;
206
209
Dream.initialize_log ~level:Env.log_level () ;
207
210
List.iter (fun src ->
208
211
match Logs.Src.name src with
+1
frontend/client/Router.mlx
+1
frontend/client/Router.mlx
···
17
17
; {path= "/oauth/authorize"; template= (module OauthAuthorizePage)}
18
18
; {path= "/account/login"; template= (module LoginPage)}
19
19
; {path= "/account/signup"; template= (module SignupPage)}
20
+
; {path= "/account/migrate"; template= (module MigratePage)}
20
21
; {path= "/account"; template= (module AccountPage)}
21
22
; {path= "/account/permissions"; template= (module AccountPermissionsPage)}
22
23
; {path= "/admin/login"; template= (module AdminLoginPage)}
+5
-3
frontend/src/templates/AccountPermissionsPage.mlx
+5
-3
frontend/src/templates/AccountPermissionsPage.mlx
···
89
89
<ul className="space-y-2">
90
90
( List.map
91
91
(fun (app : authorized_app) ->
92
-
let name = Option.value app.client_name ~default:app.client_host in
92
+
let name =
93
+
Option.value app.client_name ~default:app.client_host
94
+
in
93
95
<li key=app.client_id className="flex items-center gap-x-2">
94
96
<span
95
97
title=name
···
174
176
formMethod="post"
175
177
name="action"
176
178
value="sign_out_device"
177
-
className="text-mist-100 underline whitespace-nowrap \
178
-
hover:text-mana-100">
179
+
className="text-mist-100 underline \
180
+
whitespace-nowrap hover:text-mana-100">
179
181
(string "sign out")
180
182
</button>
181
183
</form>
+17
-7
frontend/src/templates/LoginPage.mlx
+17
-7
frontend/src/templates/LoginPage.mlx
···
33
33
</Button>
34
34
</form>
35
35
<span className="text-sm text-mist-100">
36
-
(string "or ")
37
-
<a
38
-
href="/account/signup"
39
-
className="text-mana-100 underline hover:text-mana-200">
40
-
(string "create an account")
41
-
</a>
42
-
(string ".")
36
+
(string "or: ")
37
+
<ul className="mt-1 pl-2">
38
+
<li className="mb-1">
39
+
<a
40
+
className="text-mana-100 underline hover:text-mana-200"
41
+
href="/account/signup">
42
+
(string "create an account")
43
+
</a>
44
+
</li>
45
+
<li>
46
+
<a
47
+
className="text-mana-100 underline hover:text-mana-200"
48
+
href="/account/migrate">
49
+
(string "migrate from another PDS")
50
+
</a>
51
+
</li>
52
+
</ul>
43
53
</span>
44
54
</main>
+636
frontend/src/templates/MigratePage.mlx
+636
frontend/src/templates/MigratePage.mlx
···
1
+
[@@@ocaml.warning "-26-27"]
2
+
3
+
open Melange_json.Primitives
4
+
open React
5
+
6
+
type migration_step =
7
+
| EnterCredentials
8
+
| ResumeAvailable
9
+
| Enter2FA
10
+
| ImportingData
11
+
| EnterPlcToken
12
+
| Complete
13
+
| Error
14
+
15
+
let step_of_string = function
16
+
| "enter_credentials" ->
17
+
EnterCredentials
18
+
| "resume_available" ->
19
+
ResumeAvailable
20
+
| "enter_2fa" ->
21
+
Enter2FA
22
+
| "importing_data" ->
23
+
ImportingData
24
+
| "enter_plc_token" ->
25
+
EnterPlcToken
26
+
| "complete" ->
27
+
Complete
28
+
| "error" ->
29
+
Error
30
+
| _ ->
31
+
EnterCredentials
32
+
33
+
let step_to_label = function
34
+
| EnterCredentials ->
35
+
"enter credentials"
36
+
| ResumeAvailable ->
37
+
"resume migration"
38
+
| Enter2FA ->
39
+
"two-factor authentication"
40
+
| ImportingData ->
41
+
"importing data"
42
+
| EnterPlcToken ->
43
+
"confirm identity"
44
+
| Complete ->
45
+
"migration complete"
46
+
| Error ->
47
+
"error"
48
+
49
+
let step_to_number = function
50
+
| EnterCredentials | ResumeAvailable | Enter2FA ->
51
+
0
52
+
| ImportingData ->
53
+
1
54
+
| EnterPlcToken ->
55
+
2
56
+
| Complete | Error ->
57
+
3
58
+
59
+
let total_steps = 3
60
+
61
+
module ProgressIndicator = struct
62
+
let[@react.component] make ~step_number ~label () =
63
+
<div className="mb-6">
64
+
<div className="flex items-center gap-1 text-sm text-mist-100 mb-2">
65
+
<span>
66
+
(string
67
+
( "step " ^ string_of_int step_number ^ " of "
68
+
^ string_of_int total_steps ^ ": " ) )
69
+
</span>
70
+
<span className="font-medium text-mana-100">(string label)</span>
71
+
</div>
72
+
<div
73
+
className="w-full bg-mist-60 rounded-full h-3"
74
+
style=(ReactDOM.Style.make
75
+
~boxShadow:"0 4px 8px 0 rgba(115, 117, 121, 0.30) inset" () )>
76
+
<div
77
+
className="bg-mana-100 shadow-elixir h-3 rounded-full transition-all \
78
+
duration-300"
79
+
style=(ReactDOM.Style.make
80
+
~width:(string_of_int (step_number * 100 / total_steps) ^ "%")
81
+
() )
82
+
/>
83
+
</div>
84
+
</div>
85
+
end
86
+
87
+
module AlertMessage = struct
88
+
let[@react.component] make ~message ~kind () =
89
+
let bg_class, text_class, icon =
90
+
match kind with
91
+
| `Error ->
92
+
( "bg-phoenix-100/10 border-phoenix-100/30"
93
+
, "text-phoenix-100"
94
+
, <CircleAlertIcon className="w-4 h-4 mr-2 mt-0.5 flex-shrink-0" /> )
95
+
| `Success ->
96
+
( "bg-mana-100/10 border-mana-100/30"
97
+
, "text-mana-100"
98
+
, <CheckmarkIcon className="w-4 h-4 mr-2 mt-0.5 flex-shrink-0" /> )
99
+
in
100
+
<div className=("mb-4 p-3 border rounded-lg " ^ bg_class)>
101
+
<span className=("inline-flex items-start text-sm " ^ text_class)>
102
+
icon <span>(string message)</span>
103
+
</span>
104
+
</div>
105
+
end
106
+
107
+
module LoadingOverlay = struct
108
+
type loading_step =
109
+
{ label: string
110
+
; message: string
111
+
; duration: int (* ms before moving to next step *) }
112
+
113
+
let steps =
114
+
[| { label= "authenticating"
115
+
; message= "Logging into your current PDS..."
116
+
; duration= 2000 (* fake step *) }
117
+
; { label= "creating account"
118
+
; message= "Creating your account on this PDS..."
119
+
; duration= 2000 (* fake step *) }
120
+
; { label= "importing repository"
121
+
; message= "Importing your repository data..."
122
+
; duration= 0 (* stays here until page loads *) } |]
123
+
124
+
let[@react.component] make () =
125
+
let step_index, set_step_index = React.useState (fun () -> 0) in
126
+
(* advance through steps on a timer *)
127
+
React.useEffect1
128
+
(fun () ->
129
+
let current = steps.(step_index) in
130
+
if current.duration > 0 && step_index < Array.length steps - 1 then
131
+
let timer_id =
132
+
Js.Global.setTimeout
133
+
~f:(fun () -> set_step_index (fun i -> i + 1))
134
+
current.duration
135
+
in
136
+
Some (fun () -> Js.Global.clearTimeout timer_id)
137
+
else None )
138
+
[|step_index|] ;
139
+
let current = steps.(step_index) in
140
+
let step_number = step_index + 1 in
141
+
<div>
142
+
<div className="mb-6">
143
+
<div className="flex items-center gap-1 text-sm text-mist-100 mb-2">
144
+
<span>
145
+
(string
146
+
( "step " ^ string_of_int step_number ^ " of "
147
+
^ string_of_int total_steps ^ ": " ) )
148
+
</span>
149
+
<span className="font-medium text-mana-100">
150
+
(string current.label)
151
+
</span>
152
+
</div>
153
+
<div
154
+
className="w-full bg-mist-60 rounded-full h-3"
155
+
style=(ReactDOM.Style.make
156
+
~boxShadow:"0 4px 8px 0 rgba(115, 117, 121, 0.30) inset" () )>
157
+
<div
158
+
className="bg-mana-100 shadow-elixir h-3 rounded-full \
159
+
transition-all duration-500"
160
+
style=(ReactDOM.Style.make
161
+
~width:
162
+
(string_of_int (step_number * 100 / total_steps) ^ "%")
163
+
() )
164
+
/>
165
+
</div>
166
+
</div>
167
+
<div className="flex flex-col items-center py-8">
168
+
<div
169
+
className="animate-spin w-8 h-8 border-2 border-mana-100 \
170
+
border-t-transparent rounded-full mb-4"
171
+
/>
172
+
<p className="text-mist-100 text-center">(string current.message)</p>
173
+
</div>
174
+
</div>
175
+
end
176
+
177
+
module DidDisplay = struct
178
+
let[@react.component] make ~did () =
179
+
<p className="text-xs text-mist-80 mb-4">
180
+
(string "Account DID: ")
181
+
<code className="bg-mist-60/50 px-1 rounded">(string did)</code>
182
+
</p>
183
+
end
184
+
185
+
module CredentialsForm = struct
186
+
let[@react.component] make ~csrf_token ~invite_required () =
187
+
let is_submitting, set_is_submitting = React.useState (fun () -> false) in
188
+
let handle_submit _ = set_is_submitting (fun _ -> true) in
189
+
if is_submitting then <LoadingOverlay />
190
+
else
191
+
array
192
+
[| <p key="desc" className="w-full text-balance text-mist-100 mb-4">
193
+
(string
194
+
"Migrate your existing atproto account to this PDS. You'll \
195
+
need your account credentials from your current PDS." )
196
+
</p>
197
+
; <form
198
+
key="form"
199
+
className="w-full flex flex-col gap-y-3"
200
+
onSubmit=handle_submit>
201
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
202
+
<input type_="hidden" name="action" value="start_migration" />
203
+
( if invite_required then
204
+
<Input
205
+
name="invite_code"
206
+
type_="text"
207
+
label="Invite code"
208
+
placeholder="a1b2c3d4"
209
+
required=true
210
+
showIndicator=false />
211
+
else null )
212
+
<Input
213
+
name="identifier"
214
+
type_="text"
215
+
label="Existing handle or DID"
216
+
placeholder="you.bsky.social or did:plc:..."
217
+
required=true
218
+
showIndicator=false
219
+
/>
220
+
<Input
221
+
name="password"
222
+
type_="password"
223
+
label="Existing password"
224
+
required=true
225
+
showIndicator=false
226
+
/>
227
+
<p className="text-xs text-mist-80 -mt-1">
228
+
(string
229
+
"Use your actual account password, not an app password. Your \
230
+
password is only used to log into your current PDS and is \
231
+
never stored." )
232
+
</p>
233
+
<Button type_="submit" formMethod="post" className="mt-2">
234
+
(string "start migration")
235
+
</Button>
236
+
</form>
237
+
; <div key="footer" className="mt-4">
238
+
<span className="text-sm text-mist-100">
239
+
(string "Don't have an account? ")
240
+
<a
241
+
href="/account/signup"
242
+
className="text-mana-100 underline hover:text-mana-200">
243
+
(string "sign up")
244
+
</a>
245
+
(string " instead.")
246
+
</span>
247
+
</div> |]
248
+
end
249
+
250
+
module ResumeForm = struct
251
+
let[@react.component] make ~csrf_token ~did () =
252
+
let is_submitting, set_is_submitting = React.useState (fun () -> false) in
253
+
let handle_submit _ = set_is_submitting (fun _ -> true) in
254
+
if is_submitting then <LoadingOverlay />
255
+
else
256
+
<div>
257
+
<div
258
+
className="bg-mana-100/10 border border-mana-100/30 rounded-lg p-4 \
259
+
mb-4">
260
+
<div className="flex items-start gap-3">
261
+
<CheckmarkIcon
262
+
className="w-5 h-5 text-mana-100 mt-0.5 flex-shrink-0"
263
+
/>
264
+
<div>
265
+
<h3 className="font-medium text-mana-100 mb-1">
266
+
(string "Previous migration found")
267
+
</h3>
268
+
<p className="text-sm text-mist-100">
269
+
(string
270
+
"An incomplete migration exists for this account. Enter \
271
+
your credentials again to continue where you left off." )
272
+
</p>
273
+
</div>
274
+
</div>
275
+
</div>
276
+
(match did with Some d -> <DidDisplay did=d /> | None -> null)
277
+
<form className="w-full flex flex-col gap-y-3" onSubmit=handle_submit>
278
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
279
+
<input type_="hidden" name="action" value="resume_migration" />
280
+
<Input
281
+
name="identifier"
282
+
type_="text"
283
+
label="Handle or DID"
284
+
placeholder="you.bsky.social or did:plc:..."
285
+
required=true
286
+
showIndicator=false
287
+
/>
288
+
<Input
289
+
name="password"
290
+
type_="password"
291
+
label="Password"
292
+
required=true
293
+
showIndicator=false
294
+
/>
295
+
<p className="text-xs text-mist-80 -mt-1">
296
+
(string
297
+
"Enter your credentials from your original PDS to resume the \
298
+
migration." )
299
+
</p>
300
+
<Button type_="submit" formMethod="post" className="mt-2">
301
+
(string "resume migration")
302
+
</Button>
303
+
</form>
304
+
<div className="mt-4">
305
+
<a
306
+
href="/account/migrate"
307
+
className="text-sm text-mist-100 underline hover:text-mana-100">
308
+
(string "Start a new migration instead")
309
+
</a>
310
+
</div>
311
+
</div>
312
+
end
313
+
314
+
module TwoFactorForm = struct
315
+
let[@react.component] make ~csrf_token ~identifier ~old_pds ~invite_code () =
316
+
let is_submitting, set_is_submitting = React.useState (fun () -> false) in
317
+
let handle_submit _ = set_is_submitting (fun _ -> true) in
318
+
if is_submitting then <LoadingOverlay />
319
+
else
320
+
<div>
321
+
<p className="text-mist-100 mb-4">
322
+
(string
323
+
"Your account requires two-factor authentication. Check your \
324
+
email for a sign-in code." )
325
+
</p>
326
+
<form className="w-full flex flex-col gap-y-3" onSubmit=handle_submit>
327
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
328
+
<input type_="hidden" name="action" value="submit_2fa" />
329
+
<input type_="hidden" name="identifier" value=identifier />
330
+
<input type_="hidden" name="old_pds" value=old_pds />
331
+
( match invite_code with
332
+
| Some code ->
333
+
<input type_="hidden" name="invite_code" value=code />
334
+
| None ->
335
+
null )
336
+
<Input
337
+
name="password"
338
+
type_="password"
339
+
label="Password"
340
+
required=true
341
+
showIndicator=false
342
+
/>
343
+
<Input
344
+
name="auth_factor_token"
345
+
type_="text"
346
+
label="Authentication code"
347
+
placeholder="123456"
348
+
required=true
349
+
showIndicator=false
350
+
/>
351
+
<p className="text-xs text-mist-80 -mt-1">
352
+
(string "Enter your password and the code from your email.")
353
+
</p>
354
+
<Button type_="submit" formMethod="post" className="mt-2">
355
+
(string "continue")
356
+
</Button>
357
+
</form>
358
+
<div className="mt-4">
359
+
<a
360
+
href="/account/migrate"
361
+
className="text-sm text-mist-100 underline hover:text-mana-100">
362
+
(string "Start over")
363
+
</a>
364
+
</div>
365
+
</div>
366
+
end
367
+
368
+
module BlobProgress = struct
369
+
let[@react.component] make ~csrf_token ~did ~blobs_imported ~blobs_failed () =
370
+
<div>
371
+
<div className="flex flex-col items-center py-6">
372
+
<div
373
+
className="animate-spin w-8 h-8 border-2 border-mana-100 \
374
+
border-t-transparent rounded-full mb-4"
375
+
/>
376
+
<p className="text-mist-100 text-center mb-1">
377
+
(string "Importing media...")
378
+
</p>
379
+
<p className="text-sm text-mist-80 text-center">
380
+
(string (Printf.sprintf "%d blobs imported" blobs_imported))
381
+
( if blobs_failed > 0 then
382
+
<span className="text-phoenix-100">
383
+
(string (Printf.sprintf " (%d failed)" blobs_failed))
384
+
</span>
385
+
else null )
386
+
</p>
387
+
</div>
388
+
<form className="flex justify-center">
389
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
390
+
<input type_="hidden" name="action" value="continue_blobs" />
391
+
( match did with
392
+
| Some d ->
393
+
<input type_="hidden" name="did" value=d />
394
+
| None ->
395
+
null )
396
+
<Button type_="submit" formMethod="post">
397
+
(string "continue importing")
398
+
</Button>
399
+
</form>
400
+
</div>
401
+
end
402
+
403
+
module PlcTokenForm = struct
404
+
let[@react.component] make ~csrf_token ~did () =
405
+
<div>
406
+
<p className="text-mist-100 mb-4">
407
+
(string
408
+
"Your account has been created and your data has been imported. To \
409
+
complete the migration, enter the confirmation code that was sent \
410
+
to your email." )
411
+
</p>
412
+
<form className="w-full flex flex-col gap-y-3">
413
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
414
+
<input type_="hidden" name="action" value="submit_plc_token" />
415
+
<Input
416
+
name="plc_token"
417
+
type_="text"
418
+
label="Confirmation code"
419
+
placeholder="A1B2C-3D4E5"
420
+
required=true
421
+
showIndicator=false
422
+
/>
423
+
<p className="text-xs text-mist-80 -mt-1">
424
+
(string
425
+
"This code was sent to the email address belonging to your \
426
+
account on your old PDS." )
427
+
</p>
428
+
<Button type_="submit" formMethod="post" className="mt-2">
429
+
(string "complete migration")
430
+
</Button>
431
+
</form>
432
+
<form className="mt-3">
433
+
<input type_="hidden" name="dream.csrf" value=csrf_token />
434
+
<input type_="hidden" name="action" value="resend_plc_token" />
435
+
<button
436
+
type_="submit"
437
+
formMethod="post"
438
+
className="text-sm text-mist-100 underline hover:text-mana-100">
439
+
(string "Resend confirmation code")
440
+
</button>
441
+
</form>
442
+
</div>
443
+
end
444
+
445
+
module CompleteView = struct
446
+
let[@react.component] make ~handle ~blobs_failed ~old_account_deactivated
447
+
~old_account_deactivation_error () =
448
+
<div className="py-4">
449
+
<div className="flex items-center gap-3 mb-4">
450
+
<div
451
+
className="w-10 h-10 bg-mana-100/20 rounded-full flex items-center \
452
+
justify-center">
453
+
<CheckmarkIcon className="w-5 h-5 text-mana-100" />
454
+
</div>
455
+
<div>
456
+
<h2 className="text-lg font-serif text-mana-100">
457
+
(string "Migration complete!")
458
+
</h2>
459
+
<p className="text-sm text-mist-100">
460
+
(string "Your account")
461
+
( match handle with
462
+
| Some h ->
463
+
<span className="font-medium text-mana-100">
464
+
(string (" @" ^ h))
465
+
</span>
466
+
| None ->
467
+
null )
468
+
(string " is now on this PDS.")
469
+
</p>
470
+
</div>
471
+
</div>
472
+
( if old_account_deactivated then
473
+
<p className="mb-4 text-sm text-mist-80">
474
+
(string
475
+
"Your account on your old PDS has been deactivated \
476
+
automatically." )
477
+
</p>
478
+
else
479
+
match old_account_deactivation_error with
480
+
| Some err ->
481
+
<div
482
+
className="mb-4 p-3 bg-phoenix-100/10 border \
483
+
border-phoenix-100/30 rounded-lg">
484
+
<div className="flex items-start gap-2">
485
+
<CircleAlertIcon
486
+
className="w-4 h-4 text-phoenix-100 mt-0.5 flex-shrink-0"
487
+
/>
488
+
<div>
489
+
<p className="text-sm text-phoenix-100 font-medium">
490
+
(string "Could not deactivate your old account")
491
+
</p>
492
+
<p className="text-xs text-phoenix-100/80 mt-1">
493
+
(string err)
494
+
</p>
495
+
<p className="text-sm text-mist-100 mt-2">
496
+
(string
497
+
"You may need to log into your account on your old \
498
+
PDS to deactivate it there." )
499
+
</p>
500
+
</div>
501
+
</div>
502
+
</div>
503
+
| None ->
504
+
<p className="mb-4 text-sm text-mist-80">
505
+
(string
506
+
"Make sure to log into your account on your old PDS to \
507
+
deactivate it there." )
508
+
</p> )
509
+
( if blobs_failed > 0 then
510
+
<div
511
+
className="mb-4 p-3 bg-phoenix-100/10 border border-phoenix-100/30 \
512
+
rounded-lg">
513
+
<p className="text-sm text-phoenix-100">
514
+
(string
515
+
(Printf.sprintf
516
+
"%d blob(s) failed to import. This means some of your \
517
+
content may appear to have missing media."
518
+
blobs_failed ) )
519
+
</p>
520
+
</div>
521
+
else null )
522
+
<div className="flex gap-3">
523
+
<a href="/account"><Button>(string "go to account")</Button></a>
524
+
</div>
525
+
</div>
526
+
end
527
+
528
+
module ErrorView = struct
529
+
let[@react.component] make () =
530
+
<div>
531
+
<p className="text-mist-100 mb-2">
532
+
(string
533
+
"Something went wrong during migration. Don't worry, your data on \
534
+
your original PDS is safe." )
535
+
</p>
536
+
<p className="text-mist-100 mb-4">
537
+
(string
538
+
"Check your internet connection and try again, or contact the PDS \
539
+
administrator if the problem persists.\n\n" )
540
+
</p>
541
+
<div className="flex gap-3">
542
+
<a href="/account/migrate"><Button>(string "try again")</Button></a>
543
+
<a href="/account/login">
544
+
<Button kind=`Secondary>(string "back to login")</Button>
545
+
</a>
546
+
</div>
547
+
</div>
548
+
end
549
+
550
+
type props =
551
+
{ csrf_token: string
552
+
; invite_required: bool
553
+
; hostname: string
554
+
; step: string [@default "enter_credentials"]
555
+
; did: string option [@default None]
556
+
; handle: string option [@default None]
557
+
; old_pds: string option [@default None]
558
+
; identifier: string option [@default None]
559
+
; invite_code: string option [@default None]
560
+
; blobs_imported: int [@default 0]
561
+
; blobs_failed: int [@default 0]
562
+
; old_account_deactivated: bool [@default false]
563
+
; old_account_deactivation_error: string option [@default None]
564
+
; error: string option [@default None]
565
+
; message: string option [@default None] }
566
+
[@@deriving json]
567
+
568
+
let[@react.component] make
569
+
~props:
570
+
({ csrf_token
571
+
; invite_required
572
+
; hostname= _
573
+
; step
574
+
; did
575
+
; handle
576
+
; old_pds
577
+
; identifier
578
+
; invite_code
579
+
; blobs_imported
580
+
; blobs_failed
581
+
; old_account_deactivated
582
+
; old_account_deactivation_error
583
+
; error
584
+
; message } :
585
+
props ) () =
586
+
let current_step = step_of_string step in
587
+
let step_number = step_to_number current_step in
588
+
let show_progress =
589
+
current_step <> EnterCredentials
590
+
&& current_step <> ResumeAvailable
591
+
&& current_step <> Enter2FA && current_step <> Error
592
+
&& current_step <> Complete
593
+
in
594
+
<main className="w-full h-auto max-w-md px-4 sm:px-0 my-auto">
595
+
<h1 className="text-2xl font-serif text-mana-200 mb-2">
596
+
(string "migrate account")
597
+
</h1>
598
+
( if show_progress then
599
+
<ProgressIndicator step_number label=(step_to_label current_step) />
600
+
else null )
601
+
( match error with
602
+
| Some err ->
603
+
<AlertMessage message=err kind=`Error />
604
+
| None ->
605
+
null )
606
+
( match message with
607
+
| Some msg when current_step <> Complete ->
608
+
<AlertMessage message=msg kind=`Success />
609
+
| _ ->
610
+
null )
611
+
( match current_step with
612
+
| EnterCredentials ->
613
+
<CredentialsForm csrf_token invite_required />
614
+
| ResumeAvailable ->
615
+
<ResumeForm csrf_token did />
616
+
| Enter2FA ->
617
+
<TwoFactorForm
618
+
csrf_token
619
+
identifier=(Option.value ~default:"" identifier)
620
+
old_pds=(Option.value ~default:"" old_pds)
621
+
invite_code
622
+
/>
623
+
| ImportingData ->
624
+
<BlobProgress csrf_token did blobs_imported blobs_failed />
625
+
| EnterPlcToken ->
626
+
<PlcTokenForm csrf_token did />
627
+
| Complete ->
628
+
<CompleteView
629
+
handle
630
+
blobs_failed
631
+
old_account_deactivated
632
+
old_account_deactivation_error
633
+
/>
634
+
| Error ->
635
+
<ErrorView /> )
636
+
</main>
+6
frontend/src/templates/SignupPage.mlx
+6
frontend/src/templates/SignupPage.mlx
···
46
46
className="text-mana-100 underline hover:text-mana-200">
47
47
(string "sign in")
48
48
</a>
49
+
(string " or ")
50
+
<a
51
+
href="/account/migrate"
52
+
className="text-mana-100 underline hover:text-mana-200">
53
+
(string "migrate from another PDS")
54
+
</a>
49
55
(string ".")
50
56
</span>
51
57
</main>
+2053
pegasus/lib/api/account_/migrate.ml
+2053
pegasus/lib/api/account_/migrate.ml
···
1
+
type create_session_response = Server.CreateSession.response
2
+
[@@deriving yojson {strict= false}]
3
+
4
+
type get_session_response = Server.GetSession.response
5
+
[@@deriving yojson {strict= false}]
6
+
7
+
type refresh_session_response = Server.RefreshSession.response
8
+
[@@deriving yojson {strict= false}]
9
+
10
+
type service_auth_response = Server.GetServiceAuth.response
11
+
[@@deriving yojson {strict= false}]
12
+
13
+
type list_blobs_response = Repo.ListMissingBlobs.response
14
+
[@@deriving yojson {strict= false}]
15
+
16
+
type get_preferences_response = Proxy.AppBskyActorGetPreferences.response
17
+
[@@deriving yojson {strict= false}]
18
+
19
+
type sign_plc_operation_response = Identity.SignPlcOperation.response
20
+
[@@deriving yojson {strict= false}]
21
+
22
+
type check_account_status_response = Server.CheckAccountStatus.response
23
+
[@@deriving yojson {strict= false}]
24
+
25
+
type remote_credentials_response =
26
+
Identity.GetRecommendedDidCredentials.response
27
+
[@@deriving yojson {strict= false}]
28
+
29
+
let get_account_status = Server.CheckAccountStatus.get_account_status
30
+
31
+
let get_recommended_did_credentials =
32
+
Identity.GetRecommendedDidCredentials.get_credentials
33
+
34
+
open Cohttp_lwt
35
+
36
+
type migration_state =
37
+
{ did: string
38
+
; handle: string
39
+
; old_pds: string
40
+
; access_jwt: string
41
+
; refresh_jwt: string
42
+
; email: string
43
+
; blobs_imported: int
44
+
; blobs_failed: int
45
+
; blobs_cursor: string
46
+
; plc_requested: bool }
47
+
[@@deriving yojson]
48
+
49
+
let state_key = "pegasus.migration_state"
50
+
51
+
let get_migration_state req =
52
+
match Dream.session_field req state_key with
53
+
| Some json -> (
54
+
match migration_state_of_yojson (Yojson.Safe.from_string json) with
55
+
| Ok state ->
56
+
Some state
57
+
| Error _ ->
58
+
None )
59
+
| None ->
60
+
None
61
+
62
+
let set_migration_state req state =
63
+
Dream.set_session_field req state_key
64
+
(Yojson.Safe.to_string (migration_state_to_yojson state))
65
+
66
+
let clear_migration_state req = Dream.drop_session_field req state_key
67
+
68
+
let post_json ~uri ~headers ~body =
69
+
let headers = Http.Header.add headers "Content-Type" "application/json" in
70
+
Cohttp_lwt_unix.Client.post ~headers
71
+
~body:(Body.of_string (Yojson.Safe.to_string body))
72
+
uri
73
+
74
+
let post_empty ~uri ~headers =
75
+
Cohttp_lwt_unix.Client.post ~headers ~body:Body.empty uri
76
+
77
+
let resolve_identity identifier =
78
+
let%lwt did =
79
+
if String.starts_with ~prefix:"did:" identifier then
80
+
Lwt.return_ok identifier
81
+
else
82
+
match%lwt Id_resolver.Handle.resolve identifier with
83
+
| Ok did ->
84
+
Lwt.return_ok did
85
+
| Error e ->
86
+
Lwt.return_error ("Failed to resolve handle: " ^ e)
87
+
in
88
+
match did with
89
+
| Error e ->
90
+
Lwt.return_error e
91
+
| Ok did -> (
92
+
match%lwt Id_resolver.Did.resolve did with
93
+
| Error e ->
94
+
Lwt.return_error ("Failed to resolve DID document: " ^ e)
95
+
| Ok doc -> (
96
+
match Id_resolver.Did.Document.get_service doc "#atproto_pds" with
97
+
| None ->
98
+
Lwt.return_error "No PDS service found in DID document"
99
+
| Some pds_endpoint ->
100
+
(* Get handle from alsoKnownAs *)
101
+
let handle =
102
+
match doc.also_known_as with
103
+
| Some akas ->
104
+
List.find_map
105
+
(fun aka ->
106
+
if String.starts_with ~prefix:"at://" aka then
107
+
Some (String.sub aka 5 (String.length aka - 5))
108
+
else None )
109
+
akas
110
+
|> Option.value ~default:did
111
+
| None ->
112
+
did
113
+
in
114
+
Lwt.return_ok (did, handle, pds_endpoint) ) )
115
+
116
+
type auth_result =
117
+
| AuthSuccess of create_session_response
118
+
| AuthNeeds2FA
119
+
| AuthError of string
120
+
121
+
let create_session_on_pds ~pds_endpoint ~identifier ~password ?auth_factor_token
122
+
() =
123
+
let uri =
124
+
Uri.with_path
125
+
(Uri.of_string pds_endpoint)
126
+
"/xrpc/com.atproto.server.createSession"
127
+
in
128
+
let body =
129
+
let base =
130
+
[("identifier", `String identifier); ("password", `String password)]
131
+
in
132
+
match auth_factor_token with
133
+
| Some token ->
134
+
`Assoc (("authFactorToken", `String token) :: base)
135
+
| None ->
136
+
`Assoc base
137
+
in
138
+
let headers = Http.Header.init () in
139
+
try%lwt
140
+
let%lwt res, body = post_json ~uri ~headers ~body in
141
+
match res.status with
142
+
| `OK -> (
143
+
let%lwt body_str = Body.to_string body in
144
+
match
145
+
create_session_response_of_yojson (Yojson.Safe.from_string body_str)
146
+
with
147
+
| Ok session ->
148
+
Lwt.return (AuthSuccess session)
149
+
| Error e ->
150
+
Lwt.return (AuthError ("Invalid session response: " ^ e)) )
151
+
| `Unauthorized -> (
152
+
let%lwt body_str = Body.to_string body in
153
+
(* Check if 2FA is required *)
154
+
try
155
+
let json = Yojson.Safe.from_string body_str in
156
+
let open Yojson.Safe.Util in
157
+
let error = json |> member "error" |> to_string_option in
158
+
match error with
159
+
| Some "AuthFactorTokenRequired" ->
160
+
Lwt.return AuthNeeds2FA
161
+
| _ ->
162
+
Lwt.return (AuthError "Invalid credentials")
163
+
with _ -> Lwt.return (AuthError "Invalid credentials") )
164
+
| status ->
165
+
let%lwt body_str = Body.to_string body in
166
+
Lwt.return
167
+
(AuthError
168
+
(Printf.sprintf "Authentication failed (%s): %s"
169
+
(Http.Status.to_string status)
170
+
body_str ) )
171
+
with exn ->
172
+
Lwt.return (AuthError ("Network error: " ^ Printexc.to_string exn))
173
+
174
+
let get_session ~pds_endpoint ~access_jwt =
175
+
let uri =
176
+
Uri.with_path
177
+
(Uri.of_string pds_endpoint)
178
+
"/xrpc/com.atproto.server.getSession"
179
+
in
180
+
let headers =
181
+
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
182
+
in
183
+
try%lwt
184
+
let%lwt res, body = Util.http_get uri ~headers in
185
+
match res.status with
186
+
| `OK -> (
187
+
let%lwt body_str = Body.to_string body in
188
+
match
189
+
get_session_response_of_yojson (Yojson.Safe.from_string body_str)
190
+
with
191
+
| Ok session ->
192
+
Lwt.return_ok session
193
+
| Error e ->
194
+
Lwt.return_error ("Invalid session response: " ^ e) )
195
+
| status ->
196
+
let%lwt body_str = Body.to_string body in
197
+
Lwt.return_error
198
+
(Printf.sprintf "Failed to get session info (%s): %s"
199
+
(Http.Status.to_string status)
200
+
body_str )
201
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
202
+
203
+
(* check if jwt is expired or will expire within delta_s *)
204
+
let jwt_needs_refresh ?(delta_s = 60) access_jwt =
205
+
match Jwt.decode_jwt access_jwt with
206
+
| Error _ ->
207
+
true (* if we can't decode, assume we need refresh *)
208
+
| Ok (_header, payload) -> (
209
+
try
210
+
let open Yojson.Safe.Util in
211
+
let exp = payload |> member "exp" |> to_int in
212
+
let now = int_of_float (Unix.gettimeofday ()) in
213
+
exp - now < delta_s
214
+
with _ -> true )
215
+
216
+
let refresh_session ~pds_endpoint ~refresh_jwt =
217
+
let uri =
218
+
Uri.with_path
219
+
(Uri.of_string pds_endpoint)
220
+
"/xrpc/com.atproto.server.refreshSession"
221
+
in
222
+
let headers =
223
+
Http.Header.of_list [("Authorization", "Bearer " ^ refresh_jwt)]
224
+
in
225
+
try%lwt
226
+
let%lwt res, body = post_empty ~uri ~headers in
227
+
match res.status with
228
+
| `OK -> (
229
+
let%lwt body_str = Body.to_string body in
230
+
match
231
+
refresh_session_response_of_yojson (Yojson.Safe.from_string body_str)
232
+
with
233
+
| Ok tokens ->
234
+
Lwt.return_ok tokens
235
+
| Error e ->
236
+
Lwt.return_error ("Invalid refresh response: " ^ e) )
237
+
| status ->
238
+
let%lwt body_str = Body.to_string body in
239
+
Lwt.return_error
240
+
(Printf.sprintf "Failed to refresh session (%s): %s"
241
+
(Http.Status.to_string status)
242
+
body_str )
243
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
244
+
245
+
let get_service_auth ~pds_endpoint ~access_jwt =
246
+
let uri =
247
+
Uri.with_path
248
+
(Uri.of_string pds_endpoint)
249
+
"/xrpc/com.atproto.server.getServiceAuth"
250
+
|> fun u ->
251
+
Uri.add_query_params' u
252
+
[ ("aud", Env.did)
253
+
; ("lxm", "com.atproto.server.createAccount")
254
+
; ("exp", string_of_int (int_of_float (Unix.gettimeofday ()) + 300)) ]
255
+
in
256
+
let headers =
257
+
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
258
+
in
259
+
try%lwt
260
+
let%lwt res, body = Util.http_get uri ~headers in
261
+
match res.status with
262
+
| `OK -> (
263
+
let%lwt body_str = Body.to_string body in
264
+
match
265
+
service_auth_response_of_yojson (Yojson.Safe.from_string body_str)
266
+
with
267
+
| Ok {token} ->
268
+
Lwt.return_ok token
269
+
| Error e ->
270
+
Lwt.return_error ("Invalid service auth response: " ^ e) )
271
+
| status ->
272
+
let%lwt body_str = Body.to_string body in
273
+
Lwt.return_error
274
+
(Printf.sprintf "Failed to get service auth (%s): %s"
275
+
(Http.Status.to_string status)
276
+
body_str )
277
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
278
+
279
+
(* get credentials from old pds so we can remove the pds rotation key *)
280
+
let get_remote_recommended_credentials ~pds_endpoint ~access_jwt =
281
+
let uri =
282
+
Uri.with_path
283
+
(Uri.of_string pds_endpoint)
284
+
"/xrpc/com.atproto.identity.getRecommendedDidCredentials"
285
+
in
286
+
let headers =
287
+
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
288
+
in
289
+
try%lwt
290
+
let%lwt res, body = Cohttp_lwt_unix.Client.get ~headers uri in
291
+
match res.status with
292
+
| `OK -> (
293
+
let%lwt body_str = Body.to_string body in
294
+
match
295
+
remote_credentials_response_of_yojson
296
+
(Yojson.Safe.from_string body_str)
297
+
with
298
+
| Ok creds ->
299
+
Lwt.return_ok creds
300
+
| Error e ->
301
+
Lwt.return_error ("Invalid credentials response: " ^ e) )
302
+
| status ->
303
+
let%lwt body_str = Body.to_string body in
304
+
Lwt.return_error
305
+
(Printf.sprintf "Failed to get remote credentials (%s): %s"
306
+
(Http.Status.to_string status)
307
+
body_str )
308
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
309
+
310
+
(* list current rotation keys from plc directory audit log *)
311
+
let get_plc_rotation_keys ~did =
312
+
if not (String.starts_with ~prefix:"did:plc:" did) then Lwt.return_ok []
313
+
else
314
+
let uri =
315
+
Uri.make ~scheme:"https" ~host:"plc.directory" ~path:(did ^ "/log/last")
316
+
()
317
+
in
318
+
try%lwt
319
+
let%lwt res, body =
320
+
Cohttp_lwt_unix.Client.get
321
+
~headers:(Http.Header.of_list [("Accept", "application/json")])
322
+
uri
323
+
in
324
+
match res.status with
325
+
| `OK -> (
326
+
let%lwt body_str = Body.to_string body in
327
+
try
328
+
let json = Yojson.Safe.from_string body_str in
329
+
let open Yojson.Safe.Util in
330
+
let rotation_keys =
331
+
json |> member "rotationKeys" |> to_list |> List.map to_string
332
+
in
333
+
Lwt.return_ok rotation_keys
334
+
with _ -> Lwt.return_ok [] )
335
+
| _ ->
336
+
let%lwt () = Body.drain_body body in
337
+
Lwt.return_ok []
338
+
with _ -> Lwt.return_ok []
339
+
340
+
let request_plc_operation_signature ~pds_endpoint ~access_jwt =
341
+
let uri =
342
+
Uri.with_path
343
+
(Uri.of_string pds_endpoint)
344
+
"/xrpc/com.atproto.identity.requestPlcOperationSignature"
345
+
in
346
+
let headers =
347
+
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
348
+
in
349
+
try%lwt
350
+
let%lwt res, body = post_empty ~uri ~headers in
351
+
match res.status with
352
+
| `OK ->
353
+
let%lwt () = Body.drain_body body in
354
+
Lwt.return_ok ()
355
+
| status ->
356
+
let%lwt body_str = Body.to_string body in
357
+
Lwt.return_error
358
+
(Printf.sprintf "Failed to request PLC signature (%s): %s"
359
+
(Http.Status.to_string status)
360
+
body_str )
361
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
362
+
363
+
let sign_plc_operation ~pds_endpoint ~access_jwt ~token
364
+
~(credentials : Plc.credentials) =
365
+
let uri =
366
+
Uri.with_path
367
+
(Uri.of_string pds_endpoint)
368
+
"/xrpc/com.atproto.identity.signPlcOperation"
369
+
in
370
+
let headers =
371
+
Http.Header.of_list
372
+
[ ("Authorization", "Bearer " ^ access_jwt)
373
+
; ("Content-Type", "application/json") ]
374
+
in
375
+
let body =
376
+
`Assoc
377
+
[ ("token", `String token)
378
+
; ( "rotationKeys"
379
+
, `List (List.map (fun s -> `String s) credentials.rotation_keys) )
380
+
; ( "verificationMethods"
381
+
, `Assoc
382
+
(List.map
383
+
(fun (k, v) -> (k, `String v))
384
+
credentials.verification_methods ) )
385
+
; ( "alsoKnownAs"
386
+
, `List (List.map (fun s -> `String s) credentials.also_known_as) )
387
+
; ("services", Plc.service_map_to_yojson credentials.services) ]
388
+
in
389
+
try%lwt
390
+
let%lwt res, body =
391
+
Cohttp_lwt_unix.Client.post ~headers
392
+
~body:(Body.of_string (Yojson.Safe.to_string body))
393
+
uri
394
+
in
395
+
match res.status with
396
+
| `OK -> (
397
+
let%lwt body_str = Body.to_string body in
398
+
match
399
+
sign_plc_operation_response_of_yojson
400
+
(Yojson.Safe.from_string body_str)
401
+
with
402
+
| Ok resp ->
403
+
Lwt.return_ok resp.operation
404
+
| Error e ->
405
+
Lwt.return_error ("Invalid sign operation response: " ^ e) )
406
+
| status ->
407
+
let%lwt body_str = Body.to_string body in
408
+
Lwt.return_error
409
+
(Printf.sprintf "Failed to sign PLC operation (%s): %s"
410
+
(Http.Status.to_string status)
411
+
body_str )
412
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
413
+
414
+
let submit_plc_operation ~did ~handle ~(operation : Plc.signed_operation) db =
415
+
match operation with
416
+
| Tombstone _ ->
417
+
Lwt.return_error "Cannot submit tombstone operation during migration"
418
+
| Operation op -> (
419
+
match Plc.validate_operation ~handle (Operation op) with
420
+
| Ok () -> (
421
+
match%lwt Plc.submit_operation did operation with
422
+
| Ok () ->
423
+
let%lwt _ = Sequencer.sequence_identity db ~did () in
424
+
let%lwt _ = Id_resolver.Did.resolve ~skip_cache:true did in
425
+
Lwt.return_ok ()
426
+
| Error (status, msg) ->
427
+
Lwt.return_error
428
+
(Printf.sprintf "PLC submission failed (%d): %s" status msg) )
429
+
| Error e ->
430
+
Lwt.return_error e )
431
+
432
+
let fetch_repo ~pds_endpoint ~access_jwt ~did =
433
+
let uri =
434
+
Uri.with_path (Uri.of_string pds_endpoint) "/xrpc/com.atproto.sync.getRepo"
435
+
|> fun u -> Uri.add_query_param' u ("did", did)
436
+
in
437
+
let headers =
438
+
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
439
+
in
440
+
try%lwt
441
+
let%lwt res, body = Util.http_get uri ~headers in
442
+
match res.status with
443
+
| `OK ->
444
+
let%lwt body_bytes = Body.to_string body in
445
+
Lwt.return_ok (Bytes.of_string body_bytes)
446
+
| status ->
447
+
let%lwt () = Body.drain_body body in
448
+
Lwt.return_error
449
+
(Printf.sprintf "Failed to fetch repo (%s)"
450
+
(Http.Status.to_string status) )
451
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
452
+
453
+
let list_blobs ~pds_endpoint ~access_jwt ~did ?cursor () =
454
+
let uri =
455
+
Uri.with_path
456
+
(Uri.of_string pds_endpoint)
457
+
"/xrpc/com.atproto.sync.listBlobs"
458
+
|> fun u ->
459
+
Uri.add_query_param' u ("did", did)
460
+
|> fun u ->
461
+
match cursor with
462
+
| Some c ->
463
+
Uri.add_query_param' u ("cursor", c)
464
+
| None ->
465
+
u
466
+
in
467
+
let headers =
468
+
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
469
+
in
470
+
try%lwt
471
+
let%lwt res, body = Util.http_get uri ~headers in
472
+
match res.status with
473
+
| `OK -> (
474
+
let%lwt body_str = Body.to_string body in
475
+
match
476
+
list_blobs_response_of_yojson (Yojson.Safe.from_string body_str)
477
+
with
478
+
| Ok resp ->
479
+
Lwt.return_ok resp
480
+
| Error e ->
481
+
Lwt.return_error ("Invalid list blobs response: " ^ e) )
482
+
| status ->
483
+
let%lwt () = Body.drain_body body in
484
+
Lwt.return_error
485
+
(Printf.sprintf "Failed to list blobs (%s)"
486
+
(Http.Status.to_string status) )
487
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
488
+
489
+
let fetch_blob ~pds_endpoint ~access_jwt ~did ~cid =
490
+
let uri =
491
+
Uri.with_path (Uri.of_string pds_endpoint) "/xrpc/com.atproto.sync.getBlob"
492
+
|> fun u -> Uri.add_query_params' u [("did", did); ("cid", cid)]
493
+
in
494
+
let headers =
495
+
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
496
+
in
497
+
try%lwt
498
+
let%lwt res, body = Util.http_get uri ~headers in
499
+
match res.status with
500
+
| `OK ->
501
+
let content_type =
502
+
Http.Header.get res.headers "Content-Type"
503
+
|> Option.value ~default:"application/octet-stream"
504
+
in
505
+
let%lwt body_bytes = Body.to_string body in
506
+
Lwt.return_ok (content_type, Bytes.of_string body_bytes)
507
+
| status ->
508
+
let%lwt () = Body.drain_body body in
509
+
Lwt.return_error
510
+
(Printf.sprintf "Failed to fetch blob %s (%s)" cid
511
+
(Http.Status.to_string status) )
512
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
513
+
514
+
let fetch_preferences ~pds_endpoint ~access_jwt =
515
+
let uri =
516
+
Uri.with_path
517
+
(Uri.of_string pds_endpoint)
518
+
"/xrpc/app.bsky.actor.getPreferences"
519
+
in
520
+
let headers =
521
+
Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)]
522
+
in
523
+
try%lwt
524
+
let%lwt res, body = Util.http_get uri ~headers in
525
+
match res.status with
526
+
| `OK -> (
527
+
let%lwt body_str = Body.to_string body in
528
+
match
529
+
get_preferences_response_of_yojson (Yojson.Safe.from_string body_str)
530
+
with
531
+
| Ok resp ->
532
+
Lwt.return_ok resp.preferences
533
+
| Error e ->
534
+
Dream.warning (fun log ->
535
+
log "migration: failed to parse preferences response: %s" e ) ;
536
+
Lwt.return_ok (`List []) )
537
+
| status ->
538
+
let%lwt () = Body.drain_body body in
539
+
Dream.warning (fun log ->
540
+
log "migration: failed to fetch preferences: %s"
541
+
(Http.Status.to_string status) ) ;
542
+
Lwt.return_ok (`List [])
543
+
with exn ->
544
+
Dream.warning (fun log ->
545
+
log "migration: exception fetching preferences: %s"
546
+
(Printexc.to_string exn) ) ;
547
+
Lwt.return_ok (`List [])
548
+
549
+
(* create account on this pds with existing did *)
550
+
let create_migrated_account ~email ~handle ~password ~did ~service_auth_token
551
+
?invite_code db =
552
+
let open Lwt.Infix in
553
+
(* ensure service auth token is signed by the did we're migrating *)
554
+
let%lwt verified =
555
+
match%lwt
556
+
Jwt.verify_service_jwt ~nsid:"com.atproto.server.createAccount"
557
+
~verify_sig:(fun _did pk ->
558
+
Lwt.return
559
+
@@ Jwt.verify_jwt service_auth_token
560
+
~pubkey:(Kleidos.parse_multikey_str pk) )
561
+
service_auth_token
562
+
with
563
+
| Ok creds ->
564
+
Lwt.return_ok creds
565
+
| Error (AuthRequired e) ->
566
+
Lwt.return_error @@ Errors.auth_required e
567
+
| Error (ExpiredToken e) ->
568
+
Lwt.return_error @@ Errors.invalid_request ~name:"ExpiredToken" e
569
+
| Error (InvalidToken e) ->
570
+
Lwt.return_error @@ Errors.invalid_request ~name:"InvalidToken" e
571
+
| Error (InternalError e) ->
572
+
Lwt.return_error @@ Errors.internal_error ~msg:e ()
573
+
in
574
+
match verified with
575
+
| Error e ->
576
+
Lwt.return_error e
577
+
| Ok _ -> (
578
+
(* check if did already exists *)
579
+
match%lwt
580
+
Data_store.get_actor_by_identifier did db
581
+
with
582
+
| Some existing when existing.deactivated_at <> None ->
583
+
(* account exists but is deactivated, resumable migration *)
584
+
Lwt.return_error
585
+
"RESUMABLE: An incomplete migration exists for this account."
586
+
| Some _ ->
587
+
Lwt.return_error
588
+
"An account with this DID already exists on this PDS. If you \
589
+
previously migrated here, try logging in instead."
590
+
| None -> (
591
+
(* check if handle is available (may need different handle) *)
592
+
match%lwt
593
+
Data_store.get_actor_by_identifier handle db
594
+
with
595
+
| Some _ ->
596
+
Lwt.return_error
597
+
( "The handle @" ^ handle
598
+
^ " is already taken on this PDS. You may need to use a different \
599
+
handle." )
600
+
| None -> (
601
+
(* check if email is available *)
602
+
match%lwt
603
+
Data_store.get_actor_by_identifier email db
604
+
with
605
+
| Some _ ->
606
+
Lwt.return_error "An account with this email already exists"
607
+
| None -> (
608
+
(* validate invite code if required *)
609
+
( match
610
+
( Env.invite_required
611
+
, invite_code
612
+
, Option.bind invite_code (fun c ->
613
+
if String.length c = 0 then None else Some c ) )
614
+
with
615
+
| true, None, _ | true, _, None ->
616
+
Lwt.return_error "An invite code is required"
617
+
| true, Some code, _ -> (
618
+
match%lwt Data_store.get_invite ~code db with
619
+
| Some i when i.remaining > 0 -> (
620
+
match%lwt Data_store.use_invite ~code db with
621
+
| Some _ ->
622
+
Lwt.return_ok ()
623
+
| None ->
624
+
Lwt.return_error "Failed to use invite code" )
625
+
| _ ->
626
+
Lwt.return_error "Invalid invite code" )
627
+
| false, _, _ ->
628
+
Lwt.return_ok () )
629
+
>>= function
630
+
| Error e ->
631
+
Lwt.return_error e
632
+
| Ok () ->
633
+
(* generate new signing key *)
634
+
let signing_key, signing_pubkey =
635
+
Kleidos.K256.generate_keypair ()
636
+
in
637
+
let sk_priv_mk = Kleidos.K256.privkey_to_multikey signing_key in
638
+
(* create deactivated actor *)
639
+
let%lwt () =
640
+
Data_store.create_actor ~did ~handle ~email ~password
641
+
~signing_key:sk_priv_mk db
642
+
in
643
+
let%lwt () = Data_store.deactivate_actor did db in
644
+
let () =
645
+
Util.mkfile_p
646
+
(Util.Constants.user_db_filepath did)
647
+
~perm:0o644
648
+
in
649
+
let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in
650
+
let%lwt _ =
651
+
Sequencer.sequence_account db ~did ~active:false
652
+
~status:`Deactivated ()
653
+
in
654
+
Lwt.return_ok (Kleidos.K256.pubkey_to_did_key signing_pubkey) )
655
+
) ) )
656
+
657
+
let bytes_to_car_stream (data : bytes) : Car.stream =
658
+
fun () -> Lwt.return (Lwt_seq.Cons (data, fun () -> Lwt.return Lwt_seq.Nil))
659
+
660
+
let import_repo ~did ~car_data =
661
+
try%lwt
662
+
let%lwt repo = Repository.load ~create:true did in
663
+
let stream = bytes_to_car_stream car_data in
664
+
match%lwt Repository.import_car repo stream with
665
+
| Ok _ ->
666
+
Lwt.return_ok ()
667
+
| Error e ->
668
+
Lwt.return_error ("Failed to import repository: " ^ Printexc.to_string e)
669
+
with exn ->
670
+
Lwt.return_error ("Failed to import repository: " ^ Printexc.to_string exn)
671
+
672
+
(* import blobs in batches *)
673
+
let import_blobs_batch ~pds_endpoint ~access_jwt ~did ~cids =
674
+
let%lwt user_db = User_store.connect ~create:true did in
675
+
let%lwt results =
676
+
Lwt_list.map_p
677
+
(fun cid_str ->
678
+
match%lwt fetch_blob ~pds_endpoint ~access_jwt ~did ~cid:cid_str with
679
+
| Error e ->
680
+
Dream.warning (fun log ->
681
+
log "migration %s: failed to fetch blob %s: %s" did cid_str e ) ;
682
+
Lwt.return_error cid_str
683
+
| Ok (mimetype, data) -> (
684
+
match Cid.of_string cid_str with
685
+
| Error _ ->
686
+
Lwt.return_error cid_str
687
+
| Ok cid ->
688
+
let%lwt _ = User_store.put_blob user_db cid mimetype data in
689
+
Lwt.return_ok cid_str ) )
690
+
cids
691
+
in
692
+
let imported =
693
+
List.filter (function Ok _ -> true | Error _ -> false) results
694
+
|> List.length
695
+
in
696
+
let failed =
697
+
List.filter (function Error _ -> true | Ok _ -> false) results
698
+
|> List.length
699
+
in
700
+
Lwt.return (imported, failed)
701
+
702
+
(* remove trailing slash from pds endpoint *)
703
+
let normalize_endpoint s =
704
+
if String.length s > 0 && s.[String.length s - 1] = '/' then
705
+
String.sub s 0 (String.length s - 1)
706
+
else s
707
+
708
+
(* check if plc identity has been updated to point to this pds *)
709
+
let check_identity_updated did =
710
+
match%lwt Id_resolver.Did.resolve ~skip_cache:true did with
711
+
| Error e ->
712
+
Lwt.return_error ("Failed to resolve DID: " ^ e)
713
+
| Ok doc -> (
714
+
match Id_resolver.Did.Document.get_service doc "#atproto_pds" with
715
+
| None ->
716
+
Lwt.return_error "DID document missing PDS service"
717
+
| Some endpoint ->
718
+
let normalized_endpoint = normalize_endpoint endpoint in
719
+
let normalized_host = normalize_endpoint Env.host_endpoint in
720
+
if normalized_endpoint = normalized_host then Lwt.return_ok true
721
+
else Lwt.return_ok false )
722
+
723
+
let check_local_account_status ~did =
724
+
try%lwt
725
+
match%lwt get_account_status did with
726
+
| Ok status ->
727
+
Lwt.return_ok status
728
+
| _ ->
729
+
Lwt.return_error "Failed to load account data"
730
+
with exn ->
731
+
Lwt.return_error
732
+
("Failed to check account status: " ^ Printexc.to_string exn)
733
+
734
+
let list_local_missing_blobs ~did ~limit ?cursor () =
735
+
try%lwt
736
+
let%lwt {db= us; _} = Repository.load did in
737
+
let cursor = Option.value ~default:"" cursor in
738
+
let%lwt blobs = User_store.list_missing_blobs ~limit ~cursor us in
739
+
let cids = List.map (fun (_, cid) -> Cid.to_string cid) blobs in
740
+
(* done if we get fewer blobs than limit *)
741
+
let next_cursor =
742
+
if List.length blobs >= limit then List.nth_opt cids (List.length cids - 1)
743
+
else None
744
+
in
745
+
Lwt.return_ok (cids, next_cursor)
746
+
with exn ->
747
+
Lwt.return_error ("Failed to list missing blobs: " ^ Printexc.to_string exn)
748
+
749
+
let activate_account did db =
750
+
let%lwt () = Data_store.activate_actor did db in
751
+
let%lwt _ =
752
+
Sequencer.sequence_account db ~did ~active:true ~status:`Active ()
753
+
in
754
+
Lwt.return_unit
755
+
756
+
(* deactivate account on old pds after successful migration *)
757
+
let deactivate_old_account ~pds_endpoint ~access_jwt =
758
+
let uri =
759
+
Uri.with_path
760
+
(Uri.of_string pds_endpoint)
761
+
"/xrpc/com.atproto.server.deactivateAccount"
762
+
in
763
+
let headers =
764
+
Http.Header.of_list
765
+
[ ("Authorization", "Bearer " ^ access_jwt)
766
+
; ("Content-Type", "application/json") ]
767
+
in
768
+
try%lwt
769
+
let%lwt res, body =
770
+
Cohttp_lwt_unix.Client.post ~headers ~body:(Body.of_string "{}") uri
771
+
in
772
+
match res.status with
773
+
| `OK ->
774
+
let%lwt () = Body.drain_body body in
775
+
Lwt.return_ok ()
776
+
| status ->
777
+
let%lwt body_str = Body.to_string body in
778
+
Lwt.return_error
779
+
(Printf.sprintf "Failed to deactivate old account (%s): %s"
780
+
(Http.Status.to_string status)
781
+
body_str )
782
+
with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn)
783
+
784
+
(* possible states for an existing deactivated account for resumption *)
785
+
type resume_state =
786
+
| NeedsRepoImport (* account exists but no repo *)
787
+
| NeedsBlobImport (* repo exists, may need blobs *)
788
+
| NeedsPlcUpdate (* data imported, needs plc update *)
789
+
| NeedsActivation (* plc points here, just needs activation *)
790
+
| AlreadyActive (* account is already active *)
791
+
792
+
let check_resume_state ~did db =
793
+
match%lwt Data_store.get_actor_by_identifier did db with
794
+
| None ->
795
+
Lwt.return_error "Account not found"
796
+
| Some actor when actor.deactivated_at = None ->
797
+
Lwt.return_ok AlreadyActive
798
+
| Some _actor -> (
799
+
(* account is deactivated, check if identity already points here *)
800
+
match%lwt
801
+
check_identity_updated did
802
+
with
803
+
| Ok true ->
804
+
(* just needs activation *)
805
+
Lwt.return_ok NeedsActivation
806
+
| _ -> (
807
+
(* check if repo exists; error probably means it doesn't *)
808
+
try%lwt
809
+
let%lwt us = User_store.connect ~create:false did in
810
+
let%lwt record_count = User_store.count_records us in
811
+
if record_count > 0 then
812
+
(* repo exists, check if we need blob import *)
813
+
match%lwt User_store.count_blobs us with
814
+
| cnt when cnt > 0 ->
815
+
(* data imported, needs plc update *)
816
+
Lwt.return_ok NeedsPlcUpdate
817
+
| _ ->
818
+
(* no blobs, need to start from blob import *)
819
+
Lwt.return_ok NeedsBlobImport
820
+
else
821
+
(* no repo, need to start from repo import *)
822
+
Lwt.return_ok NeedsRepoImport
823
+
with _ -> Lwt.return_ok NeedsRepoImport ) )
824
+
825
+
let get_handler =
826
+
Xrpc.handler (fun ctx ->
827
+
let csrf_token = Dream.csrf_token ctx.req in
828
+
let invite_required = Env.invite_required in
829
+
let hostname = Env.hostname in
830
+
(* check for existing migration state *)
831
+
let props : Frontend.MigratePage.props =
832
+
match get_migration_state ctx.req with
833
+
| None ->
834
+
{ csrf_token
835
+
; invite_required
836
+
; hostname
837
+
; step= "enter_credentials"
838
+
; did= None
839
+
; handle= None
840
+
; old_pds= None
841
+
; identifier= None
842
+
; invite_code= None
843
+
; blobs_imported= 0
844
+
; blobs_failed= 0
845
+
; old_account_deactivated= false
846
+
; old_account_deactivation_error= None
847
+
; error= None
848
+
; message= None }
849
+
| Some state ->
850
+
if state.plc_requested then
851
+
{ csrf_token
852
+
; invite_required
853
+
; hostname
854
+
; step= "enter_plc_token"
855
+
; did= Some state.did
856
+
; handle= Some state.handle
857
+
; old_pds= Some state.old_pds
858
+
; identifier= None
859
+
; invite_code= None
860
+
; blobs_imported= state.blobs_imported
861
+
; blobs_failed= state.blobs_failed
862
+
; old_account_deactivated= false
863
+
; old_account_deactivation_error= None
864
+
; error= None
865
+
; message= None }
866
+
else
867
+
{ csrf_token
868
+
; invite_required
869
+
; hostname
870
+
; step= "importing_data"
871
+
; did= Some state.did
872
+
; handle= Some state.handle
873
+
; old_pds= Some state.old_pds
874
+
; identifier= None
875
+
; invite_code= None
876
+
; blobs_imported= state.blobs_imported
877
+
; blobs_failed= state.blobs_failed
878
+
; old_account_deactivated= false
879
+
; old_account_deactivation_error= None
880
+
; error= None
881
+
; message= None }
882
+
in
883
+
Util.render_html ~title:"Migrate Account"
884
+
(module Frontend.MigratePage)
885
+
~props )
886
+
887
+
let post_handler =
888
+
Xrpc.handler (fun ctx ->
889
+
let csrf_token = Dream.csrf_token ctx.req in
890
+
let invite_required = Env.invite_required in
891
+
let hostname = Env.hostname in
892
+
let make_props ?(step = "enter_credentials") ?did ?handle ?old_pds
893
+
?identifier ?invite_code ?(blobs_imported = 0) ?(blobs_failed = 0)
894
+
?(old_account_deactivated = false) ?old_account_deactivation_error
895
+
?error ?message () : Frontend.MigratePage.props =
896
+
{ csrf_token
897
+
; invite_required
898
+
; hostname
899
+
; step
900
+
; did
901
+
; handle
902
+
; old_pds
903
+
; identifier
904
+
; invite_code
905
+
; blobs_imported
906
+
; blobs_failed
907
+
; old_account_deactivated
908
+
; old_account_deactivation_error
909
+
; error
910
+
; message }
911
+
in
912
+
let render_error ?(step = "enter_credentials") ?did ?handle ?old_pds
913
+
?identifier ?invite_code error =
914
+
Util.render_html ~status:`Bad_Request ~title:"Migrate Account"
915
+
(module Frontend.MigratePage)
916
+
~props:
917
+
(make_props ~step ?did ?handle ?old_pds ?identifier ?invite_code
918
+
~error () )
919
+
in
920
+
(* helper to transition to PLC token step after data import *)
921
+
let transition_to_plc_token_step ~did ~handle ~old_pds ~access_jwt
922
+
~refresh_jwt ~email ~blobs_imported ~blobs_failed =
923
+
(* import preferences before transitioning *)
924
+
let%lwt () =
925
+
match%lwt fetch_preferences ~pds_endpoint:old_pds ~access_jwt with
926
+
| Ok prefs ->
927
+
Data_store.put_preferences ~did ~prefs ctx.db
928
+
| _ ->
929
+
Lwt.return_unit
930
+
in
931
+
(* don't need plc step for did:web *)
932
+
if String.starts_with ~prefix:"did:web:" did then
933
+
(* check if identity already points here *)
934
+
match%lwt check_identity_updated did with
935
+
| Ok true ->
936
+
(* identity already points here, activate directly *)
937
+
let%lwt () = activate_account did ctx.db in
938
+
let%lwt () = Session.log_in_did ctx.req did in
939
+
let%lwt deactivation_result =
940
+
deactivate_old_account ~pds_endpoint:old_pds ~access_jwt
941
+
in
942
+
let old_account_deactivated, old_account_deactivation_error =
943
+
match deactivation_result with
944
+
| Ok () ->
945
+
(true, None)
946
+
| Error e ->
947
+
Dream.warning (fun log ->
948
+
log "migration %s: failed to deactivate old account: %s"
949
+
did e ) ;
950
+
(false, Some e)
951
+
in
952
+
Util.render_html ~title:"Migrate Account"
953
+
(module Frontend.MigratePage)
954
+
~props:
955
+
(make_props ~step:"complete" ~did ~handle ~blobs_imported
956
+
~blobs_failed ~old_account_deactivated
957
+
?old_account_deactivation_error
958
+
~message:
959
+
"Your account has been successfully migrated! Your \
960
+
did:web identity is pointing to this PDS."
961
+
() )
962
+
| _ ->
963
+
(* identity not updated yet - show instructions *)
964
+
Util.render_html ~title:"Migrate Account"
965
+
(module Frontend.MigratePage)
966
+
~props:
967
+
(make_props ~step:"error" ~did ~handle ~blobs_imported
968
+
~blobs_failed
969
+
~error:
970
+
(Printf.sprintf
971
+
"Your account uses did:web which requires manual \
972
+
configuration. Please update your \
973
+
.well-known/did.json at %s to point to this PDS \
974
+
(%s), then try resuming the migration."
975
+
(String.sub did 8 (String.length did - 8))
976
+
Env.host_endpoint )
977
+
() )
978
+
else
979
+
(* did:plc, regular flow *)
980
+
match%lwt
981
+
request_plc_operation_signature ~pds_endpoint:old_pds ~access_jwt
982
+
with
983
+
| Error e ->
984
+
Dream.warning (fun log ->
985
+
log "migration %s: failed to request PLC signature: %s" did e ) ;
986
+
(* still show the token step, user may have received email already *)
987
+
let%lwt () =
988
+
set_migration_state ctx.req
989
+
{ did
990
+
; handle
991
+
; old_pds
992
+
; access_jwt
993
+
; refresh_jwt
994
+
; email
995
+
; blobs_imported
996
+
; blobs_failed
997
+
; blobs_cursor= ""
998
+
; plc_requested= true }
999
+
in
1000
+
Util.render_html ~title:"Migrate Account"
1001
+
(module Frontend.MigratePage)
1002
+
~props:
1003
+
(make_props ~step:"enter_plc_token" ~did ~handle ~old_pds
1004
+
~blobs_imported ~blobs_failed
1005
+
~message:
1006
+
"Data import complete! Check your email for a PLC \
1007
+
confirmation code."
1008
+
~error:
1009
+
( "Note: Could not automatically request PLC signature: "
1010
+
^ e
1011
+
^ ". You may need to request it manually from your old \
1012
+
PDS." )
1013
+
() )
1014
+
| Ok () ->
1015
+
let%lwt () =
1016
+
set_migration_state ctx.req
1017
+
{ did
1018
+
; handle
1019
+
; old_pds
1020
+
; access_jwt
1021
+
; refresh_jwt
1022
+
; email
1023
+
; blobs_imported
1024
+
; blobs_failed
1025
+
; blobs_cursor= ""
1026
+
; plc_requested= true }
1027
+
in
1028
+
Util.render_html ~title:"Migrate Account"
1029
+
(module Frontend.MigratePage)
1030
+
~props:
1031
+
(make_props ~step:"enter_plc_token" ~did ~handle ~old_pds
1032
+
~blobs_imported ~blobs_failed
1033
+
~message:
1034
+
"Data import complete! Check your email for a PLC \
1035
+
confirmation code."
1036
+
() )
1037
+
in
1038
+
match%lwt Dream.form ctx.req with
1039
+
| `Ok fields -> (
1040
+
let action =
1041
+
List.assoc_opt "action" fields |> Option.value ~default:""
1042
+
in
1043
+
match action with
1044
+
| "start_migration" -> (
1045
+
let identifier =
1046
+
List.assoc_opt "identifier" fields
1047
+
|> Option.value ~default:"" |> String.trim
1048
+
in
1049
+
let password =
1050
+
List.assoc_opt "password" fields |> Option.value ~default:""
1051
+
in
1052
+
let invite_code =
1053
+
List.assoc_opt "invite_code" fields
1054
+
|> Option.map String.trim
1055
+
|> fun c ->
1056
+
Option.bind c (fun s ->
1057
+
if String.length s = 0 then None else Some s )
1058
+
in
1059
+
(* for jumping to specific steps while debugging *)
1060
+
let debug_step =
1061
+
match invite_code with
1062
+
| Some "DEBUG:RESUME" ->
1063
+
Some "resume_available"
1064
+
| Some "DEBUG:IMPORT" ->
1065
+
Some "importing_data"
1066
+
| Some "DEBUG:PLC" ->
1067
+
Some "enter_plc_token"
1068
+
| Some "DEBUG:COMPLETE" ->
1069
+
Some "complete"
1070
+
| Some "DEBUG:COMPLETE_FAIL" ->
1071
+
Some "complete_deactivation_failed"
1072
+
| Some "DEBUG:ERROR" ->
1073
+
Some "error"
1074
+
| _ ->
1075
+
None
1076
+
in
1077
+
match debug_step with
1078
+
| Some "resume_available" ->
1079
+
Util.render_html ~title:"Migrate Account"
1080
+
(module Frontend.MigratePage)
1081
+
~props:
1082
+
(make_props ~step:"resume_available" ~did:"did:plc:a1b2c3"
1083
+
~handle:"test.user" ~old_pds:"https://bsky.social" () )
1084
+
| Some "importing_data" ->
1085
+
let%lwt () =
1086
+
set_migration_state ctx.req
1087
+
{ did= "did:plc:a1b2c3"
1088
+
; handle= "test.user"
1089
+
; old_pds= "https://bsky.social"
1090
+
; access_jwt= "test_access_jwt"
1091
+
; refresh_jwt= "test_refresh_jwt"
1092
+
; email= "test@example.com"
1093
+
; blobs_imported= 42
1094
+
; blobs_failed= 3
1095
+
; blobs_cursor= ""
1096
+
; plc_requested= false }
1097
+
in
1098
+
Util.render_html ~title:"Migrate Account"
1099
+
(module Frontend.MigratePage)
1100
+
~props:
1101
+
(make_props ~step:"importing_data" ~did:"did:plc:a1b2c3"
1102
+
~handle:"test.user" ~old_pds:"https://bsky.social"
1103
+
~blobs_imported:42 ~blobs_failed:3 () )
1104
+
| Some "enter_plc_token" ->
1105
+
let%lwt () =
1106
+
set_migration_state ctx.req
1107
+
{ did= "did:plc:a1b2c3"
1108
+
; handle= "test.user"
1109
+
; old_pds= "https://bsky.social"
1110
+
; access_jwt= "test_access_jwt"
1111
+
; refresh_jwt= "test_refresh_jwt"
1112
+
; email= "test@example.com"
1113
+
; blobs_imported= 100
1114
+
; blobs_failed= 0
1115
+
; blobs_cursor= ""
1116
+
; plc_requested= true }
1117
+
in
1118
+
Util.render_html ~title:"Migrate Account"
1119
+
(module Frontend.MigratePage)
1120
+
~props:
1121
+
(make_props ~step:"enter_plc_token"
1122
+
~did:"did:plc:testuser123" ~handle:"test.user"
1123
+
~old_pds:"https://bsky.social" ~blobs_imported:100
1124
+
~blobs_failed:0
1125
+
~message:
1126
+
"Data import complete! Check your email for a PLC \
1127
+
confirmation code."
1128
+
() )
1129
+
| Some "complete" ->
1130
+
Util.render_html ~title:"Migrate Account"
1131
+
(module Frontend.MigratePage)
1132
+
~props:
1133
+
(make_props ~step:"complete" ~did:"did:plc:testuser123"
1134
+
~handle:"test.user" ~blobs_imported:100 ~blobs_failed:0
1135
+
~old_account_deactivated:true
1136
+
~message:"Your account has been successfully migrated!"
1137
+
() )
1138
+
| Some "complete_deactivation_failed" ->
1139
+
Util.render_html ~title:"Migrate Account"
1140
+
(module Frontend.MigratePage)
1141
+
~props:
1142
+
(make_props ~step:"complete" ~did:"did:plc:testuser123"
1143
+
~handle:"test.user" ~blobs_imported:95 ~blobs_failed:5
1144
+
~old_account_deactivated:false
1145
+
~old_account_deactivation_error:
1146
+
"Failed to deactivate old account (401): \
1147
+
Unauthorized"
1148
+
~message:"Your account has been successfully migrated!"
1149
+
() )
1150
+
| Some "error" ->
1151
+
Util.render_html ~title:"Migrate Account"
1152
+
(module Frontend.MigratePage)
1153
+
~props:(make_props ~step:"error" ())
1154
+
| _ -> (
1155
+
if
1156
+
(* normal flow *)
1157
+
String.length identifier = 0
1158
+
then render_error "Please enter your handle or DID"
1159
+
else if String.length password = 0 then
1160
+
render_error "Please enter your password"
1161
+
else
1162
+
(* step 1: resolve identity *)
1163
+
match%lwt resolve_identity identifier with
1164
+
| Error e ->
1165
+
render_error e
1166
+
| Ok (did, handle, old_pds) -> (
1167
+
(* step 2: authenticate with old pds *)
1168
+
match%lwt
1169
+
create_session_on_pds ~pds_endpoint:old_pds ~identifier
1170
+
~password ()
1171
+
with
1172
+
| AuthError e ->
1173
+
render_error e
1174
+
| AuthNeeds2FA ->
1175
+
(* show 2FA form *)
1176
+
Util.render_html ~title:"Migrate Account"
1177
+
(module Frontend.MigratePage)
1178
+
~props:
1179
+
(make_props ~step:"enter_2fa" ~identifier ~old_pds
1180
+
?invite_code () )
1181
+
| AuthSuccess session -> (
1182
+
(* step 3: get session info for account status and email *)
1183
+
match%lwt
1184
+
get_session ~pds_endpoint:old_pds
1185
+
~access_jwt:session.access_jwt
1186
+
with
1187
+
| Error e ->
1188
+
render_error ("Failed to get account info: " ^ e)
1189
+
| Ok session_info -> (
1190
+
let is_active =
1191
+
match session_info.active with
1192
+
| Some false ->
1193
+
false
1194
+
| _ ->
1195
+
true (* default to true if not specified *)
1196
+
in
1197
+
if not is_active then
1198
+
render_error
1199
+
"This account is already deactivated. Cannot \
1200
+
migrate a deactivated account."
1201
+
else
1202
+
(* step 4: get service auth token *)
1203
+
match%lwt
1204
+
get_service_auth ~pds_endpoint:old_pds
1205
+
~access_jwt:session.access_jwt
1206
+
with
1207
+
| Error e ->
1208
+
render_error
1209
+
("Failed to get service authorization: " ^ e)
1210
+
| Ok service_auth_token -> (
1211
+
(* use real email from old PDS, fallback to placeholder *)
1212
+
let email =
1213
+
match session_info.email with
1214
+
| Some e when String.length e > 0 ->
1215
+
e
1216
+
| _ ->
1217
+
Printf.sprintf "%s@%s" did Env.hostname
1218
+
in
1219
+
(* Step 5: Create account *)
1220
+
match%lwt
1221
+
create_migrated_account ~email ~handle
1222
+
~password ~did ~service_auth_token
1223
+
?invite_code ctx.db
1224
+
with
1225
+
| Error e
1226
+
when String.starts_with ~prefix:"RESUMABLE:"
1227
+
e -> (
1228
+
(* try to automatically resume *)
1229
+
match%lwt
1230
+
check_resume_state ~did ctx.db
1231
+
with
1232
+
| Error e ->
1233
+
render_error ~did ~handle ~old_pds e
1234
+
| Ok AlreadyActive ->
1235
+
(* account is already active, just log them in *)
1236
+
let%lwt () =
1237
+
Session.log_in_did ctx.req did
1238
+
in
1239
+
Util.render_html
1240
+
~title:"Migrate Account"
1241
+
(module Frontend.MigratePage)
1242
+
~props:
1243
+
(make_props ~step:"complete" ~did
1244
+
~handle
1245
+
~message:
1246
+
"Your account is already \
1247
+
active! You have been logged \
1248
+
in."
1249
+
() )
1250
+
| Ok NeedsActivation ->
1251
+
(* identity already points here, just activate *)
1252
+
let%lwt () =
1253
+
activate_account did ctx.db
1254
+
in
1255
+
let%lwt () =
1256
+
Session.log_in_did ctx.req did
1257
+
in
1258
+
let%lwt deactivation_result =
1259
+
match%lwt
1260
+
deactivate_old_account
1261
+
~pds_endpoint:old_pds
1262
+
~access_jwt:session.access_jwt
1263
+
with
1264
+
| Ok () ->
1265
+
Lwt.return_ok ()
1266
+
| Error err
1267
+
when Util.str_contains ~affix:"401"
1268
+
err
1269
+
|| Util.str_contains
1270
+
~affix:"Unauthorized" err
1271
+
-> (
1272
+
match%lwt
1273
+
refresh_session
1274
+
~pds_endpoint:old_pds
1275
+
~refresh_jwt:session.refresh_jwt
1276
+
with
1277
+
| Ok tokens ->
1278
+
deactivate_old_account
1279
+
~pds_endpoint:old_pds
1280
+
~access_jwt:tokens.access_jwt
1281
+
| Error refresh_err ->
1282
+
Lwt.return_error
1283
+
(Printf.sprintf
1284
+
"Token expired and \
1285
+
refresh failed: %s"
1286
+
refresh_err ) )
1287
+
| Error err ->
1288
+
Lwt.return_error err
1289
+
in
1290
+
let ( old_account_deactivated
1291
+
, old_account_deactivation_error ) =
1292
+
match deactivation_result with
1293
+
| Ok () ->
1294
+
(true, None)
1295
+
| Error err ->
1296
+
Dream.warning (fun log ->
1297
+
log
1298
+
"migration %s: failed to \
1299
+
deactivate old account: \
1300
+
%s"
1301
+
did err ) ;
1302
+
(false, Some err)
1303
+
in
1304
+
Util.render_html
1305
+
~title:"Migrate Account"
1306
+
(module Frontend.MigratePage)
1307
+
~props:
1308
+
(make_props ~step:"complete" ~did
1309
+
~handle ~old_account_deactivated
1310
+
?old_account_deactivation_error
1311
+
~message:
1312
+
"Your account has been \
1313
+
activated! Your identity is \
1314
+
pointing to this PDS."
1315
+
() )
1316
+
| Ok NeedsPlcUpdate ->
1317
+
(* data is imported, need plc update *)
1318
+
transition_to_plc_token_step ~did
1319
+
~handle ~old_pds
1320
+
~access_jwt:session.access_jwt
1321
+
~refresh_jwt:session.refresh_jwt
1322
+
~email ~blobs_imported:0
1323
+
~blobs_failed:0
1324
+
| Ok NeedsRepoImport | Ok NeedsBlobImport
1325
+
-> (
1326
+
(* need to re-import data, continue with normal flow *)
1327
+
match%lwt
1328
+
fetch_repo ~pds_endpoint:old_pds
1329
+
~access_jwt:session.access_jwt ~did
1330
+
with
1331
+
| Error err ->
1332
+
render_error ~did ~handle ~old_pds
1333
+
( "Failed to fetch repository: "
1334
+
^ err )
1335
+
| Ok car_data -> (
1336
+
match%lwt
1337
+
import_repo ~did ~car_data
1338
+
with
1339
+
| Error err ->
1340
+
render_error ~did ~handle ~old_pds
1341
+
err
1342
+
| Ok () ->
1343
+
(* continue with blob import like normal flow *)
1344
+
transition_to_plc_token_step ~did
1345
+
~handle ~old_pds
1346
+
~access_jwt:session.access_jwt
1347
+
~refresh_jwt:session.refresh_jwt
1348
+
~email ~blobs_imported:0
1349
+
~blobs_failed:0 ) ) )
1350
+
| Error e ->
1351
+
render_error e
1352
+
| Ok _signing_key_did -> (
1353
+
(* step 5: fetch and import repo *)
1354
+
match%lwt
1355
+
fetch_repo ~pds_endpoint:old_pds
1356
+
~access_jwt:session.access_jwt ~did
1357
+
with
1358
+
| Error e ->
1359
+
render_error
1360
+
("Failed to fetch repository: " ^ e)
1361
+
| Ok car_data -> (
1362
+
match%lwt import_repo ~did ~car_data with
1363
+
| Error e ->
1364
+
render_error e
1365
+
| Ok () -> (
1366
+
(* log account status after repo import *)
1367
+
let%lwt () =
1368
+
match%lwt
1369
+
check_local_account_status ~did
1370
+
with
1371
+
| Ok status ->
1372
+
Dream.info (fun log ->
1373
+
log
1374
+
"migration %s: repo \
1375
+
imported, \
1376
+
indexed_records=%d, \
1377
+
expected_blobs=%d"
1378
+
did status.indexed_records
1379
+
status.expected_blobs ) ;
1380
+
Lwt.return_unit
1381
+
| Error e ->
1382
+
Dream.warning (fun log ->
1383
+
log
1384
+
"migration %s: failed to \
1385
+
check account status: \
1386
+
%s"
1387
+
did e ) ;
1388
+
Lwt.return_unit
1389
+
in
1390
+
(* step 6: list missing blobs to import *)
1391
+
match%lwt
1392
+
list_local_missing_blobs ~did
1393
+
~limit:50 ()
1394
+
with
1395
+
| Error e ->
1396
+
Dream.warning (fun log ->
1397
+
log
1398
+
"migration %s: failed to \
1399
+
list missing blobs: %s"
1400
+
did e ) ;
1401
+
(* skip blobs, go to plc token step *)
1402
+
transition_to_plc_token_step ~did
1403
+
~handle ~old_pds
1404
+
~access_jwt:session.access_jwt
1405
+
~refresh_jwt:session.refresh_jwt
1406
+
~email ~blobs_imported:0
1407
+
~blobs_failed:0
1408
+
| Ok (missing_cids, next_cursor) ->
1409
+
if List.length missing_cids = 0
1410
+
then
1411
+
(* no missing blobs, go to plc token step *)
1412
+
transition_to_plc_token_step
1413
+
~did ~handle ~old_pds
1414
+
~access_jwt:session.access_jwt
1415
+
~refresh_jwt:
1416
+
session.refresh_jwt ~email
1417
+
~blobs_imported:0
1418
+
~blobs_failed:0
1419
+
else
1420
+
(* import this batch of missing blobs *)
1421
+
let%lwt imported, failed =
1422
+
import_blobs_batch
1423
+
~pds_endpoint:old_pds
1424
+
~access_jwt:
1425
+
session.access_jwt ~did
1426
+
~cids:missing_cids
1427
+
in
1428
+
(* store state for continuation *)
1429
+
let cursor =
1430
+
Option.value ~default:""
1431
+
next_cursor
1432
+
in
1433
+
(* check if there are more missing blobs *)
1434
+
if String.length cursor = 0 then
1435
+
(* no more missing blobs, go to plc *)
1436
+
transition_to_plc_token_step
1437
+
~did ~handle ~old_pds
1438
+
~access_jwt:
1439
+
session.access_jwt
1440
+
~refresh_jwt:
1441
+
session.refresh_jwt ~email
1442
+
~blobs_imported:imported
1443
+
~blobs_failed:failed
1444
+
else
1445
+
(* more blobs to import, save state *)
1446
+
let%lwt () =
1447
+
set_migration_state ctx.req
1448
+
{ did
1449
+
; handle
1450
+
; old_pds
1451
+
; access_jwt=
1452
+
session.access_jwt
1453
+
; refresh_jwt=
1454
+
session.refresh_jwt
1455
+
; email
1456
+
; blobs_imported= imported
1457
+
; blobs_failed= failed
1458
+
; blobs_cursor= cursor
1459
+
; plc_requested= false }
1460
+
in
1461
+
Util.render_html
1462
+
~title:"Migrate Account"
1463
+
(module Frontend.MigratePage)
1464
+
~props:
1465
+
(make_props
1466
+
~step:"importing_data"
1467
+
~did ~handle ~old_pds
1468
+
~blobs_imported:
1469
+
imported
1470
+
~blobs_failed:failed () )
1471
+
) ) ) ) ) ) ) ) )
1472
+
| "continue_blobs" -> (
1473
+
match get_migration_state ctx.req with
1474
+
| None ->
1475
+
render_error "Migration state not found. Please start over."
1476
+
| Some state -> (
1477
+
(* refresh token if needed before continuing blob import *)
1478
+
let%lwt state =
1479
+
if jwt_needs_refresh state.access_jwt then (
1480
+
match%lwt
1481
+
refresh_session ~pds_endpoint:state.old_pds
1482
+
~refresh_jwt:state.refresh_jwt
1483
+
with
1484
+
| Ok tokens ->
1485
+
let new_state =
1486
+
{ state with
1487
+
access_jwt= tokens.access_jwt
1488
+
; refresh_jwt= tokens.refresh_jwt }
1489
+
in
1490
+
let%lwt () = set_migration_state ctx.req new_state in
1491
+
Lwt.return new_state
1492
+
| Error e ->
1493
+
Dream.warning (fun log ->
1494
+
log
1495
+
"migration %s: token refresh failed, continuing \
1496
+
with old token: %s"
1497
+
state.did e ) ;
1498
+
Lwt.return state )
1499
+
else Lwt.return state
1500
+
in
1501
+
(* continue importing missing blobs *)
1502
+
let cursor =
1503
+
if String.length state.blobs_cursor > 0 then
1504
+
Some state.blobs_cursor
1505
+
else None
1506
+
in
1507
+
match%lwt
1508
+
list_local_missing_blobs ~did:state.did ~limit:50 ?cursor ()
1509
+
with
1510
+
| Error e ->
1511
+
Dream.warning (fun log ->
1512
+
log "migration %s: failed to list missing blobs: %s"
1513
+
state.did e ) ;
1514
+
(* no more blobs, go to plc token step *)
1515
+
transition_to_plc_token_step ~did:state.did
1516
+
~handle:state.handle ~old_pds:state.old_pds
1517
+
~access_jwt:state.access_jwt
1518
+
~refresh_jwt:state.refresh_jwt ~email:state.email
1519
+
~blobs_imported:state.blobs_imported
1520
+
~blobs_failed:state.blobs_failed
1521
+
| Ok (missing_cids, next_cursor) ->
1522
+
if List.length missing_cids = 0 then
1523
+
(* no more blobs, go to plc token step *)
1524
+
transition_to_plc_token_step ~did:state.did
1525
+
~handle:state.handle ~old_pds:state.old_pds
1526
+
~access_jwt:state.access_jwt
1527
+
~refresh_jwt:state.refresh_jwt ~email:state.email
1528
+
~blobs_imported:state.blobs_imported
1529
+
~blobs_failed:state.blobs_failed
1530
+
else
1531
+
let%lwt imported, failed =
1532
+
import_blobs_batch ~pds_endpoint:state.old_pds
1533
+
~access_jwt:state.access_jwt ~did:state.did
1534
+
~cids:missing_cids
1535
+
in
1536
+
let new_imported = state.blobs_imported + imported in
1537
+
let new_failed = state.blobs_failed + failed in
1538
+
let new_cursor = Option.value ~default:"" next_cursor in
1539
+
(* check if there are more missing blobs *)
1540
+
if String.length new_cursor = 0 then
1541
+
(* all done, go to plc *)
1542
+
transition_to_plc_token_step ~did:state.did
1543
+
~handle:state.handle ~old_pds:state.old_pds
1544
+
~access_jwt:state.access_jwt
1545
+
~refresh_jwt:state.refresh_jwt ~email:state.email
1546
+
~blobs_imported:new_imported ~blobs_failed:new_failed
1547
+
else
1548
+
(* more blobs to import, save state *)
1549
+
let%lwt () =
1550
+
set_migration_state ctx.req
1551
+
{ state with
1552
+
blobs_imported= new_imported
1553
+
; blobs_failed= new_failed
1554
+
; blobs_cursor= new_cursor }
1555
+
in
1556
+
Util.render_html ~title:"Migrate Account"
1557
+
(module Frontend.MigratePage)
1558
+
~props:
1559
+
(make_props ~step:"importing_data" ~did:state.did
1560
+
~handle:state.handle ~old_pds:state.old_pds
1561
+
~blobs_imported:new_imported
1562
+
~blobs_failed:new_failed () ) ) )
1563
+
| "submit_plc_token" -> (
1564
+
match get_migration_state ctx.req with
1565
+
| None ->
1566
+
render_error "Migration state not found. Please start over."
1567
+
| Some state -> (
1568
+
let plc_token =
1569
+
List.assoc_opt "plc_token" fields
1570
+
|> Option.value ~default:"" |> String.trim
1571
+
in
1572
+
if String.length plc_token = 0 then
1573
+
render_error ~step:"enter_plc_token" ~did:state.did
1574
+
~handle:state.handle ~old_pds:state.old_pds
1575
+
"Please enter the PLC token from your email"
1576
+
else
1577
+
(* Get our recommended credentials *)
1578
+
match%lwt
1579
+
get_recommended_did_credentials state.did ctx.db
1580
+
with
1581
+
| Error e ->
1582
+
render_error ~step:"enter_plc_token" ~did:state.did
1583
+
~handle:state.handle ~old_pds:state.old_pds
1584
+
("Failed to get credentials: " ^ e)
1585
+
| Ok base_credentials -> (
1586
+
(* new rotation keys = current rotation keys - old PDS key(s) + new PDS key *)
1587
+
let%lwt merged_credentials =
1588
+
let%lwt old_pds_keys =
1589
+
match%lwt
1590
+
get_remote_recommended_credentials
1591
+
~pds_endpoint:state.old_pds
1592
+
~access_jwt:state.access_jwt
1593
+
with
1594
+
| Ok creds ->
1595
+
Lwt.return creds.rotation_keys
1596
+
| Error e ->
1597
+
Dream.warning (fun log ->
1598
+
log
1599
+
"migration %s: failed to get old PDS \
1600
+
credentials: %s"
1601
+
state.did e ) ;
1602
+
Lwt.return []
1603
+
in
1604
+
let%lwt current_keys =
1605
+
match%lwt get_plc_rotation_keys ~did:state.did with
1606
+
| Ok keys ->
1607
+
Lwt.return keys
1608
+
| Error _ ->
1609
+
Lwt.return []
1610
+
in
1611
+
(* remove old PDS key(s) from current keys *)
1612
+
let preserved_keys =
1613
+
List.filter
1614
+
(fun k -> not (List.mem k old_pds_keys))
1615
+
current_keys
1616
+
in
1617
+
(* then add in new key *)
1618
+
let merged_keys =
1619
+
preserved_keys @ base_credentials.rotation_keys
1620
+
|> List.sort_uniq String.compare
1621
+
in
1622
+
Lwt.return
1623
+
{base_credentials with rotation_keys= merged_keys}
1624
+
in
1625
+
(* get old pds to sign plc operation *)
1626
+
match%lwt
1627
+
sign_plc_operation ~pds_endpoint:state.old_pds
1628
+
~access_jwt:state.access_jwt ~token:plc_token
1629
+
~credentials:merged_credentials
1630
+
with
1631
+
| Error e ->
1632
+
render_error ~step:"enter_plc_token" ~did:state.did
1633
+
~handle:state.handle ~old_pds:state.old_pds
1634
+
("Failed to sign PLC operation: " ^ e)
1635
+
| Ok signed_operation -> (
1636
+
(* submit plc operation *)
1637
+
match%lwt
1638
+
submit_plc_operation ~did:state.did
1639
+
~handle:state.handle ~operation:signed_operation
1640
+
ctx.db
1641
+
with
1642
+
| Error e ->
1643
+
render_error ~step:"enter_plc_token" ~did:state.did
1644
+
~handle:state.handle ~old_pds:state.old_pds
1645
+
("Failed to submit PLC operation: " ^ e)
1646
+
| Ok () ->
1647
+
(* log account status before activation *)
1648
+
let%lwt () =
1649
+
match%lwt
1650
+
check_local_account_status ~did:state.did
1651
+
with
1652
+
| Ok status ->
1653
+
Dream.info (fun log ->
1654
+
log
1655
+
"migration %s: activating account, \
1656
+
imported_blobs=%d/%d"
1657
+
state.did status.imported_blobs
1658
+
status.expected_blobs ) ;
1659
+
Lwt.return_unit
1660
+
| Error e ->
1661
+
Dream.warning (fun log ->
1662
+
log
1663
+
"migration %s: failed to check status \
1664
+
before activation: %s"
1665
+
state.did e ) ;
1666
+
Lwt.return_unit
1667
+
in
1668
+
(* activate the account *)
1669
+
let%lwt () = activate_account state.did ctx.db in
1670
+
let%lwt () = Session.log_in_did ctx.req state.did in
1671
+
let%lwt () = clear_migration_state ctx.req in
1672
+
(* try deactivating old account with current token, refresh if expired *)
1673
+
let%lwt deactivation_result =
1674
+
match%lwt
1675
+
deactivate_old_account
1676
+
~pds_endpoint:state.old_pds
1677
+
~access_jwt:state.access_jwt
1678
+
with
1679
+
| Ok () ->
1680
+
Lwt.return_ok ()
1681
+
| Error e
1682
+
when Util.str_contains ~affix:"401" e
1683
+
|| Util.str_contains ~affix:"Unauthorized"
1684
+
e -> (
1685
+
match%lwt
1686
+
refresh_session ~pds_endpoint:state.old_pds
1687
+
~refresh_jwt:state.refresh_jwt
1688
+
with
1689
+
| Ok tokens ->
1690
+
deactivate_old_account
1691
+
~pds_endpoint:state.old_pds
1692
+
~access_jwt:tokens.access_jwt
1693
+
| Error refresh_err ->
1694
+
Lwt.return_error
1695
+
(Printf.sprintf
1696
+
"Token expired and refresh failed: %s"
1697
+
refresh_err ) )
1698
+
| Error e ->
1699
+
Lwt.return_error e
1700
+
in
1701
+
let ( old_account_deactivated
1702
+
, old_account_deactivation_error ) =
1703
+
match deactivation_result with
1704
+
| Ok () ->
1705
+
(true, None)
1706
+
| Error e ->
1707
+
Dream.warning (fun log ->
1708
+
log
1709
+
"migration %s: failed to deactivate \
1710
+
old account: %s"
1711
+
state.did e ) ;
1712
+
(false, Some e)
1713
+
in
1714
+
Util.render_html ~title:"Migrate Account"
1715
+
(module Frontend.MigratePage)
1716
+
~props:
1717
+
(make_props ~step:"complete" ~did:state.did
1718
+
~handle:state.handle
1719
+
~blobs_imported:state.blobs_imported
1720
+
~blobs_failed:state.blobs_failed
1721
+
~old_account_deactivated
1722
+
?old_account_deactivation_error
1723
+
~message:
1724
+
"Your account has been successfully \
1725
+
migrated!"
1726
+
() ) ) ) ) )
1727
+
| "resend_plc_token" -> (
1728
+
match get_migration_state ctx.req with
1729
+
| None ->
1730
+
render_error "Migration state not found. Please start over."
1731
+
| Some state -> (
1732
+
match%lwt
1733
+
request_plc_operation_signature ~pds_endpoint:state.old_pds
1734
+
~access_jwt:state.access_jwt
1735
+
with
1736
+
| Error e ->
1737
+
Util.render_html ~title:"Migrate Account"
1738
+
(module Frontend.MigratePage)
1739
+
~props:
1740
+
(make_props ~step:"enter_plc_token" ~did:state.did
1741
+
~handle:state.handle ~old_pds:state.old_pds
1742
+
~error:("Failed to resend: " ^ e) () )
1743
+
| Ok () ->
1744
+
Util.render_html ~title:"Migrate Account"
1745
+
(module Frontend.MigratePage)
1746
+
~props:
1747
+
(make_props ~step:"enter_plc_token" ~did:state.did
1748
+
~handle:state.handle ~old_pds:state.old_pds
1749
+
~message:"Confirmation code resent! Check your email."
1750
+
() ) ) )
1751
+
| "submit_2fa" -> (
1752
+
let identifier =
1753
+
List.assoc_opt "identifier" fields
1754
+
|> Option.value ~default:"" |> String.trim
1755
+
in
1756
+
let old_pds =
1757
+
List.assoc_opt "old_pds" fields
1758
+
|> Option.value ~default:"" |> String.trim
1759
+
in
1760
+
let auth_factor_token =
1761
+
List.assoc_opt "auth_factor_token" fields
1762
+
|> Option.value ~default:"" |> String.trim
1763
+
in
1764
+
let invite_code =
1765
+
List.assoc_opt "invite_code" fields |> Option.map String.trim
1766
+
in
1767
+
let password =
1768
+
List.assoc_opt "password" fields |> Option.value ~default:""
1769
+
in
1770
+
if String.length auth_factor_token = 0 then
1771
+
render_error ~step:"enter_2fa" ~identifier ~old_pds ?invite_code
1772
+
"Please enter your authentication code"
1773
+
else
1774
+
(* re-authenticate with 2fa token *)
1775
+
match%lwt resolve_identity identifier with
1776
+
| Error e ->
1777
+
render_error ~step:"enter_2fa" ~identifier ~old_pds
1778
+
?invite_code e
1779
+
| Ok (did, handle, resolved_pds) -> (
1780
+
let pds_endpoint =
1781
+
if String.length old_pds > 0 then old_pds
1782
+
else resolved_pds
1783
+
in
1784
+
match%lwt
1785
+
create_session_on_pds ~pds_endpoint ~identifier ~password
1786
+
~auth_factor_token ()
1787
+
with
1788
+
| AuthError e ->
1789
+
render_error ~step:"enter_2fa" ~identifier
1790
+
~old_pds:pds_endpoint ?invite_code e
1791
+
| AuthNeeds2FA ->
1792
+
render_error ~step:"enter_2fa" ~identifier
1793
+
~old_pds:pds_endpoint ?invite_code
1794
+
"Invalid authentication code. Please try again."
1795
+
| AuthSuccess session -> (
1796
+
(* continue with normal migration flow *)
1797
+
match%lwt
1798
+
get_session ~pds_endpoint ~access_jwt:session.access_jwt
1799
+
with
1800
+
| Error e ->
1801
+
render_error ("Failed to get account info: " ^ e)
1802
+
| Ok session_info -> (
1803
+
let is_active =
1804
+
match session_info.active with
1805
+
| Some false ->
1806
+
false
1807
+
| _ ->
1808
+
true
1809
+
in
1810
+
if not is_active then
1811
+
render_error
1812
+
"This account is already deactivated. Cannot \
1813
+
migrate a deactivated account."
1814
+
else
1815
+
match%lwt
1816
+
get_service_auth ~pds_endpoint
1817
+
~access_jwt:session.access_jwt
1818
+
with
1819
+
| Error e ->
1820
+
render_error
1821
+
("Failed to get service authorization: " ^ e)
1822
+
| Ok service_auth_token -> (
1823
+
let email =
1824
+
match session_info.email with
1825
+
| Some e when String.length e > 0 ->
1826
+
e
1827
+
| _ ->
1828
+
Printf.sprintf "%s@%s" did Env.hostname
1829
+
in
1830
+
match%lwt
1831
+
create_migrated_account ~email ~handle
1832
+
~password ~did ~service_auth_token
1833
+
?invite_code ctx.db
1834
+
with
1835
+
| Error e ->
1836
+
render_error e
1837
+
| Ok _signing_key_did -> (
1838
+
match%lwt
1839
+
fetch_repo ~pds_endpoint
1840
+
~access_jwt:session.access_jwt ~did
1841
+
with
1842
+
| Error e ->
1843
+
render_error
1844
+
("Failed to fetch repository: " ^ e)
1845
+
| Ok car_data -> (
1846
+
match%lwt import_repo ~did ~car_data with
1847
+
| Error e ->
1848
+
render_error e
1849
+
| Ok () ->
1850
+
transition_to_plc_token_step ~did
1851
+
~handle ~old_pds:pds_endpoint
1852
+
~access_jwt:session.access_jwt
1853
+
~refresh_jwt:session.refresh_jwt
1854
+
~email ~blobs_imported:0
1855
+
~blobs_failed:0 ) ) ) ) ) ) )
1856
+
| "resume_migration" -> (
1857
+
(* resume a previously started migration *)
1858
+
let identifier =
1859
+
List.assoc_opt "identifier" fields
1860
+
|> Option.value ~default:"" |> String.trim
1861
+
in
1862
+
let password =
1863
+
List.assoc_opt "password" fields |> Option.value ~default:""
1864
+
in
1865
+
if String.length identifier = 0 then
1866
+
render_error ~step:"resume_available"
1867
+
"Please enter your handle or DID"
1868
+
else if String.length password = 0 then
1869
+
render_error ~step:"resume_available"
1870
+
"Please enter your password"
1871
+
else
1872
+
match%lwt resolve_identity identifier with
1873
+
| Error e ->
1874
+
render_error ~step:"resume_available" e
1875
+
| Ok (did, handle, old_pds) -> (
1876
+
match%lwt
1877
+
create_session_on_pds ~pds_endpoint:old_pds ~identifier
1878
+
~password ()
1879
+
with
1880
+
| AuthError e ->
1881
+
render_error ~step:"resume_available" e
1882
+
| AuthNeeds2FA ->
1883
+
(* show 2fa form, for resume we go back to credentials *)
1884
+
Util.render_html ~title:"Migrate Account"
1885
+
(module Frontend.MigratePage)
1886
+
~props:
1887
+
(make_props ~step:"enter_2fa" ~identifier ~old_pds ())
1888
+
| AuthSuccess session -> (
1889
+
(* get session info for email *)
1890
+
let%lwt email =
1891
+
match%lwt
1892
+
get_session ~pds_endpoint:old_pds
1893
+
~access_jwt:session.access_jwt
1894
+
with
1895
+
| Ok info ->
1896
+
Lwt.return
1897
+
( match info.email with
1898
+
| Some e when String.length e > 0 ->
1899
+
e
1900
+
| _ ->
1901
+
Printf.sprintf "%s@%s" did Env.hostname )
1902
+
| Error _ ->
1903
+
Lwt.return (Printf.sprintf "%s@%s" did Env.hostname)
1904
+
in
1905
+
(* check what state the existing account is in *)
1906
+
match%lwt check_resume_state ~did ctx.db with
1907
+
| Error e ->
1908
+
render_error ~step:"resume_available" ~did ~handle
1909
+
~old_pds e
1910
+
| Ok AlreadyActive ->
1911
+
(* already active, just log in *)
1912
+
let%lwt () = Session.log_in_did ctx.req did in
1913
+
Util.render_html ~title:"Migrate Account"
1914
+
(module Frontend.MigratePage)
1915
+
~props:
1916
+
(make_props ~step:"complete" ~did ~handle
1917
+
~message:
1918
+
"Your account is already active! You have \
1919
+
been logged in."
1920
+
() )
1921
+
| Ok NeedsActivation ->
1922
+
(* identity already points here, just activate *)
1923
+
let%lwt () = activate_account did ctx.db in
1924
+
let%lwt () = Session.log_in_did ctx.req did in
1925
+
let%lwt deactivation_result =
1926
+
match%lwt
1927
+
deactivate_old_account ~pds_endpoint:old_pds
1928
+
~access_jwt:session.access_jwt
1929
+
with
1930
+
| Ok () ->
1931
+
Lwt.return_ok ()
1932
+
| Error e
1933
+
when Util.str_contains ~affix:"401" e
1934
+
|| Util.str_contains ~affix:"Unauthorized" e
1935
+
-> (
1936
+
match%lwt
1937
+
refresh_session ~pds_endpoint:old_pds
1938
+
~refresh_jwt:session.refresh_jwt
1939
+
with
1940
+
| Ok tokens ->
1941
+
deactivate_old_account ~pds_endpoint:old_pds
1942
+
~access_jwt:tokens.access_jwt
1943
+
| Error refresh_err ->
1944
+
Lwt.return_error
1945
+
(Printf.sprintf
1946
+
"Token expired and refresh failed: %s"
1947
+
refresh_err ) )
1948
+
| Error e ->
1949
+
Lwt.return_error e
1950
+
in
1951
+
let ( old_account_deactivated
1952
+
, old_account_deactivation_error ) =
1953
+
match deactivation_result with
1954
+
| Ok () ->
1955
+
(true, None)
1956
+
| Error e ->
1957
+
Dream.warning (fun log ->
1958
+
log
1959
+
"migration %s: failed to deactivate old \
1960
+
account: %s"
1961
+
did e ) ;
1962
+
(false, Some e)
1963
+
in
1964
+
Util.render_html ~title:"Migrate Account"
1965
+
(module Frontend.MigratePage)
1966
+
~props:
1967
+
(make_props ~step:"complete" ~did ~handle
1968
+
~old_account_deactivated
1969
+
?old_account_deactivation_error
1970
+
~message:
1971
+
"Your account has been activated! Your \
1972
+
identity is pointing to this PDS."
1973
+
() )
1974
+
| Ok NeedsPlcUpdate ->
1975
+
(* data is imported, need plc update *)
1976
+
transition_to_plc_token_step ~did ~handle ~old_pds
1977
+
~access_jwt:session.access_jwt
1978
+
~refresh_jwt:session.refresh_jwt ~email
1979
+
~blobs_imported:0 ~blobs_failed:0
1980
+
| Ok NeedsRepoImport | Ok NeedsBlobImport -> (
1981
+
(* need to re-import data *)
1982
+
match%lwt
1983
+
fetch_repo ~pds_endpoint:old_pds
1984
+
~access_jwt:session.access_jwt ~did
1985
+
with
1986
+
| Error e ->
1987
+
render_error ~did ~handle ~old_pds
1988
+
("Failed to fetch repository: " ^ e)
1989
+
| Ok car_data -> (
1990
+
match%lwt import_repo ~did ~car_data with
1991
+
| Error e ->
1992
+
render_error ~did ~handle ~old_pds e
1993
+
| Ok () -> (
1994
+
(* list missing blobs locally *)
1995
+
match%lwt
1996
+
list_local_missing_blobs ~did ~limit:50 ()
1997
+
with
1998
+
| Error e ->
1999
+
Dream.warning (fun log ->
2000
+
log
2001
+
"migration %s: failed to list missing \
2002
+
blobs: %s"
2003
+
did e ) ;
2004
+
transition_to_plc_token_step ~did ~handle
2005
+
~old_pds ~access_jwt:session.access_jwt
2006
+
~refresh_jwt:session.refresh_jwt ~email
2007
+
~blobs_imported:0 ~blobs_failed:0
2008
+
| Ok (missing_cids, next_cursor) ->
2009
+
if List.length missing_cids = 0 then
2010
+
transition_to_plc_token_step ~did ~handle
2011
+
~old_pds ~access_jwt:session.access_jwt
2012
+
~refresh_jwt:session.refresh_jwt ~email
2013
+
~blobs_imported:0 ~blobs_failed:0
2014
+
else
2015
+
let%lwt imported, failed =
2016
+
import_blobs_batch ~pds_endpoint:old_pds
2017
+
~access_jwt:session.access_jwt ~did
2018
+
~cids:missing_cids
2019
+
in
2020
+
let cursor =
2021
+
Option.value ~default:"" next_cursor
2022
+
in
2023
+
if String.length cursor = 0 then
2024
+
transition_to_plc_token_step ~did ~handle
2025
+
~old_pds ~access_jwt:session.access_jwt
2026
+
~refresh_jwt:session.refresh_jwt ~email
2027
+
~blobs_imported:imported
2028
+
~blobs_failed:failed
2029
+
else
2030
+
let%lwt () =
2031
+
set_migration_state ctx.req
2032
+
{ did
2033
+
; handle
2034
+
; old_pds
2035
+
; access_jwt= session.access_jwt
2036
+
; refresh_jwt= session.refresh_jwt
2037
+
; email
2038
+
; blobs_imported= imported
2039
+
; blobs_failed= failed
2040
+
; blobs_cursor= cursor
2041
+
; plc_requested= false }
2042
+
in
2043
+
Util.render_html ~title:"Migrate Account"
2044
+
(module Frontend.MigratePage)
2045
+
~props:
2046
+
(make_props ~step:"importing_data" ~did
2047
+
~handle ~old_pds
2048
+
~blobs_imported:imported
2049
+
~blobs_failed:failed () ) ) ) ) ) ) )
2050
+
| _ ->
2051
+
render_error "Invalid action" )
2052
+
| _ ->
2053
+
render_error "Invalid form submission" )
+17
-10
pegasus/lib/api/identity/getRecommendedDidCredentials.ml
+17
-10
pegasus/lib/api/identity/getRecommendedDidCredentials.ml
···
1
-
type response = Plc.credentials
1
+
type response = Plc.credentials [@@deriving yojson {strict= false}]
2
+
3
+
let get_credentials did db =
4
+
match%lwt Data_store.get_actor_by_identifier did db with
5
+
| None ->
6
+
Lwt.return_error "actor not found"
7
+
| Some actor ->
8
+
actor.signing_key |> Kleidos.parse_multikey_str |> Kleidos.derive_pubkey
9
+
|> Kleidos.pubkey_to_did_key
10
+
|> (fun did_key ->
11
+
Plc.create_did_credentials Env.rotation_key did_key actor.handle )
12
+
|> Lwt.return_ok
2
13
3
14
let handler =
4
15
Xrpc.handler ~auth:Authorization (fun {auth; db; _} ->
5
16
let did = Auth.get_authed_did_exn auth in
6
-
match%lwt Data_store.get_actor_by_identifier did db with
7
-
| None ->
8
-
Errors.internal_error ~msg:"actor not found" ()
9
-
| Some actor ->
10
-
actor.signing_key |> Kleidos.parse_multikey_str
11
-
|> Kleidos.derive_pubkey |> Kleidos.pubkey_to_did_key
12
-
|> (fun did_key ->
13
-
Plc.create_did_credentials Env.rotation_key did_key actor.handle )
14
-
|> Plc.credentials_to_yojson |> Yojson.Safe.to_string |> Dream.json )
17
+
match%lwt get_credentials did db with
18
+
| Error msg ->
19
+
Errors.internal_error ~msg ()
20
+
| Ok credentials ->
21
+
response_to_yojson credentials |> Yojson.Safe.to_string |> Dream.json )
+8
-25
pegasus/lib/api/identity/submitPlcOperation.ml
+8
-25
pegasus/lib/api/identity/submitPlcOperation.ml
···
12
12
| None ->
13
13
Errors.internal_error ~msg:"actor not found" ()
14
14
| Some actor -> (
15
-
let pds_pubkey =
16
-
Env.rotation_key |> Kleidos.derive_pubkey
17
-
|> Kleidos.pubkey_to_did_key
18
-
in
19
-
if not (List.mem pds_pubkey op.rotation_keys) then
20
-
Errors.invalid_request
21
-
"rotation keys must include the PDS public key" ;
22
-
( match List.assoc_opt "atproto_pds" op.services with
23
-
| Some {type'; endpoint}
24
-
when type' <> "AtprotoPersonalDataServer"
25
-
|| endpoint <> Env.host_endpoint ->
26
-
Errors.invalid_request "invalid atproto_pds service"
27
-
| _ ->
28
-
() ) ;
29
-
let actor_pubkey =
30
-
actor.signing_key |> Kleidos.parse_multikey_str
31
-
|> Kleidos.derive_pubkey |> Kleidos.pubkey_to_did_key
32
-
in
33
-
if
34
-
List.assoc_opt "atproto" op.verification_methods
35
-
<> Some actor_pubkey
36
-
then Errors.invalid_request "incorrect atproto signing key" ;
37
-
if List.hd op.also_known_as <> "at://" ^ actor.handle then
38
-
Errors.invalid_request "incorrect handle" ;
15
+
match
16
+
Plc.validate_operation ~handle:actor.handle
17
+
~signing_key:actor.signing_key (Operation op)
18
+
with
19
+
| Ok () -> (
39
20
match%lwt Plc.submit_operation did (Operation op) with
40
21
| Ok () ->
41
22
let%lwt _ = Sequencer.sequence_identity db ~did () in
···
46
27
~msg:
47
28
( "failed to submit plc operation: " ^ Int.to_string status
48
29
^ " " ^ msg )
49
-
() ) )
30
+
() )
31
+
| Error e ->
32
+
Errors.invalid_request e ) )
+39
-38
pegasus/lib/api/server/checkAccountStatus.ml
+39
-38
pegasus/lib/api/server/checkAccountStatus.ml
···
10
10
; imported_blobs: int [@key "importedBlobs"] }
11
11
[@@deriving yojson {strict= false}]
12
12
13
+
let get_account_status did =
14
+
let%lwt {db= us; commit; actor; _} = Repository.load did in
15
+
let%lwt cid, commit =
16
+
match commit with
17
+
| Some c ->
18
+
Lwt.return c
19
+
| None ->
20
+
User_store.get_commit us |> Lwt.map Option.get
21
+
in
22
+
let repo_commit, repo_rev = (Cid.to_string cid, commit.rev) in
23
+
match%lwt
24
+
Lwt.all
25
+
[ User_store.count_blocks us
26
+
; User_store.count_records us
27
+
; User_store.count_blobs us
28
+
; User_store.count_referenced_blobs us ]
29
+
with
30
+
| [block_count; indexed_records; imported_blobs; expected_blobs] ->
31
+
(* mst blocks + records + commit *)
32
+
let repo_blocks = block_count + indexed_records + 1 in
33
+
Lwt.return_ok
34
+
{ activated= actor.deactivated_at = None
35
+
; valid_did= true
36
+
; repo_commit
37
+
; repo_rev
38
+
; repo_blocks
39
+
; indexed_records
40
+
; private_state_values= 0
41
+
; expected_blobs
42
+
; imported_blobs }
43
+
| _ ->
44
+
Lwt.return_error "failed to load account data"
45
+
13
46
let handler =
14
-
Xrpc.handler (fun {db; auth; _} ->
47
+
Xrpc.handler (fun {auth; _} ->
15
48
let did = Auth.get_authed_did_exn auth in
16
-
match%lwt Data_store.get_actor_by_identifier did db with
17
-
| None ->
18
-
Errors.internal_error ~msg:"actor not found" ()
19
-
| Some actor -> (
20
-
let%lwt {db= us; commit; _} =
21
-
Repository.load did
22
-
in
23
-
let%lwt cid, commit =
24
-
match commit with
25
-
| Some c ->
26
-
Lwt.return c
27
-
| None ->
28
-
User_store.get_commit us |> Lwt.map Option.get
29
-
in
30
-
let repo_commit, repo_rev = (Cid.to_string cid, commit.rev) in
31
-
match%lwt
32
-
Lwt.all
33
-
[ User_store.count_blocks us
34
-
; User_store.count_records us
35
-
; User_store.count_blobs us
36
-
; User_store.count_referenced_blobs us ]
37
-
with
38
-
| [block_count; indexed_records; imported_blobs; expected_blobs] ->
39
-
(* mst blocks + records + commit *)
40
-
let repo_blocks = block_count + indexed_records + 1 in
41
-
{ activated= actor.deactivated_at <> None
42
-
; valid_did= true
43
-
; repo_commit
44
-
; repo_rev
45
-
; repo_blocks
46
-
; indexed_records
47
-
; private_state_values= 0
48
-
; expected_blobs
49
-
; imported_blobs }
50
-
|> response_to_yojson |> Yojson.Safe.to_string |> Dream.json
51
-
| _ ->
52
-
Errors.internal_error ~msg:"failed to load account data" () ) )
49
+
match%lwt get_account_status did with
50
+
| Ok status ->
51
+
status |> response_to_yojson |> Yojson.Safe.to_string |> Dream.json
52
+
| Error msg ->
53
+
Errors.internal_error ~msg () )
+4
-4
pegasus/lib/api/server/getSession.ml
+4
-4
pegasus/lib/api/server/getSession.ml
···
1
-
type response = Auth.session_info
1
+
type response = Auth.session_info [@@deriving yojson {strict= false}]
2
2
3
3
let handler =
4
4
Xrpc.handler ~auth:Authorization (fun {db; auth; _} ->
···
9
9
if Auth.allows_email_read auth then session
10
10
else
11
11
{ session with
12
-
email= ""
13
-
; email_confirmed= false
14
-
; email_auth_factor= false }
12
+
email= Some ""
13
+
; email_confirmed= Some false
14
+
; email_auth_factor= Some false }
15
15
in
16
16
Dream.json @@ Yojson.Safe.to_string @@ Auth.session_info_to_yojson session )
+22
-92
pegasus/lib/auth.ml
+22
-92
pegasus/lib/auth.ml
···
3
3
type session_info =
4
4
{ handle: string
5
5
; did: string
6
-
; email: string
7
-
; email_confirmed: bool [@key "emailConfirmed"]
8
-
; email_auth_factor: bool [@key "emailAuthFactor"]
6
+
; email: string option
7
+
; email_confirmed: bool option [@key "emailConfirmed"]
8
+
; email_auth_factor: bool option [@key "emailAuthFactor"]
9
9
; active: bool option [@default None]
10
10
; status: string option [@default None] }
11
11
[@@deriving yojson {strict= false}]
···
149
149
Lwt.return
150
150
{ did= actor.did
151
151
; handle= actor.handle
152
-
; email= actor.email
153
-
; email_confirmed= true
154
-
; email_auth_factor= true
152
+
; email= Some actor.email
153
+
; email_confirmed= Some (actor.email_confirmed_at <> None)
154
+
; email_auth_factor= Some true
155
155
; active
156
156
; status }
157
157
···
410
410
| Error e ->
411
411
Lwt.return_error @@ Errors.auth_required e
412
412
| Ok token -> (
413
-
match Jwt.decode_jwt token with
414
-
| Error e ->
415
-
Lwt.return_error @@ Errors.auth_required e
416
-
| Ok (_header, payload) -> (
417
-
try
418
-
let open Yojson.Safe.Util in
419
-
let iss = payload |> member "iss" |> to_string in
420
-
let aud = payload |> member "aud" |> to_string in
421
-
let exp = payload |> member "exp" |> to_int in
422
-
let lxm = payload |> member "lxm" |> to_string_option in
423
-
let now = int_of_float (Unix.gettimeofday ()) in
424
-
if exp < now then
425
-
Lwt.return_error
426
-
@@ Errors.invalid_request ~name:"ExpiredToken" "token expired"
427
-
else if aud <> Env.did then
428
-
Lwt.return_error
429
-
@@ Errors.invalid_request ~name:"InvalidToken"
430
-
"jwt audience does not match service did"
431
-
else
432
-
let nsid =
433
-
(Dream.path [@warning "-3"]) req |> List.rev |> List.hd
434
-
in
435
-
match lxm with
436
-
| Some l when l <> nsid && l <> "*" ->
437
-
Lwt.return_error
438
-
@@ Errors.invalid_request ~name:"InvalidToken"
439
-
("jwt lxm " ^ l ^ " does not match " ^ nsid)
440
-
| _ -> (
441
-
let did =
442
-
match String.split_on_char '#' iss with
443
-
| did :: _ ->
444
-
did
445
-
| [] ->
446
-
iss
447
-
in
448
-
match%lwt Id_resolver.Did.resolve did with
449
-
| Error e ->
450
-
Dream.debug (fun log ->
451
-
log "failed to resolve did %s: %s" did e ) ;
452
-
Lwt.return_error
453
-
@@ Errors.internal_error
454
-
~msg:"could not resolve jwt issuer did" ()
455
-
| Ok did_doc -> (
456
-
match
457
-
Id_resolver.Did.Document.get_verification_key did_doc
458
-
"#atproto"
459
-
with
460
-
| None ->
461
-
Lwt.return_error
462
-
@@ Errors.internal_error
463
-
~msg:"missing or bad key in issuer did doc" ()
464
-
| Some pubkey_multibase -> (
465
-
match%lwt
466
-
verify_with_key token pubkey_multibase did db
467
-
with
468
-
| Ok creds ->
469
-
Lwt.return_ok creds
470
-
| Error _ -> (
471
-
(* try again, skipping cache in case of key rotation *)
472
-
match%lwt
473
-
Id_resolver.Did.resolve ~skip_cache:true did
474
-
with
475
-
| Error _ ->
476
-
Lwt.return_error
477
-
@@ Errors.invalid_request ~name:"InvalidToken"
478
-
"jwt signature does not match jwt issuer"
479
-
| Ok fresh_doc -> (
480
-
match
481
-
Id_resolver.Did.Document.get_verification_key
482
-
fresh_doc "#atproto"
483
-
with
484
-
| None ->
485
-
Lwt.return_error
486
-
@@ Errors.invalid_request ~name:"InvalidToken"
487
-
"jwt signature does not match jwt issuer"
488
-
| Some fresh_pubkey_multibase
489
-
when fresh_pubkey_multibase = pubkey_multibase ->
490
-
Lwt.return_error
491
-
@@ Errors.invalid_request ~name:"InvalidToken"
492
-
"jwt signature does not match jwt issuer"
493
-
| Some fresh_pubkey_multibase ->
494
-
verify_with_key token fresh_pubkey_multibase did
495
-
db ) ) ) ) )
496
-
with _ ->
497
-
Lwt.return_error @@ Errors.invalid_request "malformed service jwt" )
498
-
)
413
+
let nsid = (Dream.path [@warning "-3"]) req |> List.rev |> List.hd in
414
+
match%lwt
415
+
Jwt.verify_service_jwt ~nsid
416
+
~verify_sig:(fun did pk -> verify_with_key token pk did db)
417
+
token
418
+
with
419
+
| Ok creds ->
420
+
Lwt.return_ok creds
421
+
| Error (AuthRequired e) ->
422
+
Lwt.return_error @@ Errors.auth_required e
423
+
| Error (ExpiredToken e) ->
424
+
Lwt.return_error @@ Errors.invalid_request ~name:"ExpiredToken" e
425
+
| Error (InvalidToken e) ->
426
+
Lwt.return_error @@ Errors.invalid_request ~name:"InvalidToken" e
427
+
| Error (InternalError e) ->
428
+
Lwt.return_error @@ Errors.internal_error ~msg:e () )
499
429
500
430
let authorization : verifier =
501
431
fun ctx ->
+14
pegasus/lib/errors.ml
+14
pegasus/lib/errors.ml
···
32
32
33
33
let use_dpop_nonce () = raise UseDpopNonceError
34
34
35
+
let printer = function
36
+
| InvalidRequestError (error, message) ->
37
+
Some (Printf.sprintf "Invalid request (%s): %s" error message)
38
+
| InternalServerError (error, message) ->
39
+
Some (Printf.sprintf "Internal server error (%s): %s" error message)
40
+
| AuthError (error, message) ->
41
+
Some (Printf.sprintf "Auth error (%s): %s" error message)
42
+
| NotFoundError (error, message) ->
43
+
Some (Printf.sprintf "Not found (%s): %s" error message)
44
+
| UseDpopNonceError ->
45
+
Some "Use DPoP nonce"
46
+
| _ ->
47
+
None
48
+
35
49
let exn_to_response exn =
36
50
let format_response error msg status =
37
51
Dream.json ~status @@ Yojson.Safe.to_string
+85
pegasus/lib/jwt.ml
+85
pegasus/lib/jwt.ml
···
120
120
let exp = now_s + Defaults.service_token_exp in
121
121
let payload = service_jwt_to_yojson {iss= did; aud; lxm; exp} in
122
122
sign_jwt payload ~signing_key
123
+
124
+
type verify_jwt_error =
125
+
| AuthRequired of string
126
+
| ExpiredToken of string
127
+
| InvalidToken of string
128
+
| InternalError of string
129
+
130
+
(* if no did is provided, iss did will be assumed to be correct *)
131
+
let verify_service_jwt ~nsid ?did ~(verify_sig : string -> string -> 'a) token =
132
+
match decode_jwt token with
133
+
| Error e ->
134
+
Lwt.return_error @@ AuthRequired e
135
+
| Ok (_header, payload) -> (
136
+
try
137
+
let open Yojson.Safe.Util in
138
+
let iss = payload |> member "iss" |> to_string in
139
+
let aud = payload |> member "aud" |> to_string in
140
+
let exp = payload |> member "exp" |> to_int in
141
+
let lxm = payload |> member "lxm" |> to_string_option in
142
+
let now = int_of_float (Unix.gettimeofday ()) in
143
+
if exp < now then Lwt.return_error @@ ExpiredToken "token expired"
144
+
else if aud <> Env.did then
145
+
Lwt.return_error
146
+
@@ InvalidToken "jwt audience does not match service did"
147
+
else
148
+
let iss_did =
149
+
match String.split_on_char '#' iss with did :: _ -> did | [] -> iss
150
+
in
151
+
if did <> None && Some iss_did <> did then
152
+
Lwt.return_error @@ InvalidToken "jwt issuer does not match did"
153
+
else
154
+
match lxm with
155
+
| Some l when l <> nsid && l <> "*" ->
156
+
Lwt.return_error
157
+
@@ InvalidToken ("jwt lxm " ^ l ^ " does not match " ^ nsid)
158
+
| _ -> (
159
+
let did = Option.value did ~default:iss_did in
160
+
match%lwt Id_resolver.Did.resolve did with
161
+
| Error e ->
162
+
Dream.debug (fun log ->
163
+
log "failed to resolve did %s: %s" did e ) ;
164
+
Lwt.return_error
165
+
@@ InternalError "could not resolve jwt issuer did"
166
+
| Ok did_doc -> (
167
+
match
168
+
Id_resolver.Did.Document.get_verification_key did_doc
169
+
"#atproto"
170
+
with
171
+
| None ->
172
+
Lwt.return_error
173
+
@@ InternalError "missing or bad key in issuer did doc"
174
+
| Some pubkey_multibase -> (
175
+
match%lwt verify_sig did pubkey_multibase with
176
+
| Ok creds ->
177
+
Lwt.return_ok creds
178
+
| Error _ -> (
179
+
(* try again, skipping cache in case of key rotation *)
180
+
match%lwt
181
+
Id_resolver.Did.resolve ~skip_cache:true did
182
+
with
183
+
| Error _ ->
184
+
Lwt.return_error
185
+
@@ InvalidToken
186
+
"jwt signature does not match jwt issuer"
187
+
| Ok fresh_doc -> (
188
+
match
189
+
Id_resolver.Did.Document.get_verification_key fresh_doc
190
+
"#atproto"
191
+
with
192
+
| None ->
193
+
Lwt.return_error
194
+
@@ InvalidToken
195
+
"jwt signature does not match jwt issuer"
196
+
| Some fresh_pubkey_multibase
197
+
when fresh_pubkey_multibase = pubkey_multibase ->
198
+
Lwt.return_error
199
+
@@ InvalidToken
200
+
"jwt signature does not match jwt issuer"
201
+
| Some fresh_pubkey_multibase -> (
202
+
match%lwt verify_sig did fresh_pubkey_multibase with
203
+
| Ok creds ->
204
+
Lwt.return_ok creds
205
+
| Error e ->
206
+
Lwt.return_error @@ InternalError e ) ) ) ) ) )
207
+
with _ -> Lwt.return_error @@ InvalidToken "malformed service jwt" )
+32
pegasus/lib/plc.ml
+32
pegasus/lib/plc.ml
···
165
165
let%lwt body_str = Body.to_string body in
166
166
Lwt.return_error (Http.Status.to_int res.status, body_str)
167
167
168
+
let validate_operation ~handle ?signing_key (op : signed_operation) =
169
+
let pds_pubkey =
170
+
Env.rotation_key |> Kleidos.derive_pubkey |> Kleidos.pubkey_to_did_key
171
+
in
172
+
match op with
173
+
| Operation op -> (
174
+
if not (List.mem pds_pubkey op.rotation_keys) then
175
+
Error "rotation keys must include the PDS public key"
176
+
else
177
+
match List.assoc_opt "atproto_pds" op.services with
178
+
| Some {type'; endpoint}
179
+
when type' <> "AtprotoPersonalDataServer"
180
+
|| endpoint <> Env.host_endpoint ->
181
+
Error "invalid atproto_pds service"
182
+
| _ ->
183
+
let actor_pubkey =
184
+
signing_key
185
+
|> Option.map (fun sk ->
186
+
sk |> Kleidos.parse_multikey_str |> Kleidos.derive_pubkey
187
+
|> Kleidos.pubkey_to_did_key )
188
+
in
189
+
if
190
+
actor_pubkey <> None
191
+
&& List.assoc_opt "atproto" op.verification_methods
192
+
<> actor_pubkey
193
+
then Error "incorrect atproto signing key"
194
+
else if List.hd op.also_known_as <> "at://" ^ handle then
195
+
Error "incorrect handle"
196
+
else Ok () )
197
+
| Tombstone _ ->
198
+
Ok ()
199
+
168
200
let did_of_operation operation : string =
169
201
let cbor = signed_operation_to_yojson operation |> Dag_cbor.encode_yojson in
170
202
let digest = Digestif.SHA256.(cbor |> digest_bytes |> to_raw_string) in
+4
-3
pegasus/lib/repository.ml
+4
-3
pegasus/lib/repository.ml
···
146
146
type t =
147
147
{ key: Kleidos.key
148
148
; did: string
149
+
; actor: Data_store.Types.actor
149
150
; db: User_store.t
150
151
; mutable commit: (Cid.t * signed_commit) option }
151
152
···
422
423
Errors.invalid_request ~name:"RepoNotFound"
423
424
"your princess is in another castle"
424
425
in
425
-
let%lwt {signing_key; _} =
426
+
let%lwt actor =
426
427
match%lwt Data_store.get_actor_by_identifier did ds_conn with
427
428
| Some actor when ensure_active = false || actor.deactivated_at = None ->
428
429
Lwt.return actor
···
432
433
| None ->
433
434
failwith ("failed to retrieve actor for " ^ did)
434
435
in
435
-
let key = Kleidos.parse_multikey_str signing_key in
436
+
let key = Kleidos.parse_multikey_str actor.signing_key in
436
437
let%lwt commit = User_store.get_commit user_db in
437
-
Lwt.return {key; did; db= user_db; commit}
438
+
Lwt.return {key; did; actor; db= user_db; commit}
438
439
439
440
let export_car t : Car.stream Lwt.t =
440
441
let%lwt root, commit =
+7
pegasus/lib/util.ml
+7
pegasus/lib/util.ml
···
460
460
headers )
461
461
(Http.Header.init ()) headers
462
462
463
+
let str_contains ~affix str =
464
+
let re = Str.regexp_string affix in
465
+
try
466
+
ignore (Str.search_forward re str 0) ;
467
+
true
468
+
with Not_found -> false
469
+
463
470
module type Template = sig
464
471
type props
465
472
+5
public/main.css
+5
public/main.css
···
64
64
--shadow-shimmer: inset 0 0 1em #90bbeea6;
65
65
--shadow-glow: inset 0 0 1.25em #2d37ba80;
66
66
--shadow-bleed: inset 0 0 1.25em #db4c6473;
67
+
--shadow-elixir:
68
+
0 0 3px 1px rgba(166, 144, 241, 0.25),
69
+
-1px 2px 8px 0 rgba(141, 109, 216, 0.7) inset,
70
+
1px 3px 8px 0 rgba(184, 176, 219, 0.8) inset,
71
+
2px -2px 8px 0 rgba(68, 57, 119, 0.9) inset;
67
72
}