-2044

pegasus/lib/api/account_/migrate.ml

reviewed

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

+1007

pegasus/lib/api/account_/migrate/migrate.ml

reviewed

··· 1 1 + (* account migration handlers *) 2 2 + 3 3 + let make_props ~csrf_token ~invite_required ~hostname 4 4 + ?(step = "enter_credentials") ?did ?handle ?old_pds ?identifier ?invite_code 5 5 + ?(blobs_imported = 0) ?(blobs_failed = 0) ?(old_account_deactivated = false) 6 6 + ?old_account_deactivation_error ?error ?message () : 7 7 + Frontend.MigratePage.props = 8 8 + { csrf_token 9 9 + ; invite_required 10 10 + ; hostname 11 11 + ; step 12 12 + ; did 13 13 + ; handle 14 14 + ; old_pds 15 15 + ; identifier 16 16 + ; invite_code 17 17 + ; blobs_imported 18 18 + ; blobs_failed 19 19 + ; old_account_deactivated 20 20 + ; old_account_deactivation_error 21 21 + ; error 22 22 + ; message } 23 23 + 24 24 + let render_error ~csrf_token ~invite_required ~hostname 25 25 + ?(step = "enter_credentials") ?did ?handle ?old_pds ?identifier ?invite_code 26 26 + error = 27 27 + Util.render_html ~status:`Bad_Request ~title:"Migrate Account" 28 28 + (module Frontend.MigratePage) 29 29 + ~props: 30 30 + (make_props ~csrf_token ~invite_required ~hostname ~step ?did ?handle 31 31 + ?old_pds ?identifier ?invite_code ~error () ) 32 32 + 33 33 + (* render_error is passed to step fns with some parameters filled in, this is what remains *) 34 34 + type render_err = 35 35 + ?step:string 36 36 + -> ?did:string 37 37 + -> ?handle:string 38 38 + -> ?old_pds:string 39 39 + -> ?identifier:string 40 40 + -> ?invite_code:string 41 41 + -> string 42 42 + -> Dream.response Lwt.t 43 43 + 44 44 + (* transition to plc token step after data import *) 45 45 + let transition_to_plc_token_step ctx ~did ~handle ~old_pds ~access_jwt 46 46 + ~refresh_jwt ~email ~blobs_imported ~blobs_failed = 47 47 + let csrf_token = Dream.csrf_token ctx.Xrpc.req in 48 48 + let invite_required = Env.invite_required in 49 49 + let hostname = Env.hostname in 50 50 + (* import preferences before transitioning *) 51 51 + let%lwt () = 52 52 + match%lwt Remote.fetch_preferences ~pds_endpoint:old_pds ~access_jwt with 53 53 + | Ok prefs -> 54 54 + Data_store.put_preferences ~did ~prefs ctx.db 55 55 + | _ -> 56 56 + Lwt.return_unit 57 57 + in 58 58 + (* don't need plc step for did:web *) 59 59 + if String.starts_with ~prefix:"did:web:" did then 60 60 + match%lwt State.check_identity_updated did with 61 61 + | Ok true -> 62 62 + let%lwt () = Ops.activate_account did ctx.db in 63 63 + let%lwt () = Session.log_in_did ctx.req did in 64 64 + let%lwt deactivation_result = 65 65 + Remote.deactivate_account ~pds_endpoint:old_pds ~access_jwt 66 66 + in 67 67 + let old_account_deactivated, old_account_deactivation_error = 68 68 + match deactivation_result with 69 69 + | Ok () -> 70 70 + (true, None) 71 71 + | Error e -> 72 72 + Dream.warning (fun log -> 73 73 + log "migration %s: failed to deactivate old account: %s" did e ) ; 74 74 + (false, Some e) 75 75 + in 76 76 + Util.render_html ~title:"Migrate Account" 77 77 + (module Frontend.MigratePage) 78 78 + ~props: 79 79 + (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" 80 80 + ~did ~handle ~blobs_imported ~blobs_failed 81 81 + ~old_account_deactivated ?old_account_deactivation_error 82 82 + ~message: 83 83 + "Your account has been successfully migrated! Your did:web \ 84 84 + identity is pointing to this PDS." 85 85 + () ) 86 86 + | _ -> 87 87 + Util.render_html ~title:"Migrate Account" 88 88 + (module Frontend.MigratePage) 89 89 + ~props: 90 90 + (make_props ~csrf_token ~invite_required ~hostname ~step:"error" 91 91 + ~did ~handle ~blobs_imported ~blobs_failed 92 92 + ~error: 93 93 + (Printf.sprintf 94 94 + "Your account uses did:web which requires manual \ 95 95 + configuration. Please update your .well-known/did.json at \ 96 96 + %s to point to this PDS (%s), then try resuming the \ 97 97 + migration." 98 98 + (String.sub did 8 (String.length did - 8)) 99 99 + Env.host_endpoint ) 100 100 + () ) 101 101 + else 102 102 + match%lwt 103 103 + Remote.request_plc_signature ~pds_endpoint:old_pds ~access_jwt 104 104 + with 105 105 + | Error e -> 106 106 + Dream.warning (fun log -> 107 107 + log "migration %s: failed to request PLC signature: %s" did e ) ; 108 108 + let%lwt () = 109 109 + State.set ctx.req 110 110 + { did 111 111 + ; handle 112 112 + ; old_pds 113 113 + ; access_jwt 114 114 + ; refresh_jwt 115 115 + ; email 116 116 + ; blobs_imported 117 117 + ; blobs_failed 118 118 + ; blobs_cursor= "" 119 119 + ; plc_requested= true } 120 120 + in 121 121 + Util.render_html ~title:"Migrate Account" 122 122 + (module Frontend.MigratePage) 123 123 + ~props: 124 124 + (make_props ~csrf_token ~invite_required ~hostname 125 125 + ~step:"enter_plc_token" ~did ~handle ~old_pds ~blobs_imported 126 126 + ~blobs_failed 127 127 + ~message: 128 128 + "Data import complete! Check your email for a PLC \ 129 129 + confirmation code." 130 130 + ~error: 131 131 + ( "Note: Could not automatically request PLC signature: " ^ e 132 132 + ^ ". You may need to request it manually from your old PDS." ) 133 133 + () ) 134 134 + | Ok () -> 135 135 + let%lwt () = 136 136 + State.set ctx.req 137 137 + { did 138 138 + ; handle 139 139 + ; old_pds 140 140 + ; access_jwt 141 141 + ; refresh_jwt 142 142 + ; email 143 143 + ; blobs_imported 144 144 + ; blobs_failed 145 145 + ; blobs_cursor= "" 146 146 + ; plc_requested= true } 147 147 + in 148 148 + Util.render_html ~title:"Migrate Account" 149 149 + (module Frontend.MigratePage) 150 150 + ~props: 151 151 + (make_props ~csrf_token ~invite_required ~hostname 152 152 + ~step:"enter_plc_token" ~did ~handle ~old_pds ~blobs_imported 153 153 + ~blobs_failed 154 154 + ~message: 155 155 + "Data import complete! Check your email for a PLC \ 156 156 + confirmation code." 157 157 + () ) 158 158 + 159 159 + (* try to deactivate old account, refreshing token if needed *) 160 160 + let deactivate_old_account_with_refresh ~old_pds ~access_jwt ~refresh_jwt = 161 161 + match%lwt Remote.deactivate_account ~pds_endpoint:old_pds ~access_jwt with 162 162 + | Ok () -> 163 163 + Lwt.return_ok () 164 164 + | Error e 165 165 + when Util.str_contains ~affix:"401" e 166 166 + || Util.str_contains ~affix:"Unauthorized" e -> ( 167 167 + match%lwt Remote.refresh_session ~pds_endpoint:old_pds ~refresh_jwt with 168 168 + | Ok tokens -> 169 169 + Remote.deactivate_account ~pds_endpoint:old_pds 170 170 + ~access_jwt:tokens.access_jwt 171 171 + | Error refresh_err -> 172 172 + Lwt.return_error 173 173 + (Printf.sprintf "Token expired and refresh failed: %s" refresh_err) ) 174 174 + | Error e -> 175 175 + Lwt.return_error e 176 176 + 177 177 + let rec handle_start_migration ctx ~csrf_token ~invite_required ~hostname 178 178 + ~(render_err : render_err) fields = 179 179 + let identifier = 180 180 + List.assoc_opt "identifier" fields 181 181 + |> Option.value ~default:"" |> String.trim 182 182 + in 183 183 + let password = List.assoc_opt "password" fields |> Option.value ~default:"" in 184 184 + let invite_code = 185 185 + List.assoc_opt "invite_code" fields 186 186 + |> Option.map String.trim 187 187 + |> fun c -> 188 188 + Option.bind c (fun s -> if String.length s = 0 then None else Some s) 189 189 + in 190 190 + (* debug steps for testing *) 191 191 + let debug_step = 192 192 + match invite_code with 193 193 + | Some "DEBUG:RESUME" -> 194 194 + Some "resume_available" 195 195 + | Some "DEBUG:IMPORT" -> 196 196 + Some "importing_data" 197 197 + | Some "DEBUG:PLC" -> 198 198 + Some "enter_plc_token" 199 199 + | Some "DEBUG:COMPLETE" -> 200 200 + Some "complete" 201 201 + | Some "DEBUG:COMPLETE_FAIL" -> 202 202 + Some "complete_deactivation_failed" 203 203 + | Some "DEBUG:ERROR" -> 204 204 + Some "error" 205 205 + | _ -> 206 206 + None 207 207 + in 208 208 + match debug_step with 209 209 + | Some step -> 210 210 + handle_debug_step ctx ~csrf_token ~invite_required ~hostname step 211 211 + | None -> 212 212 + if String.length identifier = 0 then 213 213 + render_err "Please enter your handle or DID" 214 214 + else if String.length password = 0 then 215 215 + render_err "Please enter your password" 216 216 + else 217 217 + perform_migration ctx ~csrf_token ~invite_required ~hostname ~render_err 218 218 + ~identifier ~password ~invite_code 219 219 + 220 220 + and handle_debug_step (ctx : Xrpc.context) ~csrf_token ~invite_required 221 221 + ~hostname step = 222 222 + match step with 223 223 + | "resume_available" -> 224 224 + Util.render_html ~title:"Migrate Account" 225 225 + (module Frontend.MigratePage) 226 226 + ~props: 227 227 + (make_props ~csrf_token ~invite_required ~hostname 228 228 + ~step:"resume_available" ~did:"did:plc:a1b2c3" ~handle:"test.user" 229 229 + ~old_pds:"https://bsky.social" () ) 230 230 + | "importing_data" -> 231 231 + let%lwt () = 232 232 + State.set ctx.req 233 233 + { did= "did:plc:a1b2c3" 234 234 + ; handle= "test.user" 235 235 + ; old_pds= "https://bsky.social" 236 236 + ; access_jwt= "test_access_jwt" 237 237 + ; refresh_jwt= "test_refresh_jwt" 238 238 + ; email= "test@example.com" 239 239 + ; blobs_imported= 42 240 240 + ; blobs_failed= 3 241 241 + ; blobs_cursor= "" 242 242 + ; plc_requested= false } 243 243 + in 244 244 + Util.render_html ~title:"Migrate Account" 245 245 + (module Frontend.MigratePage) 246 246 + ~props: 247 247 + (make_props ~csrf_token ~invite_required ~hostname 248 248 + ~step:"importing_data" ~did:"did:plc:a1b2c3" ~handle:"test.user" 249 249 + ~old_pds:"https://bsky.social" ~blobs_imported:42 ~blobs_failed:3 250 250 + () ) 251 251 + | "enter_plc_token" -> 252 252 + let%lwt () = 253 253 + State.set ctx.req 254 254 + { did= "did:plc:a1b2c3" 255 255 + ; handle= "test.user" 256 256 + ; old_pds= "https://bsky.social" 257 257 + ; access_jwt= "test_access_jwt" 258 258 + ; refresh_jwt= "test_refresh_jwt" 259 259 + ; email= "test@example.com" 260 260 + ; blobs_imported= 100 261 261 + ; blobs_failed= 0 262 262 + ; blobs_cursor= "" 263 263 + ; plc_requested= true } 264 264 + in 265 265 + Util.render_html ~title:"Migrate Account" 266 266 + (module Frontend.MigratePage) 267 267 + ~props: 268 268 + (make_props ~csrf_token ~invite_required ~hostname 269 269 + ~step:"enter_plc_token" ~did:"did:plc:testuser123" 270 270 + ~handle:"test.user" ~old_pds:"https://bsky.social" 271 271 + ~blobs_imported:100 ~blobs_failed:0 272 272 + ~message: 273 273 + "Data import complete! Check your email for a PLC confirmation \ 274 274 + code." 275 275 + () ) 276 276 + | "complete" -> 277 277 + Util.render_html ~title:"Migrate Account" 278 278 + (module Frontend.MigratePage) 279 279 + ~props: 280 280 + (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" 281 281 + ~did:"did:plc:testuser123" ~handle:"test.user" ~blobs_imported:100 282 282 + ~blobs_failed:0 ~old_account_deactivated:true 283 283 + ~message:"Your account has been successfully migrated!" () ) 284 284 + | "complete_deactivation_failed" -> 285 285 + Util.render_html ~title:"Migrate Account" 286 286 + (module Frontend.MigratePage) 287 287 + ~props: 288 288 + (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" 289 289 + ~did:"did:plc:testuser123" ~handle:"test.user" ~blobs_imported:95 290 290 + ~blobs_failed:5 ~old_account_deactivated:false 291 291 + ~old_account_deactivation_error: 292 292 + "Failed to deactivate old account (401): Unauthorized" 293 293 + ~message:"Your account has been successfully migrated!" () ) 294 294 + | "error" | _ -> 295 295 + Util.render_html ~title:"Migrate Account" 296 296 + (module Frontend.MigratePage) 297 297 + ~props: 298 298 + (make_props ~csrf_token ~invite_required ~hostname ~step:"error" ()) 299 299 + 300 300 + and perform_migration ctx ~csrf_token ~invite_required ~hostname 301 301 + ~(render_err : render_err) ~identifier ~password ~invite_code = 302 302 + match%lwt Remote.resolve_identity identifier with 303 303 + | Error e -> 304 304 + render_err e 305 305 + | Ok (did, handle, old_pds) -> ( 306 306 + match%lwt 307 307 + Remote.create_session ~pds_endpoint:old_pds ~identifier ~password () 308 308 + with 309 309 + | Remote.AuthError e -> 310 310 + render_err e 311 311 + | Remote.AuthNeeds2FA -> 312 312 + Util.render_html ~title:"Migrate Account" 313 313 + (module Frontend.MigratePage) 314 314 + ~props: 315 315 + (make_props ~csrf_token ~invite_required ~hostname ~step:"enter_2fa" 316 316 + ~identifier ~old_pds ?invite_code () ) 317 317 + | Remote.AuthSuccess session -> ( 318 318 + match%lwt 319 319 + Remote.get_session ~pds_endpoint:old_pds ~access_jwt:session.access_jwt 320 320 + with 321 321 + | Error e -> 322 322 + render_err ("Failed to get account info: " ^ e) 323 323 + | Ok session_info -> ( 324 324 + let is_active = 325 325 + match session_info.active with Some false -> false | _ -> true 326 326 + in 327 327 + if not is_active then 328 328 + render_err 329 329 + "This account is already deactivated. Cannot migrate a \ 330 330 + deactivated account." 331 331 + else 332 332 + match%lwt 333 333 + Remote.get_service_auth ~pds_endpoint:old_pds 334 334 + ~access_jwt:session.access_jwt 335 335 + with 336 336 + | Error e -> 337 337 + render_err ("Failed to get service authorization: " ^ e) 338 338 + | Ok service_auth_token -> ( 339 339 + let email = 340 340 + match session_info.email with 341 341 + | Some e when String.length e > 0 -> 342 342 + e 343 343 + | _ -> 344 344 + Printf.sprintf "%s@%s" did Env.hostname 345 345 + in 346 346 + match%lwt 347 347 + Ops.create_account ~email ~handle ~password ~did 348 348 + ~service_auth_token ?invite_code ctx.db 349 349 + with 350 350 + | Error e when String.starts_with ~prefix:"RESUMABLE:" e -> 351 351 + handle_resumable_migration ctx ~csrf_token ~invite_required 352 352 + ~hostname ~render_err ~did ~handle ~old_pds ~session 353 353 + ~email 354 354 + | Error e -> 355 355 + render_err e 356 356 + | Ok _signing_key_did -> 357 357 + perform_data_import ctx ~csrf_token ~invite_required 358 358 + ~hostname ~render_err ~did ~handle ~old_pds ~session 359 359 + ~email ) ) ) ) 360 360 + 361 361 + and handle_resumable_migration ctx ~csrf_token ~invite_required ~hostname 362 362 + ~(render_err : render_err) ~did ~handle ~old_pds ~session ~email = 363 363 + match%lwt State.check_resume_state ~did ctx.db with 364 364 + | Error e -> 365 365 + render_err ~did ~handle ~old_pds e 366 366 + | Ok State.AlreadyActive -> 367 367 + let%lwt () = Session.log_in_did ctx.req did in 368 368 + Util.render_html ~title:"Migrate Account" 369 369 + (module Frontend.MigratePage) 370 370 + ~props: 371 371 + (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" 372 372 + ~did ~handle 373 373 + ~message:"Your account is already active! You have been logged in." 374 374 + () ) 375 375 + | Ok State.NeedsActivation -> 376 376 + let%lwt () = Ops.activate_account did ctx.db in 377 377 + let%lwt () = Session.log_in_did ctx.req did in 378 378 + let%lwt deactivation_result = 379 379 + deactivate_old_account_with_refresh ~old_pds 380 380 + ~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt 381 381 + in 382 382 + let old_account_deactivated, old_account_deactivation_error = 383 383 + match deactivation_result with 384 384 + | Ok () -> 385 385 + (true, None) 386 386 + | Error err -> 387 387 + Dream.warning (fun log -> 388 388 + log "migration %s: failed to deactivate old account: %s" did err ) ; 389 389 + (false, Some err) 390 390 + in 391 391 + Util.render_html ~title:"Migrate Account" 392 392 + (module Frontend.MigratePage) 393 393 + ~props: 394 394 + (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" 395 395 + ~did ~handle ~old_account_deactivated 396 396 + ?old_account_deactivation_error 397 397 + ~message: 398 398 + "Your account has been activated! Your identity is pointing to \ 399 399 + this PDS." 400 400 + () ) 401 401 + | Ok State.NeedsPlcUpdate -> 402 402 + transition_to_plc_token_step ctx ~did ~handle ~old_pds 403 403 + ~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt ~email 404 404 + ~blobs_imported:0 ~blobs_failed:0 405 405 + | Ok State.NeedsRepoImport | Ok State.NeedsBlobImport -> ( 406 406 + match%lwt 407 407 + Remote.fetch_repo ~pds_endpoint:old_pds ~access_jwt:session.access_jwt 408 408 + ~did 409 409 + with 410 410 + | Error err -> 411 411 + render_err ~did ~handle ~old_pds ("Failed to fetch repository: " ^ err) 412 412 + | Ok car_data -> ( 413 413 + match%lwt Ops.import_repo ~did ~car_data with 414 414 + | Error err -> 415 415 + render_err ~did ~handle ~old_pds err 416 416 + | Ok () -> 417 417 + transition_to_plc_token_step ctx ~did ~handle ~old_pds 418 418 + ~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt 419 419 + ~email ~blobs_imported:0 ~blobs_failed:0 ) ) 420 420 + 421 421 + and perform_data_import ctx ~csrf_token ~invite_required ~hostname ~render_err 422 422 + ~did ~handle ~old_pds ~session ~email = 423 423 + match%lwt 424 424 + Remote.fetch_repo ~pds_endpoint:old_pds ~access_jwt:session.access_jwt ~did 425 425 + with 426 426 + | Error e -> 427 427 + render_err ("Failed to fetch repository: " ^ e) 428 428 + | Ok car_data -> ( 429 429 + match%lwt Ops.import_repo ~did ~car_data with 430 430 + | Error e -> 431 431 + render_err e 432 432 + | Ok () -> ( 433 433 + let%lwt () = 434 434 + match%lwt Ops.check_account_status ~did with 435 435 + | Ok status -> 436 436 + Dream.info (fun log -> 437 437 + log 438 438 + "migration %s: repo imported, indexed_records=%d, \ 439 439 + expected_blobs=%d" 440 440 + did status.indexed_records status.expected_blobs ) ; 441 441 + Lwt.return_unit 442 442 + | Error e -> 443 443 + Dream.warning (fun log -> 444 444 + log "migration %s: failed to check account status: %s" did e ) ; 445 445 + Lwt.return_unit 446 446 + in 447 447 + match%lwt Ops.list_missing_blobs ~did ~limit:50 () with 448 448 + | Error e -> 449 449 + Dream.warning (fun log -> 450 450 + log "migration %s: failed to list missing blobs: %s" did e ) ; 451 451 + transition_to_plc_token_step ctx ~did ~handle ~old_pds 452 452 + ~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt 453 453 + ~email ~blobs_imported:0 ~blobs_failed:0 454 454 + | Ok (missing_cids, next_cursor) -> 455 455 + if List.length missing_cids = 0 then 456 456 + transition_to_plc_token_step ctx ~did ~handle ~old_pds 457 457 + ~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt 458 458 + ~email ~blobs_imported:0 ~blobs_failed:0 459 459 + else 460 460 + let%lwt imported, failed = 461 461 + Ops.import_blobs_batch ~pds_endpoint:old_pds 462 462 + ~access_jwt:session.access_jwt ~did ~cids:missing_cids 463 463 + in 464 464 + let cursor = Option.value ~default:"" next_cursor in 465 465 + if String.length cursor = 0 then 466 466 + transition_to_plc_token_step ctx ~did ~handle ~old_pds 467 467 + ~access_jwt:session.access_jwt 468 468 + ~refresh_jwt:session.refresh_jwt ~email 469 469 + ~blobs_imported:imported ~blobs_failed:failed 470 470 + else 471 471 + let%lwt () = 472 472 + State.set ctx.req 473 473 + { did 474 474 + ; handle 475 475 + ; old_pds 476 476 + ; access_jwt= session.access_jwt 477 477 + ; refresh_jwt= session.refresh_jwt 478 478 + ; email 479 479 + ; blobs_imported= imported 480 480 + ; blobs_failed= failed 481 481 + ; blobs_cursor= cursor 482 482 + ; plc_requested= false } 483 483 + in 484 484 + Util.render_html ~title:"Migrate Account" 485 485 + (module Frontend.MigratePage) 486 486 + ~props: 487 487 + (make_props ~csrf_token ~invite_required ~hostname 488 488 + ~step:"importing_data" ~did ~handle ~old_pds 489 489 + ~blobs_imported:imported ~blobs_failed:failed () ) ) ) 490 490 + 491 491 + and handle_continue_blobs (ctx : Xrpc.context) ~csrf_token ~invite_required 492 492 + ~hostname ~render_err = 493 493 + match State.get ctx.req with 494 494 + | None -> 495 495 + render_err "Migration state not found. Please start over." 496 496 + | Some state -> ( 497 497 + let%lwt state = 498 498 + if Remote.jwt_needs_refresh state.access_jwt then ( 499 499 + match%lwt 500 500 + Remote.refresh_session ~pds_endpoint:state.old_pds 501 501 + ~refresh_jwt:state.refresh_jwt 502 502 + with 503 503 + | Ok tokens -> 504 504 + let new_state = 505 505 + { state with 506 506 + access_jwt= tokens.access_jwt 507 507 + ; refresh_jwt= tokens.refresh_jwt } 508 508 + in 509 509 + let%lwt () = State.set ctx.req new_state in 510 510 + Lwt.return new_state 511 511 + | Error e -> 512 512 + Dream.warning (fun log -> 513 513 + log 514 514 + "migration %s: token refresh failed, continuing with old \ 515 515 + token: %s" 516 516 + state.did e ) ; 517 517 + Lwt.return state ) 518 518 + else Lwt.return state 519 519 + in 520 520 + let cursor = 521 521 + if String.length state.blobs_cursor > 0 then Some state.blobs_cursor 522 522 + else None 523 523 + in 524 524 + match%lwt Ops.list_missing_blobs ~did:state.did ~limit:50 ?cursor () with 525 525 + | Error e -> 526 526 + Dream.warning (fun log -> 527 527 + log "migration %s: failed to list missing blobs: %s" state.did e ) ; 528 528 + transition_to_plc_token_step ctx ~did:state.did ~handle:state.handle 529 529 + ~old_pds:state.old_pds ~access_jwt:state.access_jwt 530 530 + ~refresh_jwt:state.refresh_jwt ~email:state.email 531 531 + ~blobs_imported:state.blobs_imported 532 532 + ~blobs_failed:state.blobs_failed 533 533 + | Ok (missing_cids, next_cursor) -> 534 534 + if List.length missing_cids = 0 then 535 535 + transition_to_plc_token_step ctx ~did:state.did ~handle:state.handle 536 536 + ~old_pds:state.old_pds ~access_jwt:state.access_jwt 537 537 + ~refresh_jwt:state.refresh_jwt ~email:state.email 538 538 + ~blobs_imported:state.blobs_imported 539 539 + ~blobs_failed:state.blobs_failed 540 540 + else 541 541 + let%lwt imported, failed = 542 542 + Ops.import_blobs_batch ~pds_endpoint:state.old_pds 543 543 + ~access_jwt:state.access_jwt ~did:state.did ~cids:missing_cids 544 544 + in 545 545 + let new_imported = state.blobs_imported + imported in 546 546 + let new_failed = state.blobs_failed + failed in 547 547 + let new_cursor = Option.value ~default:"" next_cursor in 548 548 + if String.length new_cursor = 0 then 549 549 + transition_to_plc_token_step ctx ~did:state.did 550 550 + ~handle:state.handle ~old_pds:state.old_pds 551 551 + ~access_jwt:state.access_jwt ~refresh_jwt:state.refresh_jwt 552 552 + ~email:state.email ~blobs_imported:new_imported 553 553 + ~blobs_failed:new_failed 554 554 + else 555 555 + let%lwt () = 556 556 + State.set ctx.req 557 557 + { state with 558 558 + blobs_imported= new_imported 559 559 + ; blobs_failed= new_failed 560 560 + ; blobs_cursor= new_cursor } 561 561 + in 562 562 + Util.render_html ~title:"Migrate Account" 563 563 + (module Frontend.MigratePage) 564 564 + ~props: 565 565 + (make_props ~csrf_token ~invite_required ~hostname 566 566 + ~step:"importing_data" ~did:state.did ~handle:state.handle 567 567 + ~old_pds:state.old_pds ~blobs_imported:new_imported 568 568 + ~blobs_failed:new_failed () ) ) 569 569 + 570 570 + and handle_submit_plc_token (ctx : Xrpc.context) ~csrf_token ~invite_required 571 571 + ~hostname ~(render_err : render_err) fields = 572 572 + match State.get ctx.req with 573 573 + | None -> 574 574 + render_err "Migration state not found. Please start over." 575 575 + | Some state -> ( 576 576 + let plc_token = 577 577 + List.assoc_opt "plc_token" fields 578 578 + |> Option.value ~default:"" |> String.trim 579 579 + in 580 580 + if String.length plc_token = 0 then 581 581 + render_err ~step:"enter_plc_token" ~did:state.did ~handle:state.handle 582 582 + ~old_pds:state.old_pds "Please enter the PLC token from your email" 583 583 + else 584 584 + let%lwt old_pds_keys = 585 585 + match%lwt 586 586 + Remote.get_recommended_credentials ~pds_endpoint:state.old_pds 587 587 + ~access_jwt:state.access_jwt 588 588 + with 589 589 + | Ok creds -> 590 590 + Lwt.return creds.rotation_keys 591 591 + | Error e -> 592 592 + Dream.warning (fun log -> 593 593 + log "migration %s: failed to get old PDS credentials: %s" 594 594 + state.did e ) ; 595 595 + Lwt.return [] 596 596 + in 597 597 + let%lwt current_keys = 598 598 + match%lwt Remote.get_plc_rotation_keys ~did:state.did with 599 599 + | Ok keys -> 600 600 + Lwt.return keys 601 601 + | Error _ -> 602 602 + Lwt.return [] 603 603 + in 604 604 + let keys_to_preserve = 605 605 + List.filter (fun k -> not (List.mem k old_pds_keys)) current_keys 606 606 + in 607 607 + match%lwt 608 608 + Ops.get_recommended_did_credentials state.did ctx.db 609 609 + ~extra_rotation_keys:keys_to_preserve 610 610 + with 611 611 + | Error e -> 612 612 + render_err ~step:"enter_plc_token" ~did:state.did 613 613 + ~handle:state.handle ~old_pds:state.old_pds 614 614 + ("Failed to get credentials: " ^ e) 615 615 + | Ok credentials -> ( 616 616 + match%lwt 617 617 + Remote.sign_plc_operation ~pds_endpoint:state.old_pds 618 618 + ~access_jwt:state.access_jwt ~token:plc_token ~credentials 619 619 + with 620 620 + | Error e -> 621 621 + render_err ~step:"enter_plc_token" ~did:state.did 622 622 + ~handle:state.handle ~old_pds:state.old_pds 623 623 + ("Failed to sign PLC operation: " ^ e) 624 624 + | Ok signed_operation -> ( 625 625 + match%lwt 626 626 + Ops.submit_plc_operation ~did:state.did ~handle:state.handle 627 627 + ~operation:signed_operation ctx.db 628 628 + with 629 629 + | Error e -> 630 630 + render_err ~step:"enter_plc_token" ~did:state.did 631 631 + ~handle:state.handle ~old_pds:state.old_pds 632 632 + ("Failed to submit PLC operation: " ^ e) 633 633 + | Ok () -> 634 634 + let%lwt () = 635 635 + match%lwt Ops.check_account_status ~did:state.did with 636 636 + | Ok status -> 637 637 + Dream.info (fun log -> 638 638 + log 639 639 + "migration %s: activating account, \ 640 640 + imported_blobs=%d/%d" 641 641 + state.did status.imported_blobs 642 642 + status.expected_blobs ) ; 643 643 + Lwt.return_unit 644 644 + | Error e -> 645 645 + Dream.warning (fun log -> 646 646 + log 647 647 + "migration %s: failed to check status before \ 648 648 + activation: %s" 649 649 + state.did e ) ; 650 650 + Lwt.return_unit 651 651 + in 652 652 + let%lwt () = Ops.activate_account state.did ctx.db in 653 653 + let%lwt () = Session.log_in_did ctx.req state.did in 654 654 + let%lwt () = State.clear ctx.req in 655 655 + let%lwt deactivation_result = 656 656 + deactivate_old_account_with_refresh ~old_pds:state.old_pds 657 657 + ~access_jwt:state.access_jwt ~refresh_jwt:state.refresh_jwt 658 658 + in 659 659 + let old_account_deactivated, old_account_deactivation_error = 660 660 + match deactivation_result with 661 661 + | Ok () -> 662 662 + (true, None) 663 663 + | Error e -> 664 664 + Dream.warning (fun log -> 665 665 + log 666 666 + "migration %s: failed to deactivate old account: %s" 667 667 + state.did e ) ; 668 668 + (false, Some e) 669 669 + in 670 670 + Util.render_html ~title:"Migrate Account" 671 671 + (module Frontend.MigratePage) 672 672 + ~props: 673 673 + (make_props ~csrf_token ~invite_required ~hostname 674 674 + ~step:"complete" ~did:state.did ~handle:state.handle 675 675 + ~blobs_imported:state.blobs_imported 676 676 + ~blobs_failed:state.blobs_failed ~old_account_deactivated 677 677 + ?old_account_deactivation_error 678 678 + ~message:"Your account has been successfully migrated!" 679 679 + () ) ) ) ) 680 680 + 681 681 + and handle_resend_plc_token (ctx : Xrpc.context) ~csrf_token ~invite_required 682 682 + ~hostname = 683 683 + match State.get ctx.req with 684 684 + | None -> 685 685 + render_error ~csrf_token ~invite_required ~hostname 686 686 + "Migration state not found. Please start over." 687 687 + | Some state -> ( 688 688 + match%lwt 689 689 + Remote.request_plc_signature ~pds_endpoint:state.old_pds 690 690 + ~access_jwt:state.access_jwt 691 691 + with 692 692 + | Error e -> 693 693 + Util.render_html ~title:"Migrate Account" 694 694 + (module Frontend.MigratePage) 695 695 + ~props: 696 696 + (make_props ~csrf_token ~invite_required ~hostname 697 697 + ~step:"enter_plc_token" ~did:state.did ~handle:state.handle 698 698 + ~old_pds:state.old_pds ~error:("Failed to resend: " ^ e) () ) 699 699 + | Ok () -> 700 700 + Util.render_html ~title:"Migrate Account" 701 701 + (module Frontend.MigratePage) 702 702 + ~props: 703 703 + (make_props ~csrf_token ~invite_required ~hostname 704 704 + ~step:"enter_plc_token" ~did:state.did ~handle:state.handle 705 705 + ~old_pds:state.old_pds 706 706 + ~message:"Confirmation code resent! Check your email." () ) ) 707 707 + 708 708 + and handle_submit_2fa (ctx : Xrpc.context) ~(render_err : render_err) fields = 709 709 + let identifier = 710 710 + List.assoc_opt "identifier" fields 711 711 + |> Option.value ~default:"" |> String.trim 712 712 + in 713 713 + let old_pds = 714 714 + List.assoc_opt "old_pds" fields |> Option.value ~default:"" |> String.trim 715 715 + in 716 716 + let auth_factor_token = 717 717 + List.assoc_opt "auth_factor_token" fields 718 718 + |> Option.value ~default:"" |> String.trim 719 719 + in 720 720 + let invite_code = 721 721 + List.assoc_opt "invite_code" fields |> Option.map String.trim 722 722 + in 723 723 + let password = List.assoc_opt "password" fields |> Option.value ~default:"" in 724 724 + if String.length auth_factor_token = 0 then 725 725 + render_err ~step:"enter_2fa" ~identifier ~old_pds ?invite_code 726 726 + "Please enter your authentication code" 727 727 + else 728 728 + match%lwt Remote.resolve_identity identifier with 729 729 + | Error e -> 730 730 + render_err ~step:"enter_2fa" ~identifier ~old_pds ?invite_code e 731 731 + | Ok (did, handle, resolved_pds) -> ( 732 732 + let pds_endpoint = 733 733 + if String.length old_pds > 0 then old_pds else resolved_pds 734 734 + in 735 735 + match%lwt 736 736 + Remote.create_session ~pds_endpoint ~identifier ~password 737 737 + ~auth_factor_token () 738 738 + with 739 739 + | Remote.AuthError e -> 740 740 + render_err ~step:"enter_2fa" ~identifier ~old_pds:pds_endpoint 741 741 + ?invite_code e 742 742 + | Remote.AuthNeeds2FA -> 743 743 + render_err ~step:"enter_2fa" ~identifier ~old_pds:pds_endpoint 744 744 + ?invite_code "Invalid authentication code. Please try again." 745 745 + | Remote.AuthSuccess session -> ( 746 746 + match%lwt 747 747 + Remote.get_session ~pds_endpoint ~access_jwt:session.access_jwt 748 748 + with 749 749 + | Error e -> 750 750 + render_err ("Failed to get account info: " ^ e) 751 751 + | Ok session_info -> ( 752 752 + let is_active = 753 753 + match session_info.active with Some false -> false | _ -> true 754 754 + in 755 755 + if not is_active then 756 756 + render_err 757 757 + "This account is already deactivated. Cannot migrate a \ 758 758 + deactivated account." 759 759 + else 760 760 + match%lwt 761 761 + Remote.get_service_auth ~pds_endpoint 762 762 + ~access_jwt:session.access_jwt 763 763 + with 764 764 + | Error e -> 765 765 + render_err ("Failed to get service authorization: " ^ e) 766 766 + | Ok service_auth_token -> ( 767 767 + let email = 768 768 + match session_info.email with 769 769 + | Some e when String.length e > 0 -> 770 770 + e 771 771 + | _ -> 772 772 + Printf.sprintf "%s@%s" did Env.hostname 773 773 + in 774 774 + match%lwt 775 775 + Ops.create_account ~email ~handle ~password ~did 776 776 + ~service_auth_token ?invite_code ctx.db 777 777 + with 778 778 + | Error e -> 779 779 + render_err e 780 780 + | Ok _signing_key_did -> ( 781 781 + match%lwt 782 782 + Remote.fetch_repo ~pds_endpoint 783 783 + ~access_jwt:session.access_jwt ~did 784 784 + with 785 785 + | Error e -> 786 786 + render_err ("Failed to fetch repository: " ^ e) 787 787 + | Ok car_data -> ( 788 788 + match%lwt Ops.import_repo ~did ~car_data with 789 789 + | Error e -> 790 790 + render_err e 791 791 + | Ok () -> 792 792 + transition_to_plc_token_step ctx ~did ~handle 793 793 + ~old_pds:pds_endpoint 794 794 + ~access_jwt:session.access_jwt 795 795 + ~refresh_jwt:session.refresh_jwt ~email 796 796 + ~blobs_imported:0 ~blobs_failed:0 ) ) ) ) ) ) 797 797 + 798 798 + and handle_resume_migration (ctx : Xrpc.context) ~csrf_token ~invite_required 799 799 + ~hostname ~(render_err : render_err) fields = 800 800 + let identifier = 801 801 + List.assoc_opt "identifier" fields 802 802 + |> Option.value ~default:"" |> String.trim 803 803 + in 804 804 + let password = List.assoc_opt "password" fields |> Option.value ~default:"" in 805 805 + if String.length identifier = 0 then 806 806 + render_err ~step:"resume_available" "Please enter your handle or DID" 807 807 + else if String.length password = 0 then 808 808 + render_err ~step:"resume_available" "Please enter your password" 809 809 + else 810 810 + match%lwt Remote.resolve_identity identifier with 811 811 + | Error e -> 812 812 + render_err ~step:"resume_available" e 813 813 + | Ok (did, handle, old_pds) -> ( 814 814 + match%lwt 815 815 + Remote.create_session ~pds_endpoint:old_pds ~identifier ~password () 816 816 + with 817 817 + | Remote.AuthError e -> 818 818 + render_err ~step:"resume_available" e 819 819 + | Remote.AuthNeeds2FA -> 820 820 + Util.render_html ~title:"Migrate Account" 821 821 + (module Frontend.MigratePage) 822 822 + ~props: 823 823 + (make_props ~csrf_token ~invite_required ~hostname 824 824 + ~step:"enter_2fa" ~identifier ~old_pds () ) 825 825 + | Remote.AuthSuccess session -> ( 826 826 + let%lwt email = 827 827 + match%lwt 828 828 + Remote.get_session ~pds_endpoint:old_pds 829 829 + ~access_jwt:session.access_jwt 830 830 + with 831 831 + | Ok info -> 832 832 + Lwt.return 833 833 + ( match info.email with 834 834 + | Some e when String.length e > 0 -> 835 835 + e 836 836 + | _ -> 837 837 + Printf.sprintf "%s@%s" did Env.hostname ) 838 838 + | Error _ -> 839 839 + Lwt.return (Printf.sprintf "%s@%s" did Env.hostname) 840 840 + in 841 841 + match%lwt State.check_resume_state ~did ctx.db with 842 842 + | Error e -> 843 843 + render_err ~step:"resume_available" ~did ~handle ~old_pds e 844 844 + | Ok State.AlreadyActive -> 845 845 + let%lwt () = Session.log_in_did ctx.req did in 846 846 + Util.render_html ~title:"Migrate Account" 847 847 + (module Frontend.MigratePage) 848 848 + ~props: 849 849 + (make_props ~csrf_token ~invite_required ~hostname 850 850 + ~step:"complete" ~did ~handle 851 851 + ~message: 852 852 + "Your account is already active! You have been logged \ 853 853 + in." 854 854 + () ) 855 855 + | Ok State.NeedsActivation -> 856 856 + let%lwt () = Ops.activate_account did ctx.db in 857 857 + let%lwt () = Session.log_in_did ctx.req did in 858 858 + let%lwt deactivation_result = 859 859 + deactivate_old_account_with_refresh ~old_pds 860 860 + ~access_jwt:session.access_jwt 861 861 + ~refresh_jwt:session.refresh_jwt 862 862 + in 863 863 + let old_account_deactivated, old_account_deactivation_error = 864 864 + match deactivation_result with 865 865 + | Ok () -> 866 866 + (true, None) 867 867 + | Error e -> 868 868 + Dream.warning (fun log -> 869 869 + log "migration %s: failed to deactivate old account: %s" 870 870 + did e ) ; 871 871 + (false, Some e) 872 872 + in 873 873 + Util.render_html ~title:"Migrate Account" 874 874 + (module Frontend.MigratePage) 875 875 + ~props: 876 876 + (make_props ~csrf_token ~invite_required ~hostname 877 877 + ~step:"complete" ~did ~handle ~old_account_deactivated 878 878 + ?old_account_deactivation_error 879 879 + ~message: 880 880 + "Your account has been activated! Your identity is \ 881 881 + pointing to this PDS." 882 882 + () ) 883 883 + | Ok State.NeedsPlcUpdate -> 884 884 + transition_to_plc_token_step ctx ~did ~handle ~old_pds 885 885 + ~access_jwt:session.access_jwt ~refresh_jwt:session.refresh_jwt 886 886 + ~email ~blobs_imported:0 ~blobs_failed:0 887 887 + | Ok State.NeedsRepoImport | Ok State.NeedsBlobImport -> ( 888 888 + match%lwt 889 889 + Remote.fetch_repo ~pds_endpoint:old_pds 890 890 + ~access_jwt:session.access_jwt ~did 891 891 + with 892 892 + | Error e -> 893 893 + render_err ~did ~handle ~old_pds 894 894 + ("Failed to fetch repository: " ^ e) 895 895 + | Ok car_data -> ( 896 896 + match%lwt Ops.import_repo ~did ~car_data with 897 897 + | Error e -> 898 898 + render_err ~did ~handle ~old_pds e 899 899 + | Ok () -> ( 900 900 + match%lwt Ops.list_missing_blobs ~did ~limit:50 () with 901 901 + | Error e -> 902 902 + Dream.warning (fun log -> 903 903 + log "migration %s: failed to list missing blobs: %s" did 904 904 + e ) ; 905 905 + transition_to_plc_token_step ctx ~did ~handle ~old_pds 906 906 + ~access_jwt:session.access_jwt 907 907 + ~refresh_jwt:session.refresh_jwt ~email ~blobs_imported:0 908 908 + ~blobs_failed:0 909 909 + | Ok (missing_cids, next_cursor) -> 910 910 + if List.length missing_cids = 0 then 911 911 + transition_to_plc_token_step ctx ~did ~handle ~old_pds 912 912 + ~access_jwt:session.access_jwt 913 913 + ~refresh_jwt:session.refresh_jwt ~email 914 914 + ~blobs_imported:0 ~blobs_failed:0 915 915 + else 916 916 + let%lwt imported, failed = 917 917 + Ops.import_blobs_batch ~pds_endpoint:old_pds 918 918 + ~access_jwt:session.access_jwt ~did ~cids:missing_cids 919 919 + in 920 920 + let cursor = Option.value ~default:"" next_cursor in 921 921 + if String.length cursor = 0 then 922 922 + transition_to_plc_token_step ctx ~did ~handle ~old_pds 923 923 + ~access_jwt:session.access_jwt 924 924 + ~refresh_jwt:session.refresh_jwt ~email 925 925 + ~blobs_imported:imported ~blobs_failed:failed 926 926 + else 927 927 + let%lwt () = 928 928 + State.set ctx.req 929 929 + { did 930 930 + ; handle 931 931 + ; old_pds 932 932 + ; access_jwt= session.access_jwt 933 933 + ; refresh_jwt= session.refresh_jwt 934 934 + ; email 935 935 + ; blobs_imported= imported 936 936 + ; blobs_failed= failed 937 937 + ; blobs_cursor= cursor 938 938 + ; plc_requested= false } 939 939 + in 940 940 + Util.render_html ~title:"Migrate Account" 941 941 + (module Frontend.MigratePage) 942 942 + ~props: 943 943 + (make_props ~csrf_token ~invite_required ~hostname 944 944 + ~step:"importing_data" ~did ~handle ~old_pds 945 945 + ~blobs_imported:imported ~blobs_failed:failed () ) 946 946 + ) ) ) ) ) 947 947 + 948 948 + let get_handler = 949 949 + Xrpc.handler (fun ctx -> 950 950 + let csrf_token = Dream.csrf_token ctx.req in 951 951 + let invite_required = Env.invite_required in 952 952 + let hostname = Env.hostname in 953 953 + let props : Frontend.MigratePage.props = 954 954 + match State.get ctx.req with 955 955 + | None -> 956 956 + make_props ~csrf_token ~invite_required ~hostname 957 957 + ~step:"enter_credentials" () 958 958 + | Some state -> 959 959 + if state.plc_requested then 960 960 + make_props ~csrf_token ~invite_required ~hostname 961 961 + ~step:"enter_plc_token" ~did:state.did ~handle:state.handle 962 962 + ~old_pds:state.old_pds ~blobs_imported:state.blobs_imported 963 963 + ~blobs_failed:state.blobs_failed () 964 964 + else 965 965 + make_props ~csrf_token ~invite_required ~hostname 966 966 + ~step:"importing_data" ~did:state.did ~handle:state.handle 967 967 + ~old_pds:state.old_pds ~blobs_imported:state.blobs_imported 968 968 + ~blobs_failed:state.blobs_failed () 969 969 + in 970 970 + Util.render_html ~title:"Migrate Account" 971 971 + (module Frontend.MigratePage) 972 972 + ~props ) 973 973 + 974 974 + let post_handler = 975 975 + Xrpc.handler (fun ctx -> 976 976 + let csrf_token = Dream.csrf_token ctx.req in 977 977 + let invite_required = Env.invite_required in 978 978 + let hostname = Env.hostname in 979 979 + let render_err = render_error ~csrf_token ~invite_required ~hostname in 980 980 + match%lwt Dream.form ctx.req with 981 981 + | `Ok fields -> ( 982 982 + let get_field name = 983 983 + List.assoc_opt name fields |> Option.value ~default:"" 984 984 + |> String.trim 985 985 + in 986 986 + let action = get_field "action" in 987 987 + match action with 988 988 + | "start_migration" -> 989 989 + handle_start_migration ctx ~csrf_token ~invite_required ~hostname 990 990 + ~render_err fields 991 991 + | "continue_blobs" -> 992 992 + handle_continue_blobs ctx ~csrf_token ~invite_required ~hostname 993 993 + ~render_err 994 994 + | "submit_plc_token" -> 995 995 + handle_submit_plc_token ctx ~csrf_token ~invite_required ~hostname 996 996 + ~render_err fields 997 997 + | "resend_plc_token" -> 998 998 + handle_resend_plc_token ctx ~csrf_token ~invite_required ~hostname 999 999 + | "submit_2fa" -> 1000 1000 + handle_submit_2fa ctx ~render_err fields 1001 1001 + | "resume_migration" -> 1002 1002 + handle_resume_migration ctx ~csrf_token ~invite_required ~hostname 1003 1003 + ~render_err fields 1004 1004 + | _ -> 1005 1005 + render_err "Invalid action" ) 1006 1006 + | _ -> 1007 1007 + render_err "Invalid form submission" )

