objective categorical abstract machine language personal data server
65
fork

Configure Feed

Select the types of activity you want to include in your feed.

Update migration logic to use hermes

futurGH e2053c26 1a26cc29

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