+199

pegasus/lib/api/account_/migrate/ops.ml

reviewed

··· 1 1 + (* local migration operations *) 2 2 + 3 3 + type check_account_status_response = Server.CheckAccountStatus.response 4 4 + [@@deriving yojson {strict= false}] 5 5 + 6 6 + let get_account_status = Server.CheckAccountStatus.get_account_status 7 7 + 8 8 + let get_recommended_did_credentials = 9 9 + Identity.GetRecommendedDidCredentials.get_credentials 10 10 + 11 11 + let create_account ~email ~handle ~password ~did ~service_auth_token 12 12 + ?invite_code db = 13 13 + let open Lwt.Infix in 14 14 + let%lwt verified = 15 15 + match%lwt 16 16 + Jwt.verify_service_jwt ~nsid:"com.atproto.server.createAccount" 17 17 + ~verify_sig:(fun _did pk -> 18 18 + Lwt.return 19 19 + @@ Jwt.verify_jwt service_auth_token 20 20 + ~pubkey:(Kleidos.parse_multikey_str pk) ) 21 21 + service_auth_token 22 22 + with 23 23 + | Ok creds -> 24 24 + Lwt.return_ok creds 25 25 + | Error (AuthRequired e) -> 26 26 + Lwt.return_error @@ Errors.auth_required e 27 27 + | Error (ExpiredToken e) -> 28 28 + Lwt.return_error @@ Errors.invalid_request ~name:"ExpiredToken" e 29 29 + | Error (InvalidToken e) -> 30 30 + Lwt.return_error @@ Errors.invalid_request ~name:"InvalidToken" e 31 31 + | Error (InternalError e) -> 32 32 + Lwt.return_error @@ Errors.internal_error ~msg:e () 33 33 + in 34 34 + match verified with 35 35 + | Error e -> 36 36 + Lwt.return_error e 37 37 + | Ok _ -> ( 38 38 + match%lwt Data_store.get_actor_by_identifier did db with 39 39 + | Some existing when existing.deactivated_at <> None -> 40 40 + Lwt.return_error 41 41 + "RESUMABLE: An incomplete migration exists for this account." 42 42 + | Some _ -> 43 43 + Lwt.return_error 44 44 + "An account with this DID already exists on this PDS. If you \ 45 45 + previously migrated here, try logging in instead." 46 46 + | None -> ( 47 47 + match%lwt Data_store.get_actor_by_identifier handle db with 48 48 + | Some _ -> 49 49 + Lwt.return_error 50 50 + ( "The handle @" ^ handle 51 51 + ^ " is already taken on this PDS. You may need to use a different \ 52 52 + handle." ) 53 53 + | None -> ( 54 54 + match%lwt Data_store.get_actor_by_identifier email db with 55 55 + | Some _ -> 56 56 + Lwt.return_error "An account with this email already exists" 57 57 + | None -> ( 58 58 + ( match 59 59 + ( Env.invite_required 60 60 + , invite_code 61 61 + , Option.bind invite_code (fun c -> 62 62 + if String.length c = 0 then None else Some c ) ) 63 63 + with 64 64 + | true, None, _ | true, _, None -> 65 65 + Lwt.return_error "An invite code is required" 66 66 + | true, Some code, _ -> ( 67 67 + match%lwt Data_store.get_invite ~code db with 68 68 + | Some i when i.remaining > 0 -> ( 69 69 + match%lwt Data_store.use_invite ~code db with 70 70 + | Some _ -> 71 71 + Lwt.return_ok () 72 72 + | None -> 73 73 + Lwt.return_error "Failed to use invite code" ) 74 74 + | _ -> 75 75 + Lwt.return_error "Invalid invite code" ) 76 76 + | false, _, _ -> 77 77 + Lwt.return_ok () ) 78 78 + >>= function 79 79 + | Error e -> 80 80 + Lwt.return_error e 81 81 + | Ok () -> 82 82 + let signing_key, signing_pubkey = 83 83 + Kleidos.K256.generate_keypair () 84 84 + in 85 85 + let sk_priv_mk = Kleidos.K256.privkey_to_multikey signing_key in 86 86 + let%lwt () = 87 87 + Data_store.create_actor ~did ~handle ~email ~password 88 88 + ~signing_key:sk_priv_mk db 89 89 + in 90 90 + let%lwt () = Data_store.deactivate_actor did db in 91 91 + let () = 92 92 + Util.mkfile_p 93 93 + (Util.Constants.user_db_filepath did) 94 94 + ~perm:0o644 95 95 + in 96 96 + let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in 97 97 + let%lwt _ = 98 98 + Sequencer.sequence_account db ~did ~active:false 99 99 + ~status:`Deactivated () 100 100 + in 101 101 + Lwt.return_ok (Kleidos.K256.pubkey_to_did_key signing_pubkey) ) 102 102 + ) ) ) 103 103 + 104 104 + let bytes_to_car_stream (data : bytes) : Car.stream = 105 105 + fun () -> Lwt.return (Lwt_seq.Cons (data, fun () -> Lwt.return Lwt_seq.Nil)) 106 106 + 107 107 + let import_repo ~did ~car_data = 108 108 + try%lwt 109 109 + let%lwt repo = Repository.load ~create:true did in 110 110 + let stream = bytes_to_car_stream car_data in 111 111 + match%lwt Repository.import_car repo stream with 112 112 + | Ok _ -> 113 113 + Lwt.return_ok () 114 114 + | Error e -> 115 115 + Lwt.return_error ("Failed to import repository: " ^ Printexc.to_string e) 116 116 + with exn -> 117 117 + Lwt.return_error ("Failed to import repository: " ^ Printexc.to_string exn) 118 118 + 119 119 + let import_blobs_batch ~pds_endpoint ~access_jwt ~did ~cids = 120 120 + let%lwt user_db = User_store.connect ~create:true did in 121 121 + let%lwt results = 122 122 + Lwt_list.map_p 123 123 + (fun cid_str -> 124 124 + match%lwt 125 125 + Remote.fetch_blob ~pds_endpoint ~access_jwt ~did ~cid:cid_str 126 126 + with 127 127 + | Error e -> 128 128 + Dream.warning (fun log -> 129 129 + log "migration %s: failed to fetch blob %s: %s" did cid_str e ) ; 130 130 + Lwt.return_error cid_str 131 131 + | Ok (mimetype, data) -> ( 132 132 + match Cid.of_string cid_str with 133 133 + | Error _ -> 134 134 + Lwt.return_error cid_str 135 135 + | Ok cid -> 136 136 + let%lwt _ = User_store.put_blob user_db cid mimetype data in 137 137 + Lwt.return_ok cid_str ) ) 138 138 + cids 139 139 + in 140 140 + let imported = 141 141 + List.filter (function Ok _ -> true | Error _ -> false) results 142 142 + |> List.length 143 143 + in 144 144 + let failed = 145 145 + List.filter (function Error _ -> true | Ok _ -> false) results 146 146 + |> List.length 147 147 + in 148 148 + Lwt.return (imported, failed) 149 149 + 150 150 + let list_missing_blobs ~did ~limit ?cursor () = 151 151 + try%lwt 152 152 + let%lwt {db= us; _} = Repository.load did in 153 153 + let cursor = Option.value ~default:"" cursor in 154 154 + let%lwt blobs = User_store.list_missing_blobs ~limit ~cursor us in 155 155 + let cids = List.map (fun (_, cid) -> Cid.to_string cid) blobs in 156 156 + let next_cursor = 157 157 + if List.length blobs >= limit then List.nth_opt cids (List.length cids - 1) 158 158 + else None 159 159 + in 160 160 + Lwt.return_ok (cids, next_cursor) 161 161 + with exn -> 162 162 + Lwt.return_error ("Failed to list missing blobs: " ^ Printexc.to_string exn) 163 163 + 164 164 + let check_account_status ~did = 165 165 + try%lwt 166 166 + match%lwt get_account_status did with 167 167 + | Ok status -> 168 168 + Lwt.return_ok status 169 169 + | _ -> 170 170 + Lwt.return_error "Failed to load account data" 171 171 + with exn -> 172 172 + Lwt.return_error 173 173 + ("Failed to check account status: " ^ Printexc.to_string exn) 174 174 + 175 175 + let activate_account did db = 176 176 + let%lwt () = Data_store.activate_actor did db in 177 177 + let%lwt _ = 178 178 + Sequencer.sequence_account db ~did ~active:true ~status:`Active () 179 179 + in 180 180 + let%lwt _ = Sequencer.sequence_identity ~did db () in 181 181 + Lwt.return_unit 182 182 + 183 183 + let submit_plc_operation ~did ~handle ~(operation : Plc.signed_operation) db = 184 184 + match operation with 185 185 + | Tombstone _ -> 186 186 + Lwt.return_error "Cannot submit tombstone operation during migration" 187 187 + | Operation op -> ( 188 188 + match Plc.validate_operation ~handle (Operation op) with 189 189 + | Ok () -> ( 190 190 + match%lwt Plc.submit_operation did operation with 191 191 + | Ok () -> 192 192 + let%lwt _ = Sequencer.sequence_identity db ~did () in 193 193 + let%lwt _ = Id_resolver.Did.resolve ~skip_cache:true did in 194 194 + Lwt.return_ok () 195 195 + | Error (status, msg) -> 196 196 + Lwt.return_error 197 197 + (Printf.sprintf "PLC submission failed (%d): %s" status msg) ) 198 198 + | Error e -> 199 199 + Lwt.return_error e )

+476

pegasus/lib/api/account_/migrate/remote.ml

reviewed

··· 1 1 + (* remote pds xrpc calls for account migration *) 2 2 + 3 3 + type create_session_response = Server.CreateSession.response 4 4 + [@@deriving yojson {strict= false}] 5 5 + 6 6 + type get_session_response = Server.GetSession.response 7 7 + [@@deriving yojson {strict= false}] 8 8 + 9 9 + type refresh_session_response = Server.RefreshSession.response 10 10 + [@@deriving yojson {strict= false}] 11 11 + 12 12 + type service_auth_response = Server.GetServiceAuth.response 13 13 + [@@deriving yojson {strict= false}] 14 14 + 15 15 + type list_blobs_response = Repo.ListMissingBlobs.response 16 16 + [@@deriving yojson {strict= false}] 17 17 + 18 18 + type get_preferences_response = Proxy.AppBskyActorGetPreferences.response 19 19 + [@@deriving yojson {strict= false}] 20 20 + 21 21 + type sign_plc_operation_response = Identity.SignPlcOperation.response 22 22 + [@@deriving yojson {strict= false}] 23 23 + 24 24 + type remote_credentials_response = 25 25 + Identity.GetRecommendedDidCredentials.response 26 26 + [@@deriving yojson {strict= false}] 27 27 + 28 28 + open Cohttp_lwt 29 29 + 30 30 + type auth_result = 31 31 + | AuthSuccess of create_session_response 32 32 + | AuthNeeds2FA 33 33 + | AuthError of string 34 34 + 35 35 + let post_json ~uri ~headers ~body = 36 36 + let headers = Http.Header.add headers "Content-Type" "application/json" in 37 37 + Cohttp_lwt_unix.Client.post ~headers 38 38 + ~body:(Body.of_string (Yojson.Safe.to_string body)) 39 39 + uri 40 40 + 41 41 + let post_empty ~uri ~headers = 42 42 + Cohttp_lwt_unix.Client.post ~headers ~body:Body.empty uri 43 43 + 44 44 + let resolve_identity identifier = 45 45 + let%lwt did = 46 46 + if String.starts_with ~prefix:"did:" identifier then 47 47 + Lwt.return_ok identifier 48 48 + else 49 49 + match%lwt Id_resolver.Handle.resolve identifier with 50 50 + | Ok did -> 51 51 + Lwt.return_ok did 52 52 + | Error e -> 53 53 + Lwt.return_error ("Failed to resolve handle: " ^ e) 54 54 + in 55 55 + match did with 56 56 + | Error e -> 57 57 + Lwt.return_error e 58 58 + | Ok did -> ( 59 59 + match%lwt Id_resolver.Did.resolve did with 60 60 + | Error e -> 61 61 + Lwt.return_error ("Failed to resolve DID document: " ^ e) 62 62 + | Ok doc -> ( 63 63 + match Id_resolver.Did.Document.get_service doc "#atproto_pds" with 64 64 + | None -> 65 65 + Lwt.return_error "No PDS service found in DID document" 66 66 + | Some pds_endpoint -> 67 67 + let handle = 68 68 + match doc.also_known_as with 69 69 + | Some akas -> 70 70 + List.find_map 71 71 + (fun aka -> 72 72 + if String.starts_with ~prefix:"at://" aka then 73 73 + Some (String.sub aka 5 (String.length aka - 5)) 74 74 + else None ) 75 75 + akas 76 76 + |> Option.value ~default:did 77 77 + | None -> 78 78 + did 79 79 + in 80 80 + Lwt.return_ok (did, handle, pds_endpoint) ) ) 81 81 + 82 82 + let create_session ~pds_endpoint ~identifier ~password ?auth_factor_token () = 83 83 + let uri = 84 84 + Uri.with_path 85 85 + (Uri.of_string pds_endpoint) 86 86 + "/xrpc/com.atproto.server.createSession" 87 87 + in 88 88 + let body = 89 89 + let base = 90 90 + [("identifier", `String identifier); ("password", `String password)] 91 91 + in 92 92 + match auth_factor_token with 93 93 + | Some token -> 94 94 + `Assoc (("authFactorToken", `String token) :: base) 95 95 + | None -> 96 96 + `Assoc base 97 97 + in 98 98 + let headers = Http.Header.init () in 99 99 + try%lwt 100 100 + let%lwt res, body = post_json ~uri ~headers ~body in 101 101 + match res.status with 102 102 + | `OK -> ( 103 103 + let%lwt body_str = Body.to_string body in 104 104 + match 105 105 + create_session_response_of_yojson (Yojson.Safe.from_string body_str) 106 106 + with 107 107 + | Ok session -> 108 108 + Lwt.return (AuthSuccess session) 109 109 + | Error e -> 110 110 + Lwt.return (AuthError ("Invalid session response: " ^ e)) ) 111 111 + | `Unauthorized -> ( 112 112 + let%lwt body_str = Body.to_string body in 113 113 + try 114 114 + let json = Yojson.Safe.from_string body_str in 115 115 + let open Yojson.Safe.Util in 116 116 + let error = json |> member "error" |> to_string_option in 117 117 + match error with 118 118 + | Some "AuthFactorTokenRequired" -> 119 119 + Lwt.return AuthNeeds2FA 120 120 + | _ -> 121 121 + Lwt.return (AuthError "Invalid credentials") 122 122 + with _ -> Lwt.return (AuthError "Invalid credentials") ) 123 123 + | status -> 124 124 + let%lwt body_str = Body.to_string body in 125 125 + Lwt.return 126 126 + (AuthError 127 127 + (Printf.sprintf "Authentication failed (%s): %s" 128 128 + (Http.Status.to_string status) 129 129 + body_str ) ) 130 130 + with exn -> 131 131 + Lwt.return (AuthError ("Network error: " ^ Printexc.to_string exn)) 132 132 + 133 133 + let get_session ~pds_endpoint ~access_jwt = 134 134 + let uri = 135 135 + Uri.with_path 136 136 + (Uri.of_string pds_endpoint) 137 137 + "/xrpc/com.atproto.server.getSession" 138 138 + in 139 139 + let headers = 140 140 + Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)] 141 141 + in 142 142 + try%lwt 143 143 + let%lwt res, body = Util.http_get uri ~headers in 144 144 + match res.status with 145 145 + | `OK -> ( 146 146 + let%lwt body_str = Body.to_string body in 147 147 + match 148 148 + get_session_response_of_yojson (Yojson.Safe.from_string body_str) 149 149 + with 150 150 + | Ok session -> 151 151 + Lwt.return_ok session 152 152 + | Error e -> 153 153 + Lwt.return_error ("Invalid session response: " ^ e) ) 154 154 + | status -> 155 155 + let%lwt body_str = Body.to_string body in 156 156 + Lwt.return_error 157 157 + (Printf.sprintf "Failed to get session info (%s): %s" 158 158 + (Http.Status.to_string status) 159 159 + body_str ) 160 160 + with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn) 161 161 + 162 162 + let jwt_needs_refresh ?(delta_s = 60) access_jwt = 163 163 + match Jwt.decode_jwt access_jwt with 164 164 + | Error _ -> 165 165 + true 166 166 + | Ok (_header, payload) -> ( 167 167 + try 168 168 + let open Yojson.Safe.Util in 169 169 + let exp = payload |> member "exp" |> to_int in 170 170 + let now = int_of_float (Unix.gettimeofday ()) in 171 171 + exp - now < delta_s 172 172 + with _ -> true ) 173 173 + 174 174 + let refresh_session ~pds_endpoint ~refresh_jwt = 175 175 + let uri = 176 176 + Uri.with_path 177 177 + (Uri.of_string pds_endpoint) 178 178 + "/xrpc/com.atproto.server.refreshSession" 179 179 + in 180 180 + let headers = 181 181 + Http.Header.of_list [("Authorization", "Bearer " ^ refresh_jwt)] 182 182 + in 183 183 + try%lwt 184 184 + let%lwt res, body = post_empty ~uri ~headers in 185 185 + match res.status with 186 186 + | `OK -> ( 187 187 + let%lwt body_str = Body.to_string body in 188 188 + match 189 189 + refresh_session_response_of_yojson (Yojson.Safe.from_string body_str) 190 190 + with 191 191 + | Ok tokens -> 192 192 + Lwt.return_ok tokens 193 193 + | Error e -> 194 194 + Lwt.return_error ("Invalid refresh response: " ^ e) ) 195 195 + | status -> 196 196 + let%lwt body_str = Body.to_string body in 197 197 + Lwt.return_error 198 198 + (Printf.sprintf "Failed to refresh session (%s): %s" 199 199 + (Http.Status.to_string status) 200 200 + body_str ) 201 201 + with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn) 202 202 + 203 203 + let get_service_auth ~pds_endpoint ~access_jwt = 204 204 + let uri = 205 205 + Uri.with_path 206 206 + (Uri.of_string pds_endpoint) 207 207 + "/xrpc/com.atproto.server.getServiceAuth" 208 208 + |> fun u -> 209 209 + Uri.add_query_params' u 210 210 + [ ("aud", Env.did) 211 211 + ; ("lxm", "com.atproto.server.createAccount") 212 212 + ; ("exp", string_of_int (int_of_float (Unix.gettimeofday ()) + 300)) ] 213 213 + in 214 214 + let headers = 215 215 + Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)] 216 216 + in 217 217 + try%lwt 218 218 + let%lwt res, body = Util.http_get uri ~headers in 219 219 + match res.status with 220 220 + | `OK -> ( 221 221 + let%lwt body_str = Body.to_string body in 222 222 + match 223 223 + service_auth_response_of_yojson (Yojson.Safe.from_string body_str) 224 224 + with 225 225 + | Ok {token} -> 226 226 + Lwt.return_ok token 227 227 + | Error e -> 228 228 + Lwt.return_error ("Invalid service auth response: " ^ e) ) 229 229 + | status -> 230 230 + let%lwt body_str = Body.to_string body in 231 231 + Lwt.return_error 232 232 + (Printf.sprintf "Failed to get service auth (%s): %s" 233 233 + (Http.Status.to_string status) 234 234 + body_str ) 235 235 + with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn) 236 236 + 237 237 + let get_recommended_credentials ~pds_endpoint ~access_jwt = 238 238 + let uri = 239 239 + Uri.with_path 240 240 + (Uri.of_string pds_endpoint) 241 241 + "/xrpc/com.atproto.identity.getRecommendedDidCredentials" 242 242 + in 243 243 + let headers = 244 244 + Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)] 245 245 + in 246 246 + try%lwt 247 247 + let%lwt res, body = Cohttp_lwt_unix.Client.get ~headers uri in 248 248 + match res.status with 249 249 + | `OK -> ( 250 250 + let%lwt body_str = Body.to_string body in 251 251 + match 252 252 + remote_credentials_response_of_yojson 253 253 + (Yojson.Safe.from_string body_str) 254 254 + with 255 255 + | Ok creds -> 256 256 + Lwt.return_ok creds 257 257 + | Error e -> 258 258 + Lwt.return_error ("Invalid credentials response: " ^ e) ) 259 259 + | status -> 260 260 + let%lwt body_str = Body.to_string body in 261 261 + Lwt.return_error 262 262 + (Printf.sprintf "Failed to get remote credentials (%s): %s" 263 263 + (Http.Status.to_string status) 264 264 + body_str ) 265 265 + with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn) 266 266 + 267 267 + let request_plc_signature ~pds_endpoint ~access_jwt = 268 268 + let uri = 269 269 + Uri.with_path 270 270 + (Uri.of_string pds_endpoint) 271 271 + "/xrpc/com.atproto.identity.requestPlcOperationSignature" 272 272 + in 273 273 + let headers = 274 274 + Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)] 275 275 + in 276 276 + try%lwt 277 277 + let%lwt res, body = post_empty ~uri ~headers in 278 278 + match res.status with 279 279 + | `OK -> 280 280 + let%lwt () = Body.drain_body body in 281 281 + Lwt.return_ok () 282 282 + | status -> 283 283 + let%lwt body_str = Body.to_string body in 284 284 + Lwt.return_error 285 285 + (Printf.sprintf "Failed to request PLC signature (%s): %s" 286 286 + (Http.Status.to_string status) 287 287 + body_str ) 288 288 + with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn) 289 289 + 290 290 + let sign_plc_operation ~pds_endpoint ~access_jwt ~token 291 291 + ~(credentials : Plc.credentials) = 292 292 + let uri = 293 293 + Uri.with_path 294 294 + (Uri.of_string pds_endpoint) 295 295 + "/xrpc/com.atproto.identity.signPlcOperation" 296 296 + in 297 297 + let headers = 298 298 + Http.Header.of_list 299 299 + [ ("Authorization", "Bearer " ^ access_jwt) 300 300 + ; ("Content-Type", "application/json") ] 301 301 + in 302 302 + let body = 303 303 + `Assoc 304 304 + [ ("token", `String token) 305 305 + ; ( "rotationKeys" 306 306 + , `List (List.map (fun s -> `String s) credentials.rotation_keys) ) 307 307 + ; ( "verificationMethods" 308 308 + , `Assoc 309 309 + (List.map 310 310 + (fun (k, v) -> (k, `String v)) 311 311 + credentials.verification_methods ) ) 312 312 + ; ( "alsoKnownAs" 313 313 + , `List (List.map (fun s -> `String s) credentials.also_known_as) ) 314 314 + ; ("services", Plc.service_map_to_yojson credentials.services) ] 315 315 + in 316 316 + try%lwt 317 317 + let%lwt res, body = 318 318 + Cohttp_lwt_unix.Client.post ~headers 319 319 + ~body:(Body.of_string (Yojson.Safe.to_string body)) 320 320 + uri 321 321 + in 322 322 + match res.status with 323 323 + | `OK -> ( 324 324 + let%lwt body_str = Body.to_string body in 325 325 + match 326 326 + sign_plc_operation_response_of_yojson 327 327 + (Yojson.Safe.from_string body_str) 328 328 + with 329 329 + | Ok resp -> 330 330 + Lwt.return_ok resp.operation 331 331 + | Error e -> 332 332 + Lwt.return_error ("Invalid sign operation response: " ^ e) ) 333 333 + | status -> 334 334 + let%lwt body_str = Body.to_string body in 335 335 + Lwt.return_error 336 336 + (Printf.sprintf "Failed to sign PLC operation (%s): %s" 337 337 + (Http.Status.to_string status) 338 338 + body_str ) 339 339 + with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn) 340 340 + 341 341 + let fetch_repo ~pds_endpoint ~access_jwt ~did = 342 342 + let uri = 343 343 + Uri.with_path (Uri.of_string pds_endpoint) "/xrpc/com.atproto.sync.getRepo" 344 344 + |> fun u -> Uri.add_query_param' u ("did", did) 345 345 + in 346 346 + let headers = 347 347 + Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)] 348 348 + in 349 349 + try%lwt 350 350 + let%lwt res, body = Util.http_get uri ~headers in 351 351 + match res.status with 352 352 + | `OK -> 353 353 + let%lwt body_bytes = Body.to_string body in 354 354 + Lwt.return_ok (Bytes.of_string body_bytes) 355 355 + | status -> 356 356 + let%lwt () = Body.drain_body body in 357 357 + Lwt.return_error 358 358 + (Printf.sprintf "Failed to fetch repo (%s)" 359 359 + (Http.Status.to_string status) ) 360 360 + with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn) 361 361 + 362 362 + let fetch_blob ~pds_endpoint ~access_jwt ~did ~cid = 363 363 + let uri = 364 364 + Uri.with_path (Uri.of_string pds_endpoint) "/xrpc/com.atproto.sync.getBlob" 365 365 + |> fun u -> Uri.add_query_params' u [("did", did); ("cid", cid)] 366 366 + in 367 367 + let headers = 368 368 + Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)] 369 369 + in 370 370 + try%lwt 371 371 + let%lwt res, body = Util.http_get uri ~headers in 372 372 + match res.status with 373 373 + | `OK -> 374 374 + let content_type = 375 375 + Http.Header.get res.headers "Content-Type" 376 376 + |> Option.value ~default:"application/octet-stream" 377 377 + in 378 378 + let%lwt body_bytes = Body.to_string body in 379 379 + Lwt.return_ok (content_type, Bytes.of_string body_bytes) 380 380 + | status -> 381 381 + let%lwt () = Body.drain_body body in 382 382 + Lwt.return_error 383 383 + (Printf.sprintf "Failed to fetch blob %s (%s)" cid 384 384 + (Http.Status.to_string status) ) 385 385 + with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn) 386 386 + 387 387 + let fetch_preferences ~pds_endpoint ~access_jwt = 388 388 + let uri = 389 389 + Uri.with_path 390 390 + (Uri.of_string pds_endpoint) 391 391 + "/xrpc/app.bsky.actor.getPreferences" 392 392 + in 393 393 + let headers = 394 394 + Http.Header.of_list [("Authorization", "Bearer " ^ access_jwt)] 395 395 + in 396 396 + try%lwt 397 397 + let%lwt res, body = Util.http_get uri ~headers in 398 398 + match res.status with 399 399 + | `OK -> ( 400 400 + let%lwt body_str = Body.to_string body in 401 401 + match 402 402 + get_preferences_response_of_yojson (Yojson.Safe.from_string body_str) 403 403 + with 404 404 + | Ok resp -> 405 405 + Lwt.return_ok resp.preferences 406 406 + | Error e -> 407 407 + Dream.warning (fun log -> 408 408 + log "migration: failed to parse preferences response: %s" e ) ; 409 409 + Lwt.return_ok (`List []) ) 410 410 + | status -> 411 411 + let%lwt () = Body.drain_body body in 412 412 + Dream.warning (fun log -> 413 413 + log "migration: failed to fetch preferences: %s" 414 414 + (Http.Status.to_string status) ) ; 415 415 + Lwt.return_ok (`List []) 416 416 + with exn -> 417 417 + Dream.warning (fun log -> 418 418 + log "migration: exception fetching preferences: %s" 419 419 + (Printexc.to_string exn) ) ; 420 420 + Lwt.return_ok (`List []) 421 421 + 422 422 + let deactivate_account ~pds_endpoint ~access_jwt = 423 423 + let uri = 424 424 + Uri.with_path 425 425 + (Uri.of_string pds_endpoint) 426 426 + "/xrpc/com.atproto.server.deactivateAccount" 427 427 + in 428 428 + let headers = 429 429 + Http.Header.of_list 430 430 + [ ("Authorization", "Bearer " ^ access_jwt) 431 431 + ; ("Content-Type", "application/json") ] 432 432 + in 433 433 + try%lwt 434 434 + let%lwt res, body = 435 435 + Cohttp_lwt_unix.Client.post ~headers ~body:(Body.of_string "{}") uri 436 436 + in 437 437 + match res.status with 438 438 + | `OK -> 439 439 + let%lwt () = Body.drain_body body in 440 440 + Lwt.return_ok () 441 441 + | status -> 442 442 + let%lwt body_str = Body.to_string body in 443 443 + Lwt.return_error 444 444 + (Printf.sprintf "Failed to deactivate account (%s): %s" 445 445 + (Http.Status.to_string status) 446 446 + body_str ) 447 447 + with exn -> Lwt.return_error ("Network error: " ^ Printexc.to_string exn) 448 448 + 449 449 + let get_plc_rotation_keys ~did = 450 450 + if not (String.starts_with ~prefix:"did:plc:" did) then Lwt.return_ok [] 451 451 + else 452 452 + let uri = 453 453 + Uri.make ~scheme:"https" ~host:"plc.directory" ~path:(did ^ "/log/last") 454 454 + () 455 455 + in 456 456 + try%lwt 457 457 + let%lwt res, body = 458 458 + Cohttp_lwt_unix.Client.get 459 459 + ~headers:(Http.Header.of_list [("Accept", "application/json")]) 460 460 + uri 461 461 + in 462 462 + match res.status with 463 463 + | `OK -> ( 464 464 + let%lwt body_str = Body.to_string body in 465 465 + try 466 466 + let json = Yojson.Safe.from_string body_str in 467 467 + let open Yojson.Safe.Util in 468 468 + let rotation_keys = 469 469 + json |> member "rotationKeys" |> to_list |> List.map to_string 470 470 + in 471 471 + Lwt.return_ok rotation_keys 472 472 + with _ -> Lwt.return_ok [] ) 473 473 + | _ -> 474 474 + let%lwt () = Body.drain_body body in 475 475 + Lwt.return_ok [] 476 476 + with _ -> Lwt.return_ok []

+83

pegasus/lib/api/account_/migrate/state.ml

reviewed

··· 1 1 + (* migration state management *) 2 2 + 3 3 + type t = 4 4 + { did: string 5 5 + ; handle: string 6 6 + ; old_pds: string 7 7 + ; access_jwt: string 8 8 + ; refresh_jwt: string 9 9 + ; email: string 10 10 + ; blobs_imported: int 11 11 + ; blobs_failed: int 12 12 + ; blobs_cursor: string 13 13 + ; plc_requested: bool } 14 14 + [@@deriving yojson] 15 15 + 16 16 + let state_key = "pegasus.migration_state" 17 17 + 18 18 + let get req = 19 19 + match Dream.session_field req state_key with 20 20 + | Some json -> ( 21 21 + match of_yojson (Yojson.Safe.from_string json) with 22 22 + | Ok state -> 23 23 + Some state 24 24 + | Error _ -> 25 25 + None ) 26 26 + | None -> 27 27 + None 28 28 + 29 29 + let set req state = 30 30 + Dream.set_session_field req state_key 31 31 + (Yojson.Safe.to_string (to_yojson state)) 32 32 + 33 33 + let clear req = Dream.drop_session_field req state_key 34 34 + 35 35 + (* possible states for resuming an existing deactivated account *) 36 36 + type resume_state = 37 37 + | NeedsRepoImport 38 38 + | NeedsBlobImport 39 39 + | NeedsPlcUpdate 40 40 + | NeedsActivation 41 41 + | AlreadyActive 42 42 + 43 43 + let normalize_endpoint s = 44 44 + if String.length s > 0 && s.[String.length s - 1] = '/' then 45 45 + String.sub s 0 (String.length s - 1) 46 46 + else s 47 47 + 48 48 + let check_identity_updated did = 49 49 + match%lwt Id_resolver.Did.resolve ~skip_cache:true did with 50 50 + | Error e -> 51 51 + Lwt.return_error ("Failed to resolve DID: " ^ e) 52 52 + | Ok doc -> ( 53 53 + match Id_resolver.Did.Document.get_service doc "#atproto_pds" with 54 54 + | None -> 55 55 + Lwt.return_error "DID document missing PDS service" 56 56 + | Some endpoint -> 57 57 + let normalized_endpoint = normalize_endpoint endpoint in 58 58 + let normalized_host = normalize_endpoint Env.host_endpoint in 59 59 + if normalized_endpoint = normalized_host then Lwt.return_ok true 60 60 + else Lwt.return_ok false ) 61 61 + 62 62 + let check_resume_state ~did db = 63 63 + match%lwt Data_store.get_actor_by_identifier did db with 64 64 + | None -> 65 65 + Lwt.return_error "Account not found" 66 66 + | Some actor when actor.deactivated_at = None -> 67 67 + Lwt.return_ok AlreadyActive 68 68 + | Some _actor -> ( 69 69 + match%lwt check_identity_updated did with 70 70 + | Ok true -> 71 71 + Lwt.return_ok NeedsActivation 72 72 + | _ -> ( 73 73 + try%lwt 74 74 + let%lwt us = User_store.connect ~create:false did in 75 75 + let%lwt record_count = User_store.count_records us in 76 76 + if record_count > 0 then 77 77 + match%lwt User_store.count_blobs us with 78 78 + | cnt when cnt > 0 -> 79 79 + Lwt.return_ok NeedsPlcUpdate 80 80 + | _ -> 81 81 + Lwt.return_ok NeedsBlobImport 82 82 + else Lwt.return_ok NeedsRepoImport 83 83 + with _ -> Lwt.return_ok NeedsRepoImport ) )