+12 -12

bin/main.ml

··· 2 2 open Dream 3 3 4 4 let () = 5 5 - Rate_limiter.Shared.register ~name:"repo-write-hour" ~duration_ms:Util.hour 5 5 + Rate_limiter.Shared.register ~name:"repo-write-hour" ~duration_ms:Util.Time.hour 6 6 ~points:5000 ; 7 7 - Rate_limiter.Shared.register ~name:"repo-write-day" ~duration_ms:Util.day 7 7 + Rate_limiter.Shared.register ~name:"repo-write-day" ~duration_ms:Util.Time.day 8 8 ~points:35000 9 9 10 10 let handlers = ··· 35 35 ; (post, "/account/security", Api.Account_.Security.Index.post_handler) 36 36 ; ( get 37 37 , "/account/security/backup-codes" 38 38 - , Api.Account_.Security.Backup_codes.count_handler ) 38 38 + , Api.Account_.Security.Security_backup_codes.count_handler ) 39 39 ; ( post 40 40 , "/account/security/backup-codes/regenerate" 41 41 - , Api.Account_.Security.Backup_codes.regenerate_handler ) 41 41 + , Api.Account_.Security.Security_backup_codes.regenerate_handler ) 42 42 ; ( get 43 43 , "/account/security/totp/setup" 44 44 - , Api.Account_.Security.Totp.setup_handler ) 44 44 + , Api.Account_.Security.Security_totp.setup_handler ) 45 45 ; ( post 46 46 , "/account/security/totp/verify" 47 47 - , Api.Account_.Security.Totp.verify_handler ) 47 47 + , Api.Account_.Security.Security_totp.verify_handler ) 48 48 ; ( post 49 49 , "/account/security/totp/disable" 50 50 - , Api.Account_.Security.Totp.disable_handler ) 50 50 + , Api.Account_.Security.Security_totp.disable_handler ) 51 51 ; ( get 52 52 , "/account/security/keys" 53 53 - , Api.Account_.Security.Security_key.list_handler ) 53 53 + , Api.Account_.Security.Security_keys.list_handler ) 54 54 ; ( post 55 55 , "/account/security/keys/setup" 56 56 - , Api.Account_.Security.Security_key.setup_handler ) 56 56 + , Api.Account_.Security.Security_keys.setup_handler ) 57 57 ; ( post 58 58 , "/account/security/keys/:id/verify" 59 59 - , Api.Account_.Security.Security_key.verify_handler ) 59 59 + , Api.Account_.Security.Security_keys.verify_handler ) 60 60 ; ( post 61 61 , "/account/security/keys/:id/resync" 62 62 - , Api.Account_.Security.Security_key.resync_handler ) 62 62 + , Api.Account_.Security.Security_keys.resync_handler ) 63 63 ; ( delete 64 64 , "/account/security/keys/:id" 65 65 - , Api.Account_.Security.Security_key.delete_handler ) 65 65 + , Api.Account_.Security.Security_keys.delete_handler ) 66 66 ; (get, "/account/permissions", Api.Account_.Permissions.get_handler) 67 67 ; (post, "/account/permissions", Api.Account_.Permissions.post_handler) 68 68 ; (get, "/account/identity", Api.Account_.Identity.get_handler)

+10 -10

pegasus/bench/bench_repository.ml

··· 50 50 51 51 let setup_test_db () : (User_store.t * string) Lwt.t = 52 52 let path, uri = create_temp_db () in 53 53 - let%lwt pool = Util.connect_sqlite ~create:true ~write:true uri in 53 53 + let%lwt pool = Util.Sqlite.connect ~create:true ~write:true uri in 54 54 let%lwt () = Migrations.run_migrations User_store pool in 55 55 let db : User_store.t = {did= "did:plc:bench"; db= pool} in 56 56 Lwt.return (db, path) ··· 175 175 let blocks = generate_blocks size in 176 176 let%lwt r1 = 177 177 time_it (Printf.sprintf "Bulk.put_blocks (%d blocks)" size) (fun () -> 178 178 - Util.use_pool db.db (fun conn -> User_store.Bulk.put_blocks blocks conn) 178 178 + Util.Sqlite.use_pool db.db (fun conn -> User_store.Bulk.put_blocks blocks conn) 179 179 >|= fun _ -> () ) 180 180 in 181 181 print_result r1 ; ··· 184 184 let records = generate_record_data size in 185 185 let%lwt r2 = 186 186 time_it (Printf.sprintf "Bulk.put_records (%d records)" size) (fun () -> 187 187 - Util.use_pool db2.db (fun conn -> User_store.Bulk.put_records records conn) 187 187 + Util.Sqlite.use_pool db2.db (fun conn -> User_store.Bulk.put_records records conn) 188 188 >|= fun _ -> () ) 189 189 in 190 190 print_result r2 ; ··· 200 200 let records = generate_record_data size in 201 201 let kv_pairs = List.map (fun (path, cid, _, _) -> (path, cid)) records in 202 202 let%lwt () = 203 203 - Util.use_pool db.db (fun conn -> User_store.Bulk.put_records records conn) 203 203 + Util.Sqlite.use_pool db.db (fun conn -> User_store.Bulk.put_records records conn) 204 204 >|= fun _ -> () 205 205 in 206 206 let%lwt r1 = ··· 231 231 let initial_records = generate_record_data initial_size in 232 232 let initial_kv = List.map (fun (path, cid, _, _) -> (path, cid)) initial_records in 233 233 let%lwt () = 234 234 - Util.use_pool db.db (fun conn -> User_store.Bulk.put_records initial_records conn) 234 234 + Util.Sqlite.use_pool db.db (fun conn -> User_store.Bulk.put_records initial_records conn) 235 235 >|= fun _ -> () 236 236 in 237 237 let%lwt mst = Mst.of_assoc db initial_kv in 238 238 let add_records = generate_record_data add_count in 239 239 let add_kv = List.map (fun (path, cid, _, _) -> (path, cid)) add_records in 240 240 let%lwt () = 241 241 - Util.use_pool db.db (fun conn -> User_store.Bulk.put_records add_records conn) 241 241 + Util.Sqlite.use_pool db.db (fun conn -> User_store.Bulk.put_records add_records conn) 242 242 >|= fun _ -> () 243 243 in 244 244 let%lwt r1 = ··· 332 332 let%lwt db, path = setup_test_db () in 333 333 let records = generate_record_data size in 334 334 let%lwt () = 335 335 - Util.use_pool db.db (fun conn -> User_store.Bulk.put_records records conn) 335 335 + Util.Sqlite.use_pool db.db (fun conn -> User_store.Bulk.put_records records conn) 336 336 >|= fun _ -> () 337 337 in 338 338 let%lwt r1 = ··· 352 352 let num_ops = 500 in 353 353 let initial_records = generate_record_data initial_size in 354 354 let%lwt () = 355 355 - Util.use_pool db.db (fun conn -> User_store.Bulk.put_records initial_records conn) 355 355 + Util.Sqlite.use_pool db.db (fun conn -> User_store.Bulk.put_records initial_records conn) 356 356 >|= fun _ -> () 357 357 in 358 358 let initial_kv = List.map (fun (path, cid, _, _) -> (path, cid)) initial_records in 359 359 let%lwt mst = Mst.of_assoc db initial_kv in 360 360 let extra_records = generate_record_data num_ops in 361 361 let%lwt () = 362 362 - Util.use_pool db.db (fun conn -> User_store.Bulk.put_records extra_records conn) 362 362 + Util.Sqlite.use_pool db.db (fun conn -> User_store.Bulk.put_records extra_records conn) 363 363 >|= fun _ -> () 364 364 in 365 365 let existing = ref (shuffle initial_records) in ··· 409 409 let size = 20000 in 410 410 let blocks = generate_blocks size in 411 411 let%lwt () = 412 412 - Util.use_pool db.db (fun conn -> User_store.Bulk.put_blocks blocks conn) >|= fun _ -> () 412 412 + Util.Sqlite.use_pool db.db (fun conn -> User_store.Bulk.put_blocks blocks conn) >|= fun _ -> () 413 413 in 414 414 let cids = List.map fst blocks in 415 415 let shuffled_cids = shuffle cids in

+1 -1

pegasus/lib/api/account_/identity.ml

··· 31 31 Lwt.return_none 32 32 else Lwt.return_none 33 33 in 34 34 - Util.render_html ~title:"Identity" 34 34 + Util.Html.render_page ~title:"Identity" 35 35 (module Frontend.AccountIdentityPage) 36 36 ~props: 37 37 { current_user

+8 -8

pegasus/lib/api/account_/index.ml

··· 1 1 let has_valid_delete_code (actor : Data_store.Types.actor) = 2 2 match (actor.auth_code, actor.auth_code_expires_at) with 3 3 | Some code, Some expires_at -> 4 4 - String.starts_with ~prefix:"del-" code && expires_at > Util.now_ms () 4 4 + String.starts_with ~prefix:"del-" code && expires_at > Util.Time.now_ms () 5 5 | _ -> 6 6 false 7 7 8 8 let has_valid_email_change_code (actor : Data_store.Types.actor) = 9 9 match (actor.auth_code, actor.auth_code_expires_at, actor.pending_email) with 10 10 | Some _, Some expires_at, Some _ -> 11 11 - expires_at > Util.now_ms () 11 11 + expires_at > Util.Time.now_ms () 12 12 | _ -> 13 13 false 14 14 15 15 let has_valid_email_confirmation_code (actor : Data_store.Types.actor) = 16 16 match (actor.auth_code, actor.auth_code_expires_at, actor.pending_email) with 17 17 | Some _, Some expires_at, None -> 18 18 - expires_at > Util.now_ms () 18 18 + expires_at > Util.Time.now_ms () 19 19 | _ -> 20 20 false 21 21 ··· 47 47 let email_change_pending = has_valid_email_change_code actor in 48 48 let pending_email = actor.pending_email in 49 49 let delete_pending = has_valid_delete_code actor in 50 50 - Util.render_html ~title:"Account" 50 50 + Util.Html.render_page ~title:"Account" 51 51 (module Frontend.AccountPage) 52 52 ~props: 53 53 { current_user ··· 101 101 let email_change_pending = has_valid_email_change_code actor in 102 102 let pending_email = actor.pending_email in 103 103 let delete_pending = has_valid_delete_code actor in 104 104 - Util.render_html ~title:"Account" 104 104 + Util.Html.render_page ~title:"Account" 105 105 (module Frontend.AccountPage) 106 106 ~props: 107 107 { current_user= {current_user with handle= actor.handle} ··· 133 133 (* update handle if changed *) 134 134 let%lwt handle_result = 135 135 if new_handle <> actor.handle then 136 136 - Identity.UpdateHandle.update_handle ~did 136 136 + Identity_util.update_handle ~did 137 137 ~handle:new_handle ctx.db 138 138 else Lwt.return_ok () 139 139 in ··· 177 177 | Some code, Some expires_at 178 178 when String.starts_with ~prefix:"del-" code 179 179 && code = token 180 180 - && expires_at > Util.now_ms () -> 180 180 + && expires_at > Util.Time.now_ms () -> 181 181 let%lwt _ = 182 182 Server.DeleteAccount.delete_account ~did ctx.db 183 183 in ··· 222 222 match%lwt 223 223 match (actor.auth_code, actor.auth_code_expires_at) with 224 224 | Some code, Some expiry 225 225 - when Some code = token && expiry > Util.now_ms () -> 225 225 + when Some code = token && expiry > Util.Time.now_ms () -> 226 226 Server.UpdateEmail.update_email ~token actor ctx.db 227 227 | _ -> 228 228 Lwt.return_error Server.UpdateEmail.InvalidToken

+7 -7

pegasus/lib/api/account_/login.ml

··· 2 2 Xrpc.handler (fun ctx -> 3 3 let redirect_url = 4 4 if List.length @@ Dream.all_queries ctx.req > 0 then 5 5 - Uri.make ~path:"/oauth/authorize" ~query:(Util.copy_query ctx.req) () 5 5 + Uri.make ~path:"/oauth/authorize" ~query:(Util.Http.copy_query ctx.req) () 6 6 |> Uri.to_string 7 7 else "/account" 8 8 in 9 9 let csrf_token = Dream.csrf_token ctx.req in 10 10 - Util.render_html ~title:"Login" 10 10 + Util.Html.render_page ~title:"Login" 11 11 (module Frontend.LoginPage) 12 12 ~props: 13 13 { redirect_url ··· 69 69 with 70 70 | None -> 71 71 let error = "Session expired. Please try again." in 72 72 - Util.render_html ~status:`Unauthorized ~title:"Login" 72 72 + Util.Html.render_page ~status:`Unauthorized ~title:"Login" 73 73 (module Frontend.LoginPage) 74 74 ~props: 75 75 { redirect_url ··· 95 95 let%lwt methods = 96 96 Two_factor.get_available_methods ~did:pending.did ctx.db 97 97 in 98 98 - Util.render_html ~status:`Unauthorized ~title:"Login" 98 98 + Util.Html.render_page ~status:`Unauthorized ~title:"Login" 99 99 (module Frontend.LoginPage) 100 100 ~props: 101 101 { redirect_url ··· 115 115 let error = 116 116 "Invalid username or password. Please try again." 117 117 in 118 118 - Util.render_html ~status:`Unauthorized ~title:"Login" 118 118 + Util.Html.render_page ~status:`Unauthorized ~title:"Login" 119 119 (module Frontend.LoginPage) 120 120 ~props: 121 121 { redirect_url ··· 145 145 Lwt.return () 146 146 else Lwt.return () 147 147 in 148 148 - Util.render_html ~title:"Login" 148 148 + Util.Html.render_page ~title:"Login" 149 149 (module Frontend.LoginPage) 150 150 ~props: 151 151 { redirect_url ··· 160 160 | _ -> 161 161 let redirect_url = "/account" in 162 162 let error = "Something went wrong, go back and try again." in 163 163 - Util.render_html ~status:`Unauthorized ~title:"Login" 163 163 + Util.Html.render_page ~status:`Unauthorized ~title:"Login" 164 164 (module Frontend.LoginPage) 165 165 ~props: 166 166 { redirect_url

+25 -25

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

··· 36 36 let render_error ~csrf_token ~invite_required ~hostname 37 37 ?(step = "enter_credentials") ?did ?handle ?old_pds ?identifier ?invite_code 38 38 error = 39 39 - Util.render_html ~status:`Bad_Request ~title:"Migrate Account" 39 39 + Util.Html.render_page ~status:`Bad_Request ~title:"Migrate Account" 40 40 (module Frontend.MigratePage) 41 41 ~props: 42 42 (make_props ~csrf_token ~invite_required ~hostname ~step ?did ?handle ··· 95 95 log "migration %s: failed to deactivate old account: %s" did e ) ; 96 96 (false, Some e) 97 97 in 98 98 - Util.render_html ~title:"Migrate Account" 98 98 + Util.Html.render_page ~title:"Migrate Account" 99 99 (module Frontend.MigratePage) 100 100 ~props: 101 101 (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" ··· 106 106 identity is pointing to this PDS." 107 107 () ) 108 108 | _ -> 109 109 - Util.render_html ~title:"Migrate Account" 109 109 + Util.Html.render_page ~title:"Migrate Account" 110 110 (module Frontend.MigratePage) 111 111 ~props: 112 112 (make_props ~csrf_token ~invite_required ~hostname ~step:"error" ··· 123 123 else 124 124 match session with 125 125 | None -> 126 126 - Util.render_html ~status:`Internal_Server_Error ~title:"Migrate Account" 126 126 + Util.Html.render_page ~status:`Internal_Server_Error ~title:"Migrate Account" 127 127 (module Frontend.MigratePage) 128 128 ~props: 129 129 (make_props ~csrf_token ~invite_required ~hostname ~step:"error" ··· 145 145 ; blobs_cursor= "" 146 146 ; plc_requested= true } 147 147 in 148 148 - Util.render_html ~title:"Migrate Account" 148 148 + Util.Html.render_page ~title:"Migrate Account" 149 149 (module Frontend.MigratePage) 150 150 ~props: 151 151 (make_props ~csrf_token ~invite_required ~hostname ··· 172 172 ; blobs_cursor= "" 173 173 ; plc_requested= true } 174 174 in 175 175 - Util.render_html ~title:"Migrate Account" 175 175 + Util.Html.render_page ~title:"Migrate Account" 176 176 (module Frontend.MigratePage) 177 177 ~props: 178 178 (make_props ~csrf_token ~invite_required ~hostname ··· 243 243 in 244 244 match step with 245 245 | "resume_available" -> 246 246 - Util.render_html ~title:"Migrate Account" 246 246 + Util.Html.render_page ~title:"Migrate Account" 247 247 (module Frontend.MigratePage) 248 248 ~props: 249 249 (make_props ~csrf_token ~invite_required ~hostname ··· 262 262 ; blobs_cursor= "" 263 263 ; plc_requested= false } 264 264 in 265 265 - Util.render_html ~title:"Migrate Account" 265 265 + Util.Html.render_page ~title:"Migrate Account" 266 266 (module Frontend.MigratePage) 267 267 ~props: 268 268 (make_props ~csrf_token ~invite_required ~hostname ··· 282 282 ; blobs_cursor= "" 283 283 ; plc_requested= true } 284 284 in 285 285 - Util.render_html ~title:"Migrate Account" 285 285 + Util.Html.render_page ~title:"Migrate Account" 286 286 (module Frontend.MigratePage) 287 287 ~props: 288 288 (make_props ~csrf_token ~invite_required ~hostname ··· 294 294 code." 295 295 () ) 296 296 | "complete" -> 297 297 - Util.render_html ~title:"Migrate Account" 297 297 + Util.Html.render_page ~title:"Migrate Account" 298 298 (module Frontend.MigratePage) 299 299 ~props: 300 300 (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" ··· 302 302 ~blobs_failed:0 ~old_account_deactivated:true 303 303 ~message:"Your account has been successfully migrated!" () ) 304 304 | "complete_deactivation_failed" -> 305 305 - Util.render_html ~title:"Migrate Account" 305 305 + Util.Html.render_page ~title:"Migrate Account" 306 306 (module Frontend.MigratePage) 307 307 ~props: 308 308 (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" ··· 312 312 "Failed to deactivate old account (401): Unauthorized" 313 313 ~message:"Your account has been successfully migrated!" () ) 314 314 | "error" | _ -> 315 315 - Util.render_html ~title:"Migrate Account" 315 315 + Util.Html.render_page ~title:"Migrate Account" 316 316 (module Frontend.MigratePage) 317 317 ~props: 318 318 (make_props ~csrf_token ~invite_required ~hostname ~step:"error" ()) ··· 329 329 | Remote.AuthError e -> 330 330 render_err e 331 331 | Remote.AuthNeeds2FA -> 332 332 - Util.render_html ~title:"Migrate Account" 332 332 + Util.Html.render_page ~title:"Migrate Account" 333 333 (module Frontend.MigratePage) 334 334 ~props: 335 335 (make_props ~csrf_token ~invite_required ~hostname ~step:"enter_2fa" ··· 380 380 render_err ~did ~handle ~old_pds e 381 381 | Ok State.AlreadyActive -> 382 382 let%lwt () = Session.log_in_did ctx.req did in 383 383 - Util.render_html ~title:"Migrate Account" 383 383 + Util.Html.render_page ~title:"Migrate Account" 384 384 (module Frontend.MigratePage) 385 385 ~props: 386 386 (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" ··· 400 400 log "migration %s: failed to deactivate old account: %s" did err ) ; 401 401 (false, Some err) 402 402 in 403 403 - Util.render_html ~title:"Migrate Account" 403 403 + Util.Html.render_page ~title:"Migrate Account" 404 404 (module Frontend.MigratePage) 405 405 ~props: 406 406 (make_props ~csrf_token ~invite_required ~hostname ~step:"complete" ··· 484 484 ; blobs_cursor= cursor 485 485 ; plc_requested= false } 486 486 in 487 487 - Util.render_html ~title:"Migrate Account" 487 487 + Util.Html.render_page ~title:"Migrate Account" 488 488 (module Frontend.MigratePage) 489 489 ~props: 490 490 (make_props ~csrf_token ~invite_required ~hostname ··· 543 543 ; blobs_failed= new_failed 544 544 ; blobs_cursor= new_cursor } 545 545 in 546 546 - Util.render_html ~title:"Migrate Account" 546 546 + Util.Html.render_page ~title:"Migrate Account" 547 547 (module Frontend.MigratePage) 548 548 ~props: 549 549 (make_props ~csrf_token ~invite_required ~hostname ··· 662 662 state.did e ) ; 663 663 (false, Some e) 664 664 in 665 665 - Util.render_html ~title:"Migrate Account" 665 665 + Util.Html.render_page ~title:"Migrate Account" 666 666 (module Frontend.MigratePage) 667 667 ~props: 668 668 (make_props ~csrf_token ~invite_required ~hostname ··· 689 689 | Ok old_client -> ( 690 690 match%lwt Remote.request_plc_signature old_client with 691 691 | Error e -> 692 692 - Util.render_html ~title:"Migrate Account" 692 692 + Util.Html.render_page ~title:"Migrate Account" 693 693 (module Frontend.MigratePage) 694 694 ~props: 695 695 (make_props ~csrf_token ~invite_required ~hostname 696 696 ~step:"enter_plc_token" ~did:state.did ~handle:state.handle 697 697 ~old_pds:state.old_pds ~error:("Failed to resend: " ^ e) () ) 698 698 | Ok () -> 699 699 - Util.render_html ~title:"Migrate Account" 699 699 + Util.Html.render_page ~title:"Migrate Account" 700 700 (module Frontend.MigratePage) 701 701 ~props: 702 702 (make_props ~csrf_token ~invite_required ~hostname ··· 811 811 | Remote.AuthError e -> 812 812 render_err ~step:"resume_available" e 813 813 | Remote.AuthNeeds2FA -> 814 814 - Util.render_html ~title:"Migrate Account" 814 814 + Util.Html.render_page ~title:"Migrate Account" 815 815 (module Frontend.MigratePage) 816 816 ~props: 817 817 (make_props ~csrf_token ~invite_required ~hostname ··· 834 834 render_err ~step:"resume_available" ~did ~handle ~old_pds e 835 835 | Ok State.AlreadyActive -> 836 836 let%lwt () = Session.log_in_did ctx.req did in 837 837 - Util.render_html ~title:"Migrate Account" 837 837 + Util.Html.render_page ~title:"Migrate Account" 838 838 (module Frontend.MigratePage) 839 839 ~props: 840 840 (make_props ~csrf_token ~invite_required ~hostname ··· 860 860 did e ) ; 861 861 (false, Some e) 862 862 in 863 863 - Util.render_html ~title:"Migrate Account" 863 863 + Util.Html.render_page ~title:"Migrate Account" 864 864 (module Frontend.MigratePage) 865 865 ~props: 866 866 (make_props ~csrf_token ~invite_required ~hostname ··· 919 919 ; blobs_cursor= cursor 920 920 ; plc_requested= false } 921 921 in 922 922 - Util.render_html ~title:"Migrate Account" 922 922 + Util.Html.render_page ~title:"Migrate Account" 923 923 (module Frontend.MigratePage) 924 924 ~props: 925 925 (make_props ~csrf_token ~invite_required ~hostname ··· 949 949 ~old_pds:state.old_pds ~blobs_imported:state.blobs_imported 950 950 ~blobs_failed:state.blobs_failed () 951 951 in 952 952 - Util.render_html ~title:"Migrate Account" 952 952 + Util.Html.render_page ~title:"Migrate Account" 953 953 (module Frontend.MigratePage) 954 954 ~props ) 955 955

+8 -8

pegasus/lib/api/account_/password_reset.ml

··· 4 4 let step = 5 5 Dream.query ctx.req "step" |> Option.value ~default:"request" 6 6 in 7 7 - Util.render_html ~title:"Reset Password" 7 7 + Util.Html.render_page ~title:"Reset Password" 8 8 (module Frontend.PasswordResetPage) 9 9 ~props:{csrf_token; step; email_sent_to= None; error= None} ) 10 10 ··· 25 25 List.assoc_opt "password" fields |> Option.value ~default:"" 26 26 in 27 27 if String.length token = 0 then 28 28 - Util.render_html ~status:`Bad_Request ~title:"Reset Password" 28 28 + Util.Html.render_page ~status:`Bad_Request ~title:"Reset Password" 29 29 (module Frontend.PasswordResetPage) 30 30 ~props: 31 31 { csrf_token ··· 33 33 ; email_sent_to= None 34 34 ; error= Some "Please enter the reset code." } 35 35 else if String.length password < 8 then 36 36 - Util.render_html ~status:`Bad_Request ~title:"Reset Password" 36 36 + Util.Html.render_page ~status:`Bad_Request ~title:"Reset Password" 37 37 (module Frontend.PasswordResetPage) 38 38 ~props: 39 39 { csrf_token ··· 45 45 Server.ResetPassword.reset_password ~token ~password ctx.db 46 46 with 47 47 | Ok _ -> 48 48 - Util.render_html ~title:"Reset Password" 48 48 + Util.Html.render_page ~title:"Reset Password" 49 49 (module Frontend.PasswordResetPage) 50 50 ~props: 51 51 { csrf_token ··· 54 54 ; error= None } 55 55 | Error Server.ResetPassword.InvalidToken 56 56 | Error Server.ResetPassword.ExpiredToken -> 57 57 - Util.render_html ~status:`Bad_Request ~title:"Reset Password" 57 57 + Util.Html.render_page ~status:`Bad_Request ~title:"Reset Password" 58 58 (module Frontend.PasswordResetPage) 59 59 ~props: 60 60 { csrf_token ··· 71 71 |> String.lowercase_ascii 72 72 in 73 73 if String.length email = 0 then 74 74 - Util.render_html ~status:`Bad_Request ~title:"Reset Password" 74 74 + Util.Html.render_page ~status:`Bad_Request ~title:"Reset Password" 75 75 (module Frontend.PasswordResetPage) 76 76 ~props: 77 77 { csrf_token ··· 87 87 | None -> 88 88 Lwt.return_unit 89 89 in 90 90 - Util.render_html ~title:"Reset Password" 90 90 + Util.Html.render_page ~title:"Reset Password" 91 91 (module Frontend.PasswordResetPage) 92 92 ~props: 93 93 { csrf_token ··· 95 95 ; email_sent_to= Some email 96 96 ; error= None } ) 97 97 | _ -> 98 98 - Util.render_html ~status:`Bad_Request ~title:"Reset Password" 98 98 + Util.Html.render_page ~status:`Bad_Request ~title:"Reset Password" 99 99 (module Frontend.PasswordResetPage) 100 100 ~props: 101 101 { csrf_token

+1 -1

pegasus/lib/api/account_/permissions.ml

··· 68 68 : Frontend.AccountPermissionsPage.device ) ) 69 69 device_rows 70 70 in 71 71 - Util.render_html ~title:"Permissions" 71 71 + Util.Html.render_page ~title:"Permissions" 72 72 (module Frontend.AccountPermissionsPage) 73 73 ~props: 74 74 { current_user

pegasus/lib/api/account_/security/backup_codes.ml pegasus/lib/api/account_/security/security_backup_codes.ml

+1 -1

pegasus/lib/api/account_/security/index.ml

··· 53 53 let%lwt two_fa_status = Two_factor.get_status ~did ctx.db in 54 54 let error = Dream.query ctx.req "error" in 55 55 let success = Dream.query ctx.req "success" in 56 56 - Util.render_html ~title:"Security" 56 56 + Util.Html.render_page ~title:"Security" 57 57 (module Frontend.AccountSecurityPage) 58 58 ~props: 59 59 { current_user

pegasus/lib/api/account_/security/security_key.ml pegasus/lib/api/account_/security/security_keys.ml

pegasus/lib/api/account_/security/totp.ml pegasus/lib/api/account_/security/security_totp.ml

+11 -11

pegasus/lib/api/account_/signup.ml

··· 17 17 if String.contains handle_input '.' then handle_input 18 18 else handle_input ^ hostname_suffix 19 19 in 20 20 - let validation_result = Util.validate_handle handle in 20 20 + let validation_result = Identity_util.validate_handle handle in 21 21 match validation_result with 22 22 | Error (InvalidFormat e) | Error (TooLong e) | Error (TooShort e) -> 23 23 Dream.json @@ Yojson.Safe.to_string ··· 44 44 let csrf_token = Dream.csrf_token ctx.req in 45 45 let invite_required = Env.invite_required in 46 46 let hostname = Env.hostname in 47 47 - Util.render_html ~title:"Sign Up" 47 47 + Util.Html.render_page ~title:"Sign Up" 48 48 (module Frontend.SignupPage) 49 49 ~props:{csrf_token; invite_required; hostname; error= None} ) 50 50 ··· 85 85 ?invite_code ctx.db 86 86 with 87 87 | Error Server.CreateAccount.InviteCodeRequired -> 88 88 - Util.render_html ~status:`Bad_Request ~title:"Sign Up" 88 88 + Util.Html.render_page ~status:`Bad_Request ~title:"Sign Up" 89 89 (module Frontend.SignupPage) 90 90 ~props: 91 91 { props with 92 92 error= Some "An invite code is required to sign up." } 93 93 | Error Server.CreateAccount.InvalidInviteCode -> 94 94 - Util.render_html ~status:`Bad_Request ~title:"Sign Up" 94 94 + Util.Html.render_page ~status:`Bad_Request ~title:"Sign Up" 95 95 (module Frontend.SignupPage) 96 96 ~props:{props with error= Some "Invalid invite code."} 97 97 | Error (Server.CreateAccount.InvalidHandle e) -> 98 98 - Util.render_html ~status:`Bad_Request ~title:"Sign Up" 98 98 + Util.Html.render_page ~status:`Bad_Request ~title:"Sign Up" 99 99 (module Frontend.SignupPage) 100 100 ~props:{props with error= Some e} 101 101 | Error Server.CreateAccount.EmailAlreadyExists -> 102 102 - Util.render_html ~status:`Bad_Request ~title:"Sign Up" 102 102 + Util.Html.render_page ~status:`Bad_Request ~title:"Sign Up" 103 103 (module Frontend.SignupPage) 104 104 ~props: 105 105 { props with 106 106 error= Some "An account with that email already exists." } 107 107 | Error Server.CreateAccount.HandleAlreadyExists -> 108 108 - Util.render_html ~status:`Bad_Request ~title:"Sign Up" 108 108 + Util.Html.render_page ~status:`Bad_Request ~title:"Sign Up" 109 109 (module Frontend.SignupPage) 110 110 ~props: 111 111 { props with 112 112 error= Some "An account with that handle already exists." } 113 113 | Error Server.CreateAccount.DidAlreadyExists -> 114 114 - Util.render_html ~status:`Bad_Request ~title:"Sign Up" 114 114 + Util.Html.render_page ~status:`Bad_Request ~title:"Sign Up" 115 115 (module Frontend.SignupPage) 116 116 ~props: 117 117 { props with 118 118 error= Some "An account with that DID already exists." } 119 119 | Error (Server.CreateAccount.PlcError _) -> 120 120 - Util.render_html ~status:`Internal_Server_Error ~title:"Sign Up" 120 120 + Util.Html.render_page ~status:`Internal_Server_Error ~title:"Sign Up" 121 121 (module Frontend.SignupPage) 122 122 ~props: 123 123 { props with ··· 126 126 "Failed to create your identity. Please try again \ 127 127 later." } 128 128 | Error Server.CreateAccount.InviteUseFailure -> 129 129 - Util.render_html ~status:`Internal_Server_Error ~title:"Sign Up" 129 129 + Util.Html.render_page ~status:`Internal_Server_Error ~title:"Sign Up" 130 130 (module Frontend.SignupPage) 131 131 ~props: 132 132 { props with ··· 137 137 let%lwt () = Session.log_in_did ctx.req did in 138 138 Dream.redirect ctx.req "/account" ) 139 139 | _ -> 140 140 - Util.render_html ~status:`Bad_Request ~title:"Sign Up" 140 140 + Util.Html.render_page ~status:`Bad_Request ~title:"Sign Up" 141 141 (module Frontend.SignupPage) 142 142 ~props: 143 143 { props with

+3 -3

pegasus/lib/api/admin/getAccountInfo.ml

··· 4 4 { did= actor.did 5 5 ; handle= actor.handle 6 6 ; email= Some actor.email 7 7 - ; email_confirmed_at= Option.map Util.ms_to_iso8601 actor.email_confirmed_at 8 8 - ; indexed_at= Util.ms_to_iso8601 actor.created_at 9 9 - ; deactivated_at= Option.map Util.ms_to_iso8601 actor.deactivated_at 7 7 + ; email_confirmed_at= Option.map Util.Time.ms_to_iso8601 actor.email_confirmed_at 8 8 + ; indexed_at= Util.Time.ms_to_iso8601 actor.created_at 9 9 + ; deactivated_at= Option.map Util.Time.ms_to_iso8601 actor.deactivated_at 10 10 ; related_records= None 11 11 ; invited_by= None 12 12 ; invites= None

+2 -2

pegasus/lib/api/admin/updateAccountHandle.ml

··· 7 7 | None -> 8 8 Errors.invalid_request "account not found" 9 9 | Some _ -> ( 10 10 - match%lwt Identity.UpdateHandle.update_handle ~did ~handle db with 10 10 + match%lwt Identity_util.update_handle ~did ~handle db with 11 11 | Ok () -> 12 12 Dream.empty `OK 13 13 | Error e -> 14 14 Errors.invalid_request ~name:"InvalidHandle" 15 15 - (Identity.UpdateHandle.update_handle_error_to_string e) ) ) 15 15 + (Identity_util.update_handle_error_to_string e) ) )

+2 -2

pegasus/lib/api/admin_/blobs.ml

··· 114 114 let%lwt blobs, next_cursor = list_all_blobs ~limit ~cursor ctx.db in 115 115 let blobs = List.map blob_to_view blobs in 116 116 let csrf_token = Dream.csrf_token ctx.req in 117 117 - Util.render_html ~title:"Admin / Blobs" 117 117 + Util.Html.render_page ~title:"Admin / Blobs" 118 118 (module Frontend.AdminBlobsPage) 119 119 ~props: 120 120 { blobs ··· 172 172 let limit = 50 in 173 173 let%lwt blobs, next_cursor = list_all_blobs ~limit ~cursor ctx.db in 174 174 let blobs = List.map blob_to_view blobs in 175 175 - Util.render_html ~title:"Admin / Blobs" 175 175 + Util.Html.render_page ~title:"Admin / Blobs" 176 176 (module Frontend.AdminBlobsPage) 177 177 ~props:{blobs; csrf_token; cursor; next_cursor; error; success} 178 178 in

+2 -2

pegasus/lib/api/admin_/invites.ml

··· 11 11 let%lwt invites = Data_store.list_invites ~limit:100 ctx.db in 12 12 let invites = List.map invite_to_view invites in 13 13 let csrf_token = Dream.csrf_token ctx.req in 14 14 - Util.render_html ~title:"Admin / Invite Codes" 14 14 + Util.Html.render_page ~title:"Admin / Invite Codes" 15 15 (module Frontend.AdminInvitesPage) 16 16 ~props:{invites; csrf_token; error= None; success= None} ) 17 17 ··· 25 25 let render_page ?error ?success () = 26 26 let%lwt invites = Data_store.list_invites ~limit:100 ctx.db in 27 27 let invites = List.map invite_to_view invites in 28 28 - Util.render_html ~title:"Admin / Invite Codes" 28 28 + Util.Html.render_page ~title:"Admin / Invite Codes" 29 29 (module Frontend.AdminInvitesPage) 30 30 ~props:{invites; csrf_token; error; success} 31 31 in

+3 -3

pegasus/lib/api/admin_/login.ml

··· 5 5 Dream.redirect ctx.req "/admin/users" 6 6 | false -> 7 7 let csrf_token = Dream.csrf_token ctx.req in 8 8 - Util.render_html ~title:"Admin Login" 8 8 + Util.Html.render_page ~title:"Admin Login" 9 9 (module Frontend.AdminLoginPage) 10 10 ~props:{csrf_token; error= None} ) 11 11 ··· 21 21 let%lwt () = Session.set_admin_authenticated ctx.req true in 22 22 Dream.redirect ctx.req "/admin/users" 23 23 else 24 24 - Util.render_html ~status:`Unauthorized ~title:"Admin Login" 24 24 + Util.Html.render_page ~status:`Unauthorized ~title:"Admin Login" 25 25 (module Frontend.AdminLoginPage) 26 26 ~props:{csrf_token; error= Some "Invalid password."} 27 27 | _ -> 28 28 - Util.render_html ~status:`Unauthorized ~title:"Admin Login" 28 28 + Util.Html.render_page ~status:`Unauthorized ~title:"Admin Login" 29 29 (module Frontend.AdminLoginPage) 30 30 ~props:{csrf_token; error= Some "Invalid form submission."} )

+4 -4

pegasus/lib/api/admin_/users.ml

··· 49 49 let actors = List.map actor_to_view actors in 50 50 let csrf_token = Dream.csrf_token ctx.req in 51 51 let hostname = Env.hostname in 52 52 - Util.render_html ~title:"Admin / Users" 52 52 + Util.Html.render_page ~title:"Admin / Users" 53 53 (module Frontend.AdminUsersPage) 54 54 ~props: 55 55 { actors ··· 96 96 None 97 97 else None 98 98 in 99 99 - Util.render_html ~title:"Admin / Users" 99 99 + Util.Html.render_page ~title:"Admin / Users" 100 100 (module Frontend.AdminUsersPage) 101 101 ~props: 102 102 { actors ··· 137 137 if String.contains handle_input '.' then handle_input 138 138 else handle_input ^ hostname_suffix 139 139 in 140 140 - match Util.validate_handle handle with 140 140 + match Identity_util.validate_handle handle with 141 141 | Error (InvalidFormat e) 142 142 | Error (TooLong e) 143 143 | Error (TooShort e) -> ··· 204 204 List.assoc_opt "handle" fields |> Option.value ~default:"" 205 205 in 206 206 match%lwt 207 207 - Identity.UpdateHandle.update_handle ~did ~handle ctx.db 207 207 + Identity_util.update_handle ~did ~handle ctx.db 208 208 with 209 209 | Ok () -> 210 210 render_page ~success:"Handle updated." ()

+1 -1

pegasus/lib/api/identity/requestPlcOperationSignature.ml

··· 2 2 Xrpc.handler ~auth:Authorization (fun {auth; db; _} -> 3 3 let did = Auth.get_authed_did_exn auth in 4 4 let code = Util.make_code () in 5 5 - let expires_at = Util.now_ms () + (60 * 60 * 1000) in 5 5 + let expires_at = Util.Time.now_ms () + (60 * 60 * 1000) in 6 6 let%lwt () = Data_store.set_auth_code ~did ~code ~expires_at db in 7 7 let%lwt {email; handle; _} = 8 8 Data_store.get_actor_by_identifier did db |> Lwt.map Option.get

+2 -2

pegasus/lib/api/identity/signPlcOperation.ml

··· 13 13 | Some actor -> ( 14 14 match (actor.auth_code, actor.auth_code_expires_at) with 15 15 | auth_code, Some auth_expires_at 16 16 - when input.token = auth_code && Util.now_ms () < auth_expires_at -> ( 16 16 + when input.token = auth_code && Util.Time.now_ms () < auth_expires_at -> ( 17 17 match%lwt Plc.get_audit_log did with 18 18 | Ok log -> 19 19 let latest = Mist.Util.last log |> Option.get in ··· 21 21 Option.map 22 22 (fun v -> 23 23 try 24 24 - Util.Did_doc_types.string_map_of_yojson v |> Result.get_ok 24 24 + Util.Types.string_map_of_yojson v |> Result.get_ok 25 25 with _ -> Errors.invalid_request "invalid request body" ) 26 26 input.verification_methods 27 27 in

+4 -85

pegasus/lib/api/identity/updateHandle.ml

··· 1 1 open Lexicons.Com.Atproto.Identity.UpdateHandle.Main 2 2 3 3 - type update_handle_error = 4 4 - | InvalidFormat of string 5 5 - | HandleTaken 6 6 - | TooShort of string 7 7 - | TooLong of string 8 8 - | InternalServerError of string 9 9 - 10 10 - let update_handle_error_to_string = function 11 11 - | InvalidFormat m | TooShort m | TooLong m -> 12 12 - "handle " ^ m 13 13 - | HandleTaken -> 14 14 - "handle already taken" 15 15 - | InternalServerError msg -> 16 16 - msg 17 17 - 18 18 - let update_handle ~did ~handle db = 19 19 - match Util.validate_handle handle with 20 20 - | Error (InvalidFormat e) -> 21 21 - Lwt.return_error (InvalidFormat e) 22 22 - | Error (TooShort e) -> 23 23 - Lwt.return_error (TooShort e) 24 24 - | Error (TooLong e) -> 25 25 - Lwt.return_error (TooLong e) 26 26 - | Ok () -> ( 27 27 - match%lwt Data_store.get_actor_by_identifier handle db with 28 28 - | Some _ -> 29 29 - Lwt.return_error HandleTaken 30 30 - | None -> ( 31 31 - let%lwt {handle= prev_handle; _} = 32 32 - Data_store.get_actor_by_identifier did db |> Lwt.map Option.get 33 33 - in 34 34 - let%lwt () = Data_store.update_actor_handle ~did ~handle db in 35 35 - let%lwt plc_result = 36 36 - if String.starts_with ~prefix:"did:plc:" did then 37 37 - match%lwt Plc.get_audit_log did with 38 38 - | Error e -> 39 39 - Lwt.return_error 40 40 - (InternalServerError ("failed to fetch did doc: " ^ e)) 41 41 - | Ok log -> ( 42 42 - let latest = List.rev log |> List.hd in 43 43 - let aka = 44 44 - match 45 45 - List.mem ("at://" ^ handle) latest.operation.also_known_as 46 46 - with 47 47 - | true -> 48 48 - latest.operation.also_known_as 49 49 - | false -> 50 50 - ("at://" ^ handle) :: latest.operation.also_known_as 51 51 - in 52 52 - let aka = 53 53 - List.filter (fun x -> x <> "at://" ^ prev_handle) aka 54 54 - in 55 55 - let signed = 56 56 - Plc.sign_operation Env.rotation_key 57 57 - (Operation 58 58 - { type'= "plc_operation" 59 59 - ; prev= Some latest.cid 60 60 - ; also_known_as= aka 61 61 - ; rotation_keys= latest.operation.rotation_keys 62 62 - ; verification_methods= 63 63 - latest.operation.verification_methods 64 64 - ; services= latest.operation.services } ) 65 65 - in 66 66 - match%lwt Plc.submit_operation did signed with 67 67 - | Ok _ -> 68 68 - Lwt.return_ok () 69 69 - | Error (status, msg) -> 70 70 - Lwt.return_error 71 71 - (InternalServerError 72 72 - (Printf.sprintf "failed to submit plc operation: %d %s" 73 73 - status msg ) ) ) 74 74 - else Lwt.return_ok () 75 75 - in 76 76 - match plc_result with 77 77 - | Error e -> 78 78 - Lwt.return_error e 79 79 - | Ok () -> 80 80 - let () = Ttl_cache.String_cache.remove Id_resolver.Did.cache did in 81 81 - let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in 82 82 - Lwt.return_ok () ) ) 83 83 - 84 3 let calc_key_did ctx = Some (Auth.get_authed_did_exn ctx.Xrpc.auth) 85 4 86 5 let handler = 87 6 Xrpc.handler ~auth:Authorization 88 7 ~rate_limits: 89 8 [ Route 90 90 - { duration_ms= 5 * Util.minute 9 9 + { duration_ms= 5 * Util.Time.minute 91 10 ; points= 10 92 11 ; calc_key= Some calc_key_did 93 12 ; calc_points= None } 94 13 ; Route 95 95 - { duration_ms= Util.day 14 14 + { duration_ms= Util.Time.day 96 15 ; points= 50 97 16 ; calc_key= Some calc_key_did 98 17 ; calc_points= None } ] ··· 100 19 Auth.assert_identity_scope auth ~attr:Oauth.Scopes.Handle ; 101 20 let did = Auth.get_authed_did_exn auth in 102 21 let%lwt {handle} = Xrpc.parse_body req input_of_yojson in 103 103 - match%lwt update_handle ~did ~handle db with 22 22 + match%lwt Identity_util.update_handle ~did ~handle db with 104 23 | Ok () -> 105 24 Dream.empty `OK 106 25 | Error e -> 107 107 - let msg = update_handle_error_to_string e in 26 26 + let msg = Identity_util.update_handle_error_to_string e in 108 27 Log.err (fun log -> log "%s" msg) ; 109 28 Errors.invalid_request ~name:"InvalidHandle" msg )

+4 -4

pegasus/lib/api/oauth_/authorize.ml

··· 4 4 let get_handler = 5 5 Xrpc.handler (fun ctx -> 6 6 let login_redirect = 7 7 - Uri.make ~path:"/account/login" ~query:(Util.copy_query ctx.req) () 7 7 + Uri.make ~path:"/account/login" ~query:(Util.Http.copy_query ctx.req) () 8 8 |> Uri.to_string |> Dream.redirect ctx.req 9 9 in 10 10 let client_id = Dream.query ctx.req "client_id" in ··· 45 45 ^ Uuidm.to_string 46 46 (Uuidm.v4_gen (Random.State.make_self_init ()) ()) 47 47 in 48 48 - let expires_at = Util.now_ms () + Constants.code_expiry_ms in 48 48 + let expires_at = Util.Time.now_ms () + Constants.code_expiry_ms in 49 49 let%lwt () = 50 50 Queries.insert_auth_code ctx.db 51 51 { code ··· 136 136 Option.value current_user 137 137 ~default:(List.hd logged_in_users) 138 138 in 139 139 - Util.render_html ~title:("Authorizing " ^ host) 139 139 + Util.Html.render_page ~title:("Authorizing " ^ host) 140 140 (module Frontend.OauthAuthorizePage) 141 141 ~props: 142 142 { client_url ··· 191 191 Errors.invalid_request "code already authorized" 192 192 else if code_rec.used then 193 193 Errors.invalid_request "code already used" 194 194 - else if Util.now_ms () > code_rec.expires_at then 194 194 + else if Util.Time.now_ms () > code_rec.expires_at then 195 195 Errors.invalid_request "code expired" 196 196 else if code_rec.request_id <> request_id then 197 197 Errors.invalid_request "code not for this request"

+2 -2

pegasus/lib/api/oauth_/par.ml

··· 23 23 ^ Uuidm.to_string (Uuidm.v4_gen (Random.State.make_self_init ()) ()) 24 24 in 25 25 let request_uri = Constants.request_uri_prefix ^ request_id in 26 26 - let expires_at = Util.now_ms () + Constants.par_request_ttl_ms in 26 26 + let expires_at = Util.Time.now_ms () + Constants.par_request_ttl_ms in 27 27 let request : oauth_request = 28 28 { request_id 29 29 ; client_id= req.client_id 30 30 ; request_data= Yojson.Safe.to_string (par_request_to_yojson req) 31 31 ; dpop_jkt= Some proof.jkt 32 32 ; expires_at 33 33 - ; created_at= Util.now_ms () } 33 33 + ; created_at= Util.Time.now_ms () } 34 34 in 35 35 let%lwt () = Queries.insert_par_request ctx.db request in 36 36 Dream.json ~status:`Created

+2 -2

pegasus/lib/api/oauth_/token.ml

··· 17 17 | None -> 18 18 Errors.invalid_request "invalid code" 19 19 | Some code_rec -> ( 20 20 - if Util.now_ms () > code_rec.expires_at then 20 20 + if Util.Time.now_ms () > code_rec.expires_at then 21 21 Errors.invalid_request "code expired" 22 22 else 23 23 match code_rec.authorized_by with ··· 80 80 () ) 81 81 in 82 82 let now_sec = int_of_float (Unix.gettimeofday ()) in 83 83 - let now_ms = Util.now_ms () in 83 83 + let now_ms = Util.Time.now_ms () in 84 84 let expires_in = 85 85 Constants.access_token_expiry_ms / 1000 86 86 in

+1 -1

pegasus/lib/api/proxy/appBskyFeedGetFeed.ml

··· 7 7 let handler = 8 8 Xrpc.handler ~auth:Authorization (fun ctx -> 9 9 let input = Xrpc.parse_query ctx.req query_of_yojson in 10 10 - match Util.parse_at_uri input.feed with 10 10 + match Util.Syntax.parse_at_uri input.feed with 11 11 | None -> 12 12 Errors.invalid_request ("invalid feed URI " ^ input.feed) 13 13 | Some {repo; collection; rkey; _} -> (

+2 -2

pegasus/lib/api/repo/getRecord.ml

··· 9 9 match input_did with 10 10 | Ok input_did -> ( 11 11 let uri = 12 12 - Util.make_at_uri ~repo:input_did ~collection:input.collection 12 12 + Util.Syntax.make_at_uri ~repo:input_did ~collection:input.collection 13 13 ~rkey:input.rkey ~fragment:None 14 14 in 15 15 let%lwt repo = Repository.load ~ensure_active:true input_did in ··· 68 68 Errors.internal_error ~name:"RecordNotFound" 69 69 ~msg: 70 70 ( "could not find record " 71 71 - ^ Util.make_at_uri ~repo:input.repo ~collection:input.collection 71 71 + ^ Util.Syntax.make_at_uri ~repo:input.repo ~collection:input.collection 72 72 ~rkey:input.rkey ~fragment:None ) 73 73 () ) )

+1 -1

pegasus/lib/api/root.ml

··· 1 1 let handler = 2 2 Xrpc.handler (fun _ -> 3 3 - Util.render_html ~title:"Pegasus" (module Frontend.RootPage) ~props:() ) 3 3 + Util.Html.render_page ~title:"Pegasus" (module Frontend.RootPage) ~props:() )

+2 -2

pegasus/lib/api/server/confirmEmail.ml

··· 9 9 else 10 10 match (actor.auth_code, actor.auth_code_expires_at) with 11 11 | Some auth_code, Some expires_at 12 12 - when auth_code = token && Util.now_ms () < expires_at -> 12 12 + when auth_code = token && Util.Time.now_ms () < expires_at -> 13 13 let%lwt () = Data_store.confirm_email ~did:actor.did db in 14 14 Lwt.return_ok () 15 15 - | Some _, Some expires_at when Util.now_ms () >= expires_at -> 15 15 + | Some _, Some expires_at when Util.Time.now_ms () >= expires_at -> 16 16 Lwt.return_error ExpiredToken 17 17 | _ -> 18 18 Lwt.return_error InvalidToken

+1 -1

pegasus/lib/api/server/createAccount.ml

··· 33 33 Lwt.return_error e 34 34 | Ok () -> ( 35 35 (* validate handle *) 36 36 - match Util.validate_handle handle with 36 36 + match Identity_util.validate_handle handle with 37 37 | Error (InvalidFormat e) | Error (TooLong e) | Error (TooShort e) -> 38 38 Lwt.return_error (InvalidHandle ("handle " ^ e)) 39 39 | Ok _ -> (

+2 -2

pegasus/lib/api/server/createSession.ml

··· 35 35 let key = id ^ "-" ^ Util.request_ip req in 36 36 let _ = 37 37 Xrpc.consume_route_rate_limit ~name:"repo-write-hour" 38 38 - ~duration_ms:Util.day ~max_points:300 ~key ~consume_points 38 38 + ~duration_ms:Util.Time.day ~max_points:300 ~key ~consume_points 39 39 in 40 40 let _ = 41 41 Xrpc.consume_route_rate_limit ~name:"repo-write-day" 42 42 - ~duration_ms:(5 * Util.minute) ~max_points:30 ~key ~consume_points 42 42 + ~duration_ms:(5 * Util.Time.minute) ~max_points:30 ~key ~consume_points 43 43 in 44 44 match%lwt 45 45 Lwt_result.catch @@ fun () -> Data_store.try_login ~id ~password db

+3 -3

pegasus/lib/api/server/deleteAccount.ml

··· 10 10 let delete_account ~did db = 11 11 let%lwt () = 12 12 try%lwt 13 13 - Util.use_pool db (fun conn -> 14 14 - Util.transact conn (fun () -> 13 13 + Util.Sqlite.use_pool db (fun conn -> 14 14 + Util.Sqlite.transact conn (fun () -> 15 15 let open Util.Syntax in 16 16 let$! () = 17 17 Data_store.Queries.delete_reserved_keys_by_did ~did conn ··· 45 45 | Some auth_code, Some auth_expires_at 46 46 when String.starts_with ~prefix:"del-" auth_code 47 47 && token = auth_code 48 48 - && Util.now_ms () < auth_expires_at -> 48 48 + && Util.Time.now_ms () < auth_expires_at -> 49 49 let%lwt _ = delete_account ~did db in 50 50 Dream.empty `OK 51 51 | None, _ | _, None ->

+4 -4

pegasus/lib/api/server/requestAccountDelete.ml

··· 4 4 "del-" 5 5 ^ String.sub 6 6 Digestif.SHA256.( 7 7 - digest_string (did ^ Int.to_string @@ Util.now_ms ()) |> to_hex ) 7 7 + digest_string (did ^ Int.to_string @@ Util.Time.now_ms ()) |> to_hex ) 8 8 0 8 9 9 in 10 10 - let expires_at = Util.now_ms () + (15 * 60 * 1000) in 10 10 + let expires_at = Util.Time.now_ms () + (15 * 60 * 1000) in 11 11 let%lwt () = Data_store.set_auth_code ~did ~code ~expires_at db in 12 12 Util.send_email_or_log ~recipients:[To actor.email] 13 13 ~subject:(Printf.sprintf "Account deletion request for %s" actor.handle) ··· 19 19 Xrpc.handler ~auth:Authorization 20 20 ~rate_limits: 21 21 [ Route 22 22 - { duration_ms= Util.day 22 22 + { duration_ms= Util.Time.day 23 23 ; points= 15 24 24 ; calc_key= Some calc_key_did 25 25 ; calc_points= None } 26 26 ; Route 27 27 - { duration_ms= Util.hour 27 27 + { duration_ms= Util.Time.hour 28 28 ; points= 5 29 29 ; calc_key= Some calc_key_did 30 30 ; calc_points= None } ]

+3 -3

pegasus/lib/api/server/requestEmailConfirmation.ml

··· 6 6 Lwt.return_error AlreadyConfirmed 7 7 | None -> 8 8 let code = Util.make_code () in 9 9 - let expires_at = Util.now_ms () + (10 * 60 * 1000) in 9 9 + let expires_at = Util.Time.now_ms () + (10 * 60 * 1000) in 10 10 let%lwt () = 11 11 Data_store.set_auth_code ~did:actor.did ~code ~expires_at db 12 12 in ··· 23 23 Xrpc.handler ~auth:Authorization 24 24 ~rate_limits: 25 25 [ Route 26 26 - { duration_ms= Util.day 26 26 + { duration_ms= Util.Time.day 27 27 ; points= 15 28 28 ; calc_key= Some calc_key_did 29 29 ; calc_points= None } 30 30 ; Route 31 31 - { duration_ms= Util.hour 31 31 + { duration_ms= Util.Time.hour 32 32 ; points= 5 33 33 ; calc_key= Some calc_key_did 34 34 ; calc_points= None } ]

+3 -3

pegasus/lib/api/server/requestEmailUpdate.ml

··· 8 8 if token_required then 9 9 let did = actor.did in 10 10 let code = Util.make_code () in 11 11 - let expires_at = Util.now_ms () + (10 * 60 * 1000) in 11 11 + let expires_at = Util.Time.now_ms () + (10 * 60 * 1000) in 12 12 let%lwt () = 13 13 match pending_email with 14 14 | Some pending_email -> ··· 41 41 Xrpc.handler ~auth:Authorization 42 42 ~rate_limits: 43 43 [ Route 44 44 - { duration_ms= Util.day 44 44 + { duration_ms= Util.Time.day 45 45 ; points= 15 46 46 ; calc_key= Some calc_key_did 47 47 ; calc_points= None } 48 48 ; Route 49 49 - { duration_ms= Util.hour 49 49 + { duration_ms= Util.Time.hour 50 50 ; points= 5 51 51 ; calc_key= Some calc_key_did 52 52 ; calc_points= None } ]

+3 -3

pegasus/lib/api/server/requestPasswordReset.ml

··· 3 3 let request_password_reset (actor : Data_store.Types.actor) db = 4 4 let did = actor.did in 5 5 let code = Util.make_code () in 6 6 - let expires_at = Util.now_ms () + (10 * 60 * 1000) in 6 6 + let expires_at = Util.Time.now_ms () + (10 * 60 * 1000) in 7 7 let%lwt () = Data_store.set_auth_code ~did ~code ~expires_at db in 8 8 Util.send_email_or_log ~recipients:[To actor.email] 9 9 ~subject:(Printf.sprintf "Password reset for %s" actor.handle) ··· 13 13 Xrpc.handler 14 14 ~rate_limits: 15 15 [ Route 16 16 - {duration_ms= Util.day; points= 50; calc_key= None; calc_points= None} 16 16 + {duration_ms= Util.Time.day; points= 50; calc_key= None; calc_points= None} 17 17 ; Route 18 18 - {duration_ms= Util.hour; points= 15; calc_key= None; calc_points= None} 18 18 + {duration_ms= Util.Time.hour; points= 15; calc_key= None; calc_points= None} 19 19 ] 20 20 (fun {req; auth; db; _} -> 21 21 let%lwt actor_opt =

+2 -2

pegasus/lib/api/server/resetPassword.ml

··· 9 9 | Some actor -> ( 10 10 match (actor.auth_code, actor.auth_code_expires_at) with 11 11 | Some auth_code, Some auth_expires_at 12 12 - when token = auth_code && Util.now_ms () < auth_expires_at -> 12 12 + when token = auth_code && Util.Time.now_ms () < auth_expires_at -> 13 13 let%lwt () = Data_store.update_password ~did:actor.did ~password db in 14 14 Lwt.return_ok actor.did 15 15 | _ -> ··· 19 19 Xrpc.handler 20 20 ~rate_limits: 21 21 [ Route 22 22 - { duration_ms= 5 * Util.minute 22 22 + { duration_ms= 5 * Util.Time.minute 23 23 ; points= 50 24 24 ; calc_key= None 25 25 ; calc_points= None } ]

+2 -2

pegasus/lib/api/server/updateEmail.ml

··· 25 25 | Some token -> ( 26 26 match (actor.auth_code, actor.auth_code_expires_at) with 27 27 | Some auth_code, Some expires_at 28 28 - when auth_code = token && Util.now_ms () < expires_at -> 28 28 + when auth_code = token && Util.Time.now_ms () < expires_at -> 29 29 let%lwt () = Data_store.update_email ~did ~email db in 30 30 Lwt.return_ok email 31 31 - | Some _, Some expires_at when Util.now_ms () >= expires_at -> 31 31 + | Some _, Some expires_at when Util.Time.now_ms () >= expires_at -> 32 32 Lwt.return_error ExpiredToken 33 33 | _ -> 34 34 Lwt.return_error InvalidToken ) )

+43 -43

pegasus/lib/data_store.ml

··· 319 319 {sql| INSERT INTO revoked_tokens (did, jti, revoked_at) VALUES (%string{did}, %string{jti}, %int{now}) |sql}] 320 320 end 321 321 322 322 - type t = Util.caqti_pool 322 322 + type t = Util.Sqlite.caqti_pool 323 323 324 324 let pool : t option ref = ref None 325 325 ··· 339 339 if create = Some true then 340 340 Util.mkfile_p Util.Constants.pegasus_db_filepath ~perm:0o644 ; 341 341 let%lwt db = 342 342 - Util.connect_sqlite ?create ~write:true 342 342 + Util.Sqlite.connect ?create ~write:true 343 343 Util.Constants.pegasus_db_location 344 344 in 345 345 let%lwt () = Migrations.run_migrations Data_store db in ··· 350 350 if create = Some true then 351 351 Util.mkfile_p Util.Constants.pegasus_db_filepath ~perm:0o644 ; 352 352 let%lwt db = 353 353 - Util.connect_sqlite ?create ~write:false Util.Constants.pegasus_db_location 353 353 + Util.Sqlite.connect ?create ~write:false Util.Constants.pegasus_db_location 354 354 in 355 355 let%lwt () = Migrations.run_migrations Data_store db in 356 356 Lwt.return db 357 357 358 358 let create_actor ~did ~handle ~email ~password ~signing_key conn = 359 359 let password_hash = Bcrypt.hash password |> Bcrypt.string_of_hash in 360 360 - let now = Util.now_ms () in 361 361 - Util.use_pool conn 360 360 + let now = Util.Time.now_ms () in 361 361 + Util.Sqlite.use_pool conn 362 362 @@ Queries.create_actor ~did ~handle ~email ~password_hash ~signing_key 363 363 ~created_at:now 364 364 ~preferences:(Yojson.Safe.from_string "[]") 365 365 366 366 let get_actor_by_identifier id conn = 367 367 - Util.use_pool conn @@ Queries.get_actor_by_identifier ~id 367 367 + Util.Sqlite.use_pool conn @@ Queries.get_actor_by_identifier ~id 368 368 369 369 - let activate_actor did conn = Util.use_pool conn @@ Queries.activate_actor ~did 369 369 + let activate_actor did conn = Util.Sqlite.use_pool conn @@ Queries.activate_actor ~did 370 370 371 371 let deactivate_actor did conn = 372 372 - let deactivated_at = Util.now_ms () in 373 373 - Util.use_pool conn @@ Queries.deactivate_actor ~did ~deactivated_at 372 372 + let deactivated_at = Util.Time.now_ms () in 373 373 + Util.Sqlite.use_pool conn @@ Queries.deactivate_actor ~did ~deactivated_at 374 374 375 375 - let delete_actor did conn = Util.use_pool conn @@ Queries.delete_actor ~did 375 375 + let delete_actor did conn = Util.Sqlite.use_pool conn @@ Queries.delete_actor ~did 376 376 377 377 let update_actor_handle ~did ~handle conn = 378 378 - Util.use_pool conn @@ Queries.update_actor_handle ~did ~handle 378 378 + Util.Sqlite.use_pool conn @@ Queries.update_actor_handle ~did ~handle 379 379 380 380 let try_login ~id ~password conn = 381 381 match%lwt get_actor_by_identifier id conn with ··· 390 390 Lwt.return_none ) 391 391 392 392 let list_actors ?(cursor = "") ?(limit = 100) conn = 393 393 - Util.use_pool conn @@ Queries.list_actors ~cursor ~limit 393 393 + Util.Sqlite.use_pool conn @@ Queries.list_actors ~cursor ~limit 394 394 395 395 let put_preferences ~did ~prefs conn = 396 396 - Util.use_pool conn @@ Queries.put_preferences ~did ~preferences:prefs 396 396 + Util.Sqlite.use_pool conn @@ Queries.put_preferences ~did ~preferences:prefs 397 397 398 398 (* invite codes *) 399 399 let create_invite ~code ~did ~remaining conn = 400 400 - Util.use_pool conn @@ Queries.create_invite ~code ~did ~remaining 400 400 + Util.Sqlite.use_pool conn @@ Queries.create_invite ~code ~did ~remaining 401 401 402 402 - let get_invite ~code conn = Util.use_pool conn @@ Queries.get_invite ~code 402 402 + let get_invite ~code conn = Util.Sqlite.use_pool conn @@ Queries.get_invite ~code 403 403 404 404 - let use_invite ~code conn = Util.use_pool conn @@ Queries.use_invite ~code 404 404 + let use_invite ~code conn = Util.Sqlite.use_pool conn @@ Queries.use_invite ~code 405 405 406 406 let list_invites ?(limit = 100) conn = 407 407 - Util.use_pool conn @@ Queries.list_invites ~limit 407 407 + Util.Sqlite.use_pool conn @@ Queries.list_invites ~limit 408 408 409 409 - let delete_invite ~code conn = Util.use_pool conn @@ Queries.delete_invite ~code 409 409 + let delete_invite ~code conn = Util.Sqlite.use_pool conn @@ Queries.delete_invite ~code 410 410 411 411 let update_invite ~code ~did ~remaining conn = 412 412 - Util.use_pool conn @@ Queries.update_invite ~code ~did ~remaining 412 412 + Util.Sqlite.use_pool conn @@ Queries.update_invite ~code ~did ~remaining 413 413 414 414 let list_actors_filtered ?(cursor = "") ?(limit = 100) ~filter conn = 415 415 if String.length filter = 0 then 416 416 - Util.use_pool conn @@ Queries.list_all_actors ~cursor ~limit 417 417 - else Util.use_pool conn @@ Queries.list_actors_filtered ~filter ~cursor ~limit 416 416 + Util.Sqlite.use_pool conn @@ Queries.list_all_actors ~cursor ~limit 417 417 + else Util.Sqlite.use_pool conn @@ Queries.list_actors_filtered ~filter ~cursor ~limit 418 418 419 419 (* reserved keys *) 420 420 let create_reserved_key ~key_did ~did ~private_key conn = 421 421 - let created_at = Util.now_ms () in 422 422 - Util.use_pool conn 421 421 + let created_at = Util.Time.now_ms () in 422 422 + Util.Sqlite.use_pool conn 423 423 @@ Queries.create_reserved_key ~key_did ~did ~private_key ~created_at 424 424 425 425 let get_reserved_key_by_did ~did conn = 426 426 - Util.use_pool conn @@ Queries.get_reserved_key_by_did ~did 426 426 + Util.Sqlite.use_pool conn @@ Queries.get_reserved_key_by_did ~did 427 427 428 428 let get_reserved_key ~key_did conn = 429 429 - Util.use_pool conn @@ Queries.get_reserved_key ~key_did 429 429 + Util.Sqlite.use_pool conn @@ Queries.get_reserved_key ~key_did 430 430 431 431 let delete_reserved_key ~key_did conn = 432 432 - Util.use_pool conn @@ Queries.delete_reserved_key ~key_did 432 432 + Util.Sqlite.use_pool conn @@ Queries.delete_reserved_key ~key_did 433 433 434 434 let delete_reserved_keys_by_did ~did conn = 435 435 - Util.use_pool conn @@ Queries.delete_reserved_keys_by_did ~did 435 435 + Util.Sqlite.use_pool conn @@ Queries.delete_reserved_keys_by_did ~did 436 436 437 437 (* 2fa *) 438 438 let set_auth_code ~did ~code ~expires_at conn = 439 439 - Util.use_pool conn @@ Queries.set_auth_code ~did ~code ~expires_at 439 439 + Util.Sqlite.use_pool conn @@ Queries.set_auth_code ~did ~code ~expires_at 440 440 441 441 let set_pending_email ~did ~code ~expires_at ~pending_email conn = 442 442 - Util.use_pool conn 442 442 + Util.Sqlite.use_pool conn 443 443 @@ Queries.set_pending_email ~did ~code ~expires_at ~pending_email 444 444 445 445 let clear_auth_code ~did conn = 446 446 - Util.use_pool conn @@ Queries.clear_auth_code ~did 446 446 + Util.Sqlite.use_pool conn @@ Queries.clear_auth_code ~did 447 447 448 448 let get_actor_by_auth_code ~code conn = 449 449 - Util.use_pool conn @@ Queries.get_actor_by_auth_code ~code 449 449 + Util.Sqlite.use_pool conn @@ Queries.get_actor_by_auth_code ~code 450 450 451 451 let update_password ~did ~password conn = 452 452 let password_hash = Bcrypt.hash password |> Bcrypt.string_of_hash in 453 453 - Util.use_pool conn @@ Queries.update_password ~did ~password_hash 453 453 + Util.Sqlite.use_pool conn @@ Queries.update_password ~did ~password_hash 454 454 455 455 let update_email ~did ~email conn = 456 456 - Util.use_pool conn @@ Queries.update_email ~did ~email 456 456 + Util.Sqlite.use_pool conn @@ Queries.update_email ~did ~email 457 457 458 458 let confirm_email ~did conn = 459 459 - let confirmed_at = Util.now_ms () in 460 460 - Util.use_pool conn @@ Queries.confirm_email ~did ~confirmed_at 459 459 + let confirmed_at = Util.Time.now_ms () in 460 460 + Util.Sqlite.use_pool conn @@ Queries.confirm_email ~did ~confirmed_at 461 461 462 462 (* firehose helpers *) 463 463 let append_firehose_event conn ~time ~t ~data : int Lwt.t = 464 464 - Util.use_pool conn @@ Queries.firehose_insert ~time ~t ~data 464 464 + Util.Sqlite.use_pool conn @@ Queries.firehose_insert ~time ~t ~data 465 465 466 466 let list_firehose_since conn ~since ~limit : firehose_event list Lwt.t = 467 467 - Util.use_pool conn @@ Queries.firehose_since ~since ~limit 467 467 + Util.Sqlite.use_pool conn @@ Queries.firehose_since ~since ~limit 468 468 469 469 let next_firehose_event conn ~cursor : firehose_event option Lwt.t = 470 470 - Util.use_pool conn @@ Queries.firehose_next ~cursor 470 470 + Util.Sqlite.use_pool conn @@ Queries.firehose_next ~cursor 471 471 472 472 let earliest_firehose_after_time conn ~time : firehose_event option Lwt.t = 473 473 - Util.use_pool conn @@ Queries.firehose_earliest_after ~time 473 473 + Util.Sqlite.use_pool conn @@ Queries.firehose_earliest_after ~time 474 474 475 475 let latest_firehose_seq conn : int option Lwt.t = 476 476 - Util.use_pool conn @@ Queries.firehose_latest_seq 476 476 + Util.Sqlite.use_pool conn @@ Queries.firehose_latest_seq 477 477 478 478 let next_firehose_seq conn : int Lwt.t = 479 479 - let%lwt seq = Util.use_pool conn Queries.firehose_latest_seq in 479 479 + let%lwt seq = Util.Sqlite.use_pool conn Queries.firehose_latest_seq in 480 480 Option.map succ seq |> Option.value ~default:0 |> Lwt.return 481 481 482 482 (* jwts *) 483 483 let is_token_revoked conn ~did ~jti = 484 484 - Util.use_pool conn @@ Queries.get_revoked_token ~did ~jti 484 484 + Util.Sqlite.use_pool conn @@ Queries.get_revoked_token ~did ~jti 485 485 486 486 let revoke_token conn ~did ~jti = 487 487 - Util.use_pool conn @@ Queries.revoke_token ~did ~jti ~now:(Util.now_ms ()) 487 487 + Util.Sqlite.use_pool conn @@ Queries.revoke_token ~did ~jti ~now:(Util.Time.now_ms ())

+4 -4

pegasus/lib/id_resolver.ml

··· 8 8 let uri = 9 9 Uri.of_string ("https://" ^ handle ^ "/.well-known/atproto-did") 10 10 in 11 11 - let%lwt {status; _}, body = Util.http_get uri in 11 11 + let%lwt {status; _}, body = Util.Http.get uri in 12 12 match status with 13 13 | `OK -> 14 14 let%lwt did = Body.to_string body in ··· 77 77 end 78 78 79 79 module Did = struct 80 80 - open Util.Did_doc_types 80 80 + open Util.Types 81 81 82 82 module Document = struct 83 83 type service = ··· 175 175 ~path:(Uri.pct_encode did) () 176 176 in 177 177 let%lwt {status; _}, body = 178 178 - Util.http_get uri 178 178 + Util.Http.get uri 179 179 ~headers:(Cohttp.Header.of_list [("Accept", "application/json")]) 180 180 in 181 181 match status with ··· 197 197 ~path:"/.well-known/did.json" () 198 198 in 199 199 let%lwt {status; _}, body = 200 200 - Util.http_get uri 200 200 + Util.Http.get uri 201 201 ~headers:(Cohttp.Header.of_list [("Accept", "application/json")]) 202 202 in 203 203 match status with

+107

pegasus/lib/identity_util.ml

··· 1 1 + type validate_handle_error = 2 2 + | InvalidFormat of string 3 3 + | TooShort of string 4 4 + | TooLong of string 5 5 + 6 6 + let validate_handle handle = 7 7 + (* if it's a custom domain, just check that it contains a period *) 8 8 + if not (String.ends_with ~suffix:("." ^ Env.hostname) handle) then 9 9 + if not (String.contains handle '.') then 10 10 + Error (InvalidFormat ("must end with " ^ "." ^ Env.hostname)) 11 11 + else Ok () 12 12 + else 13 13 + let front = 14 14 + String.sub handle 0 15 15 + (String.length handle - (String.length Env.hostname + 1)) 16 16 + in 17 17 + if String.contains front '.' then 18 18 + Error (InvalidFormat "can't contain periods") 19 19 + else 20 20 + match String.length front with 21 21 + | l when l < 3 -> 22 22 + Error (TooShort "must be at least 3 characters") 23 23 + | l when l > 18 -> 24 24 + Error (TooLong "must be at most 18 characters") 25 25 + | _ -> 26 26 + Ok () 27 27 + 28 28 + type update_handle_error = 29 29 + | InvalidFormat of string 30 30 + | HandleTaken 31 31 + | TooShort of string 32 32 + | TooLong of string 33 33 + | InternalServerError of string 34 34 + 35 35 + let update_handle_error_to_string = function 36 36 + | InvalidFormat m | TooShort m | TooLong m -> 37 37 + "handle " ^ m 38 38 + | HandleTaken -> 39 39 + "handle already taken" 40 40 + | InternalServerError msg -> 41 41 + msg 42 42 + 43 43 + let update_handle ~did ~handle db = 44 44 + match validate_handle handle with 45 45 + | Error (InvalidFormat e) -> 46 46 + Lwt.return_error (InvalidFormat e) 47 47 + | Error (TooShort e) -> 48 48 + Lwt.return_error (TooShort e) 49 49 + | Error (TooLong e) -> 50 50 + Lwt.return_error (TooLong e) 51 51 + | Ok () -> ( 52 52 + match%lwt Data_store.get_actor_by_identifier handle db with 53 53 + | Some _ -> 54 54 + Lwt.return_error HandleTaken 55 55 + | None -> ( 56 56 + let%lwt {handle= prev_handle; _} = 57 57 + Data_store.get_actor_by_identifier did db |> Lwt.map Option.get 58 58 + in 59 59 + let%lwt () = Data_store.update_actor_handle ~did ~handle db in 60 60 + let%lwt plc_result = 61 61 + if String.starts_with ~prefix:"did:plc:" did then 62 62 + match%lwt Plc.get_audit_log did with 63 63 + | Error e -> 64 64 + Lwt.return_error 65 65 + (InternalServerError ("failed to fetch did doc: " ^ e)) 66 66 + | Ok log -> ( 67 67 + let latest = List.rev log |> List.hd in 68 68 + let aka = 69 69 + match 70 70 + List.mem ("at://" ^ handle) latest.operation.also_known_as 71 71 + with 72 72 + | true -> 73 73 + latest.operation.also_known_as 74 74 + | false -> 75 75 + ("at://" ^ handle) :: latest.operation.also_known_as 76 76 + in 77 77 + let aka = 78 78 + List.filter (fun x -> x <> "at://" ^ prev_handle) aka 79 79 + in 80 80 + let signed = 81 81 + Plc.sign_operation Env.rotation_key 82 82 + (Operation 83 83 + { type'= "plc_operation" 84 84 + ; prev= Some latest.cid 85 85 + ; also_known_as= aka 86 86 + ; rotation_keys= latest.operation.rotation_keys 87 87 + ; verification_methods= 88 88 + latest.operation.verification_methods 89 89 + ; services= latest.operation.services } ) 90 90 + in 91 91 + match%lwt Plc.submit_operation did signed with 92 92 + | Ok _ -> 93 93 + Lwt.return_ok () 94 94 + | Error (status, msg) -> 95 95 + Lwt.return_error 96 96 + (InternalServerError 97 97 + (Printf.sprintf "failed to submit plc operation: %d %s" 98 98 + status msg ) ) ) 99 99 + else Lwt.return_ok () 100 100 + in 101 101 + match plc_result with 102 102 + | Error e -> 103 103 + Lwt.return_error e 104 104 + | Ok () -> 105 105 + let () = Ttl_cache.String_cache.remove Id_resolver.Did.cache did in 106 106 + let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in 107 107 + Lwt.return_ok () ) )

+2 -2

pegasus/lib/lexicon_resolver.ml

··· 24 24 [@@deriving yojson {strict= false}] 25 25 26 26 let cache : permission_set Ttl_cache.String_cache.t = 27 27 - Ttl_cache.String_cache.create (3 * Util.hour) () 27 27 + Ttl_cache.String_cache.create (3 * Util.Time.hour) () 28 28 29 29 (* reuse dns client from id_resolver *) 30 30 let dns_client = Id_resolver.Handle.dns_client 31 31 32 32 (* resolve did authority for nsid *) 33 33 let resolve_did_authority nsid = 34 34 - let authority = Util.nsid_authority nsid in 34 34 + let authority = Util.Syntax.nsid_authority nsid in 35 35 try%lwt 36 36 let%lwt result = 37 37 Dns_client_lwt.getaddrinfo dns_client Dns.Rr_map.Txt

+5 -5

pegasus/lib/migrations/migrations.ml

··· 62 62 with _ -> None 63 63 64 64 let run_migration db (id, name, sql) = 65 65 - Util.use_pool db (fun conn -> 66 66 - Util.transact conn (fun () -> 65 65 + Util.Sqlite.use_pool db (fun conn -> 66 66 + Util.Sqlite.transact conn (fun () -> 67 67 let open Lwt_result.Infix in 68 68 execute_raw conn sql 69 69 >>= fun () -> 70 70 - let applied_at = Util.now_ms () in 70 70 + let applied_at = Util.Time.now_ms () in 71 71 Queries.record_migration ~id ~name ~applied_at conn ) ) 72 72 73 73 type migration_type = Data_store | User_store ··· 80 80 | User_store -> 81 81 User_store_migrations_sql.(read, file_list) 82 82 in 83 83 - let%lwt () = Util.use_pool conn Queries.create_migrations_table in 83 83 + let%lwt () = Util.Sqlite.use_pool conn Queries.create_migrations_table in 84 84 let%lwt applied = 85 85 - Util.use_pool conn Queries.get_applied_migrations 85 85 + Util.Sqlite.use_pool conn Queries.get_applied_migrations 86 86 >|= List.map (fun m -> m.id) 87 87 in 88 88 let pending =

+1 -1

pegasus/lib/oauth/client.ml

··· 1 1 open Types 2 2 3 3 let fetch_client_metadata client_id : client_metadata Lwt.t = 4 4 - let%lwt {status; _}, res = Util.http_get (Uri.of_string client_id) in 4 4 + let%lwt {status; _}, res = Util.Http.get (Uri.of_string client_id) in 5 5 if status <> `OK then 6 6 let%lwt () = Cohttp_lwt.Body.drain_body res in 7 7 failwith

+3 -3

pegasus/lib/oauth/dpop.ml

··· 15 15 Hashtbl.create Constants.jti_cache_size 16 16 17 17 let cleanup_jti_cache () = 18 18 - let now = Util.now_ms () in 18 18 + let now = Util.Time.now_ms () in 19 19 Hashtbl.filter_map_inplace 20 20 (fun _ expires_at -> if expires_at > now then Some expires_at else None) 21 21 jti_cache ··· 50 50 |> to_raw_string |> Jwt.b64_encode ) 51 51 52 52 let create_nonce_state secret = 53 53 - let counter = Util.now_ms () / Constants.dpop_rotation_interval_ms in 53 53 + let counter = Util.Time.now_ms () / Constants.dpop_rotation_interval_ms in 54 54 { secret 55 55 ; counter 56 56 ; prev= compute_nonce secret (pred counter) ··· 60 60 let nonce_state = ref (create_nonce_state Env.dpop_nonce_secret) 61 61 62 62 let next_nonce () = 63 63 - let now_counter = Util.now_ms () / Constants.dpop_rotation_interval_ms in 63 63 + let now_counter = Util.Time.now_ms () / Constants.dpop_rotation_interval_ms in 64 64 let diff = now_counter - !nonce_state.counter in 65 65 ( match diff with 66 66 | 0 ->

+18 -18

pegasus/lib/oauth/queries.ml

··· 3 3 open Types 4 4 5 5 let insert_par_request conn req = 6 6 - Util.use_pool conn 6 6 + Util.Sqlite.use_pool conn 7 7 @@ [%rapper 8 8 execute 9 9 {sql| ··· 14 14 req 15 15 16 16 let get_par_request conn request_id = 17 17 - Util.use_pool conn 17 17 + Util.Sqlite.use_pool conn 18 18 @@ [%rapper 19 19 get_opt 20 20 {sql| ··· 25 25 AND expires_at > %int{now} 26 26 |sql} 27 27 record_out] 28 28 - ~request_id ~now:(Util.now_ms ()) 28 28 + ~request_id ~now:(Util.Time.now_ms ()) 29 29 30 30 let insert_auth_code conn code = 31 31 - Util.use_pool conn 31 31 + Util.Sqlite.use_pool conn 32 32 @@ [%rapper 33 33 execute 34 34 {sql| ··· 39 39 code 40 40 41 41 let get_auth_code conn code = 42 42 - Util.use_pool conn 42 42 + Util.Sqlite.use_pool conn 43 43 @@ [%rapper 44 44 get_opt 45 45 {sql| ··· 53 53 ~code 54 54 55 55 let activate_auth_code conn code did ~ip ~user_agent = 56 56 - let authorized_at = Util.now_ms () in 57 57 - Util.use_pool conn 56 56 + let authorized_at = Util.Time.now_ms () in 57 57 + Util.Sqlite.use_pool conn 58 58 @@ [%rapper 59 59 execute 60 60 {sql| ··· 68 68 ~did ~authorized_at ~ip ~user_agent ~code 69 69 70 70 let consume_auth_code conn code = 71 71 - Util.use_pool conn 71 71 + Util.Sqlite.use_pool conn 72 72 @@ [%rapper 73 73 get_opt 74 74 {sql| ··· 83 83 ~code 84 84 85 85 let insert_oauth_token conn token = 86 86 - Util.use_pool conn 86 86 + Util.Sqlite.use_pool conn 87 87 @@ [%rapper 88 88 execute 89 89 {sql| ··· 94 94 token 95 95 96 96 let get_oauth_token_by_refresh conn refresh_token = 97 97 - Util.use_pool conn 97 97 + Util.Sqlite.use_pool conn 98 98 @@ [%rapper 99 99 get_opt 100 100 {sql| ··· 108 108 ~refresh_token 109 109 110 110 let update_oauth_token conn ~old_refresh_token ~new_refresh_token ~expires_at = 111 111 - let now_ms = Util.now_ms () in 112 112 - Util.use_pool conn 111 111 + let now_ms = Util.Time.now_ms () in 112 112 + Util.Sqlite.use_pool conn 113 113 @@ [%rapper 114 114 execute 115 115 {sql| ··· 122 122 ~new_refresh_token ~expires_at ~now_ms ~old_refresh_token 123 123 124 124 let delete_oauth_token_by_refresh conn refresh_token = 125 125 - Util.use_pool conn 125 125 + Util.Sqlite.use_pool conn 126 126 @@ [%rapper 127 127 execute 128 128 {sql| ··· 131 131 ~refresh_token 132 132 133 133 let get_oauth_tokens_by_did conn did = 134 134 - Util.use_pool conn 134 134 + Util.Sqlite.use_pool conn 135 135 @@ [%rapper 136 136 get_many 137 137 {sql| ··· 146 146 ~did 147 147 148 148 let get_distinct_clients_by_did conn did = 149 149 - Util.use_pool conn 149 149 + Util.Sqlite.use_pool conn 150 150 @@ [%rapper 151 151 get_many 152 152 {sql| ··· 159 159 ~did 160 160 161 161 let get_distinct_devices_by_did conn did = 162 162 - Util.use_pool conn 162 162 + Util.Sqlite.use_pool conn 163 163 @@ [%rapper 164 164 get_many 165 165 {sql| ··· 173 173 ~did 174 174 175 175 let delete_oauth_tokens_by_client conn ~did ~client_id = 176 176 - Util.use_pool conn 176 176 + Util.Sqlite.use_pool conn 177 177 @@ [%rapper 178 178 execute 179 179 {sql| ··· 183 183 ~did ~client_id 184 184 185 185 let delete_oauth_tokens_by_device conn ~did ~last_ip ~last_user_agent = 186 186 - Util.use_pool conn 186 186 + Util.Sqlite.use_pool conn 187 187 @@ [%rapper 188 188 execute 189 189 {sql|

+2 -2

pegasus/lib/oauth/scopes.ml

··· 69 69 70 70 (* check if permission_nsid is under include_nsid's authority *) 71 71 let is_parent_authority_of ~include_nsid ~permission_nsid = 72 72 - let include_authority = Util.nsid_authority include_nsid in 73 73 - let permission_authority = Util.nsid_authority permission_nsid in 72 72 + let include_authority = Util.Syntax.nsid_authority include_nsid in 73 73 + let permission_authority = Util.Syntax.nsid_authority permission_nsid in 74 74 String.equal include_authority permission_authority 75 75 || String.starts_with ~prefix:(include_authority ^ ".") permission_authority 76 76

+13 -13

pegasus/lib/passkey.ml

··· 126 126 127 127 let create_challenge ?did ~challenge_type db = 128 128 let _challenge_obj, challenge_b64 = Webauthn.generate_challenge () in 129 129 - let now = Util.now_ms () in 129 129 + let now = Util.Time.now_ms () in 130 130 let expires_at = now + challenge_expiry_ms in 131 131 let challenge_type_str = 132 132 match challenge_type with ··· 136 136 "authenticate" 137 137 in 138 138 let%lwt () = 139 139 - Util.use_pool db 139 139 + Util.Sqlite.use_pool db 140 140 @@ Queries.insert_challenge ~challenge:challenge_b64 ~did 141 141 ~challenge_type:challenge_type_str ~expires_at ~created_at:now 142 142 in 143 143 Lwt.return challenge_b64 144 144 145 145 let verify_challenge ~challenge ~challenge_type db = 146 146 - let now = Util.now_ms () in 146 146 + let now = Util.Time.now_ms () in 147 147 let expected_type = 148 148 match challenge_type with 149 149 | `Register -> ··· 151 151 | `Authenticate -> 152 152 "authenticate" 153 153 in 154 154 - match%lwt Util.use_pool db @@ Queries.get_challenge challenge now with 154 154 + match%lwt Util.Sqlite.use_pool db @@ Queries.get_challenge challenge now with 155 155 | Some c when c.challenge_type = expected_type -> 156 156 Lwt.return_some c 157 157 | _ -> 158 158 Lwt.return_none 159 159 160 160 let delete_challenge ~challenge db = 161 161 - Util.use_pool db @@ Queries.delete_challenge ~challenge 161 161 + Util.Sqlite.use_pool db @@ Queries.delete_challenge ~challenge 162 162 163 163 let store_credential ~did ~credential_id ~public_key ~name db = 164 164 - let now = Util.now_ms () in 165 165 - Util.use_pool db 164 164 + let now = Util.Time.now_ms () in 165 165 + Util.Sqlite.use_pool db 166 166 @@ Queries.insert_passkey ~did ~credential_id ~public_key ~sign_count:0 ~name 167 167 ~created_at:now 168 168 169 169 let get_credentials_for_user ~did db = 170 170 - Util.use_pool db @@ Queries.get_passkeys_by_did ~did 170 170 + Util.Sqlite.use_pool db @@ Queries.get_passkeys_by_did ~did 171 171 172 172 let get_credential_by_id ~credential_id db = 173 173 - Util.use_pool db @@ Queries.get_passkey_by_credential_id ~credential_id 173 173 + Util.Sqlite.use_pool db @@ Queries.get_passkey_by_credential_id ~credential_id 174 174 175 175 let update_sign_count ~credential_id ~sign_count db = 176 176 - let now = Util.now_ms () in 177 177 - Util.use_pool db 176 176 + let now = Util.Time.now_ms () in 177 177 + Util.Sqlite.use_pool db 178 178 @@ Queries.update_passkey_sign_count ~credential_id ~sign_count 179 179 ~last_used_at:now 180 180 181 181 let delete_credential ~id ~did db = 182 182 - let%lwt () = Util.use_pool db @@ Queries.delete_passkey ~id ~did in 182 182 + let%lwt () = Util.Sqlite.use_pool db @@ Queries.delete_passkey ~id ~did in 183 183 Lwt.return_true 184 184 185 185 let rename_credential ~id ~did ~name db = 186 186 - let%lwt () = Util.use_pool db @@ Queries.rename_passkey ~id ~did ~name in 186 186 + let%lwt () = Util.Sqlite.use_pool db @@ Queries.rename_passkey ~id ~did ~name in 187 187 Lwt.return_true 188 188 189 189 let generate_registration_options ~did ~email ~existing_credentials db =

+2 -2

pegasus/lib/plc.ml

··· 1 1 open Cohttp 2 2 open Cohttp_lwt 3 3 open Cohttp_lwt_unix 4 4 - open Util.Did_doc_types 4 4 + open Util.Types 5 5 6 6 let default_endpoint = "https://plc.directory" 7 7 ··· 278 278 did 279 279 in 280 280 let headers = Http.Header.init_with "Accept" "application/json" in 281 281 - let%lwt res, body = Util.http_get ~headers uri in 281 281 + let%lwt res, body = Util.Http.get ~headers uri in 282 282 match res.status with 283 283 | `OK -> 284 284 let%lwt body = Body.to_string body in

+2 -2

pegasus/lib/repository.ml

··· 577 577 in 578 578 let record_data = List.rev record_data in 579 579 let%lwt _ = 580 580 - Util.use_pool ~timeout:600. t.db.db (fun conn -> 581 581 - Util.transact conn (fun () -> 580 580 + Util.Sqlite.use_pool ~timeout:600. t.db.db (fun conn -> 581 581 + Util.Sqlite.transact conn (fun () -> 582 582 let$! _ = User_store.Queries.put_commit root commit_bytes conn in 583 583 let$! () = User_store.Queries.clear_mst conn in 584 584 let$! () = User_store.Bulk.put_blocks mst_blocks conn in

+16 -16

pegasus/lib/security_key.ml

··· 182 182 183 183 let setup_security_key ~did ~name db = 184 184 let secret = generate_secret () in 185 185 - let now = Util.now_ms () in 185 185 + let now = Util.Time.now_ms () in 186 186 let%lwt () = 187 187 - Util.use_pool db 187 187 + Util.Sqlite.use_pool db 188 188 @@ Queries.insert_security_key ~did ~name ~secret ~counter:0 ~created_at:now 189 189 in 190 190 - let%lwt id = Util.use_pool db @@ Queries.get_last_insert_id () in 190 190 + let%lwt id = Util.Sqlite.use_pool db @@ Queries.get_last_insert_id () in 191 191 let issuer = "Pegasus PDS (" ^ Env.hostname ^ ")" in 192 192 let uri = make_provisioning_uri ~secret ~account:did ~issuer in 193 193 let secret_b32 = ··· 196 196 Lwt.return (id, secret_b32, uri) 197 197 198 198 let verify_setup ~id ~did ~code db = 199 199 - match%lwt Util.use_pool db @@ Queries.get_security_key_by_id id did with 199 199 + match%lwt Util.Sqlite.use_pool db @@ Queries.get_security_key_by_id id did with 200 200 | None -> 201 201 Lwt.return_error "Security key not found" 202 202 | Some sk -> ( ··· 209 209 | Error msg -> 210 210 Lwt.return_error msg 211 211 | Ok new_counter -> 212 212 - let now = Util.now_ms () in 212 212 + let now = Util.Time.now_ms () in 213 213 let%lwt () = 214 214 - Util.use_pool db 214 214 + Util.Sqlite.use_pool db 215 215 @@ Queries.verify_security_key ~id ~did ~verified_at:now 216 216 ~counter:new_counter 217 217 in ··· 219 219 220 220 let verify_login ~did ~code db = 221 221 let%lwt keys = 222 222 - Util.use_pool db @@ Queries.get_verified_security_keys_by_did ~did 222 222 + Util.Sqlite.use_pool db @@ Queries.get_verified_security_keys_by_did ~did 223 223 in 224 224 let rec try_keys = function 225 225 | [] -> ··· 229 229 | Error _ -> 230 230 try_keys rest 231 231 | Ok new_counter -> 232 232 - let now = Util.now_ms () in 232 232 + let now = Util.Time.now_ms () in 233 233 let%lwt () = 234 234 - Util.use_pool db 234 234 + Util.Sqlite.use_pool db 235 235 @@ Queries.update_counter_and_last_used ~id:sk.id 236 236 ~counter:new_counter ~last_used_at:now 237 237 in ··· 240 240 try_keys keys 241 241 242 242 let resync_key ~id ~did ~code1 ~code2 db = 243 243 - match%lwt Util.use_pool db @@ Queries.get_security_key_by_id id did with 243 243 + match%lwt Util.Sqlite.use_pool db @@ Queries.get_security_key_by_id id did with 244 244 | None -> 245 245 Lwt.return_error "Security key not found" 246 246 | Some sk -> ( ··· 254 254 Lwt.return_error msg 255 255 | Ok new_counter -> 256 256 let%lwt () = 257 257 - Util.use_pool db 257 257 + Util.Sqlite.use_pool db 258 258 @@ Queries.update_counter ~id:sk.id ~counter:new_counter 259 259 in 260 260 Lwt.return_ok () ) 261 261 262 262 let get_keys_for_user ~did db = 263 263 - Util.use_pool db @@ Queries.get_security_keys_by_did ~did 263 263 + Util.Sqlite.use_pool db @@ Queries.get_security_keys_by_did ~did 264 264 265 265 let delete_key ~id ~did db = 266 266 - let%lwt () = Util.use_pool db @@ Queries.delete_security_key ~id ~did in 266 266 + let%lwt () = Util.Sqlite.use_pool db @@ Queries.delete_security_key ~id ~did in 267 267 Lwt.return_true 268 268 269 269 let has_security_keys ~did db = 270 270 - match%lwt Util.use_pool db @@ Queries.has_security_keys ~did with 270 270 + match%lwt Util.Sqlite.use_pool db @@ Queries.has_security_keys ~did with 271 271 | Some _ -> 272 272 Lwt.return_true 273 273 | None -> 274 274 Lwt.return_false 275 275 276 276 let count_security_keys ~did db = 277 277 - Util.use_pool db @@ Queries.count_security_keys ~did 277 277 + Util.Sqlite.use_pool db @@ Queries.count_security_keys ~did 278 278 279 279 let count_verified_security_keys ~did db = 280 280 - Util.use_pool db @@ Queries.count_verified_security_keys ~did 280 280 + Util.Sqlite.use_pool db @@ Queries.count_verified_security_keys ~did

+11 -11

pegasus/lib/sequencer.ml

··· 444 444 in 445 445 match kind_result with 446 446 | Ok kind -> 447 447 - Ok {seq= dbe.seq; time= Util.ms_to_iso8601 dbe.time; kind} 447 447 + Ok {seq= dbe.seq; time= Util.Time.ms_to_iso8601 dbe.time; kind} 448 448 | Error e -> 449 449 Error ("failed to parse event: " ^ e) ) 450 450 | Error _ -> ··· 458 458 459 459 let queue_max = 1000 460 460 461 461 - let notify_interval = 20 * Util.minute 461 461 + let notify_interval = 20 * Util.Time.minute 462 462 463 463 let ring : item array = Array.make ring_size {seq= 0; bytes= Bytes.empty} 464 464 ··· 486 486 head_seq := it.seq ; 487 487 ring.(it.seq mod ring_size) <- it ; 488 488 if !count < ring_size then incr count ; 489 489 - let now = Util.now_ms () in 489 489 + let now = Util.Time.now_ms () in 490 490 if now - !last_notified > notify_interval then begin 491 491 last_notified := now ; 492 492 List.iter ··· 726 726 let sequence_commit (conn : Data_store.t) ~(did : string) ~(commit : Cid.t) 727 727 ~(rev : string) ?since ~(blocks : bytes) ~(ops : commit_evt_op list) 728 728 ?(prev_data : Cid.t option) () : int Lwt.t = 729 729 - let time_ms = Util.now_ms () in 730 730 - let time_iso = Util.ms_to_iso8601 time_ms in 729 729 + let time_ms = Util.Time.now_ms () in 730 730 + let time_iso = Util.Time.ms_to_iso8601 time_ms in 731 731 let evt : commit_evt = 732 732 { rebase= false 733 733 ; too_big= false ··· 748 748 749 749 let sequence_sync (conn : Data_store.t) ~(did : string) ~(rev : string) 750 750 ~(blocks : bytes) () : int Lwt.t = 751 751 - let time_ms = Util.now_ms () in 752 752 - let time_iso = Util.ms_to_iso8601 time_ms in 751 751 + let time_ms = Util.Time.now_ms () in 752 752 + let time_iso = Util.Time.ms_to_iso8601 time_ms in 753 753 let evt : sync_evt = {did; rev; blocks} in 754 754 let raw = Dag_cbor.encode_yojson @@ Encode.format_sync evt in 755 755 let%lwt seq = DB.append_event conn ~t:`Sync ~time:time_ms ~data:raw in ··· 759 759 760 760 let sequence_identity (conn : Data_store.t) ~(did : string) 761 761 ?(handle : string option) () : int Lwt.t = 762 762 - let time_ms = Util.now_ms () in 763 763 - let time_iso = Util.ms_to_iso8601 time_ms in 762 762 + let time_ms = Util.Time.now_ms () in 763 763 + let time_iso = Util.Time.ms_to_iso8601 time_ms in 764 764 let evt : identity_evt = {did; handle} in 765 765 let raw = Dag_cbor.encode_yojson @@ Encode.format_identity evt in 766 766 let%lwt seq = DB.append_event conn ~t:`Identity ~time:time_ms ~data:raw in ··· 770 770 771 771 let sequence_account (conn : Data_store.t) ~(did : string) ~(active : bool) 772 772 ?(status : account_status option) () : int Lwt.t = 773 773 - let time_ms = Util.now_ms () in 774 774 - let time_iso = Util.ms_to_iso8601 time_ms in 773 773 + let time_ms = Util.Time.now_ms () in 774 774 + let time_iso = Util.Time.ms_to_iso8601 time_ms in 775 775 let evt : account_evt = {did; active; status} in 776 776 let raw = Dag_cbor.encode_yojson @@ Encode.format_account evt in 777 777 let%lwt seq = DB.append_event conn ~t:`Account ~time:time_ms ~data:raw in

+1 -1

pegasus/lib/session.ml

··· 198 198 Lwt.return_some 199 199 { actor with 200 200 avatar_data_uri= 201 201 - Some (Util.make_data_uri ~mimetype ~data) } 201 201 + Some (Util.Html.make_data_uri ~mimetype ~data) } 202 202 | _ -> 203 203 Lwt.return_some actor ) 204 204 | _ ->

+13 -13

pegasus/lib/totp.ml

··· 97 97 with _ -> false 98 98 99 99 let store_codes ~did ~codes db = 100 100 - let now = Util.now_ms () in 100 100 + let now = Util.Time.now_ms () in 101 101 Lwt_list.iter_s 102 102 (fun code -> 103 103 let code_hash = hash_code code in 104 104 - Util.use_pool db 104 104 + Util.Sqlite.use_pool db 105 105 @@ Queries.insert_backup_code ~did ~code_hash ~created_at:now ) 106 106 codes 107 107 108 108 let regenerate ~did db = 109 109 - let%lwt () = Util.use_pool db @@ Queries.delete_backup_codes_by_did ~did in 109 109 + let%lwt () = Util.Sqlite.use_pool db @@ Queries.delete_backup_codes_by_did ~did in 110 110 let codes = generate_codes () in 111 111 let%lwt () = store_codes ~did ~codes db in 112 112 Lwt.return (List.map format_code codes) ··· 114 114 let verify_and_consume ~did ~code db = 115 115 let normalized_code = normalize_code code in 116 116 let%lwt codes = 117 117 - Util.use_pool db @@ Queries.get_unused_backup_codes_by_did ~did 117 117 + Util.Sqlite.use_pool db @@ Queries.get_unused_backup_codes_by_did ~did 118 118 in 119 119 let rec check = function 120 120 | [] -> 121 121 Lwt.return_false 122 122 | c :: rest -> 123 123 if verify_code_hash normalized_code c.code_hash then 124 124 - let now = Util.now_ms () in 124 124 + let now = Util.Time.now_ms () in 125 125 let%lwt () = 126 126 - Util.use_pool db 126 126 + Util.Sqlite.use_pool db 127 127 @@ Queries.mark_code_used ~id:c.id ~did ~used_at:now 128 128 in 129 129 Lwt.return_true ··· 132 132 check codes 133 133 134 134 let get_remaining_count ~did db = 135 135 - Util.use_pool db @@ Queries.count_unused_backup_codes ~did 135 135 + Util.Sqlite.use_pool db @@ Queries.count_unused_backup_codes ~did 136 136 137 137 let has_backup_codes ~did db = 138 138 let%lwt count = get_remaining_count ~did db in ··· 244 244 check 0 245 245 246 246 let create_secret ~did ~secret db = 247 247 - Util.use_pool db @@ Queries.set_totp_secret ~did ~secret 247 247 + Util.Sqlite.use_pool db @@ Queries.set_totp_secret ~did ~secret 248 248 249 249 let get_secret ~did db = 250 250 - match%lwt Util.use_pool db @@ Queries.get_totp_secret ~did with 250 250 + match%lwt Util.Sqlite.use_pool db @@ Queries.get_totp_secret ~did with 251 251 | Some (Some secret, verified_at) -> 252 252 Lwt.return_some (secret, verified_at) 253 253 | _ -> ··· 261 261 Lwt.return_error "TOTP is already enabled" 262 262 | Some (secret, None) -> 263 263 if verify_code ~secret ~code then 264 264 - let now = Util.now_ms () in 264 264 + let now = Util.Time.now_ms () in 265 265 let%lwt () = 266 266 - Util.use_pool db @@ Queries.verify_totp_secret ~did ~verified_at:now 266 266 + Util.Sqlite.use_pool db @@ Queries.verify_totp_secret ~did ~verified_at:now 267 267 in 268 268 Lwt.return_ok () 269 269 else Lwt.return_error "Invalid verification code" 270 270 271 271 - let disable ~did db = Util.use_pool db @@ Queries.clear_totp_secret ~did 271 271 + let disable ~did db = Util.Sqlite.use_pool db @@ Queries.clear_totp_secret ~did 272 272 273 273 let is_enabled ~did db = 274 274 - match%lwt Util.use_pool db @@ Queries.is_totp_enabled ~did with 274 274 + match%lwt Util.Sqlite.use_pool db @@ Queries.is_totp_enabled ~did with 275 275 | Some _ -> 276 276 Lwt.return_true 277 277 | None ->

+1 -1

pegasus/lib/ttl_cache.ml

··· 10 10 11 11 let default_initial_capacity = 16 12 12 13 13 - let[@inline] _now_ms () : time_ms = Util.now_ms () 13 13 + let[@inline] _now_ms () : time_ms = Util.Time.now_ms () 14 14 15 15 let create ?capacity ?(initial_capacity = default_initial_capacity) 16 16 default_ttl () : 'a t =

+16 -16

pegasus/lib/two_factor.ml

··· 104 104 Base64.(encode_string ~alphabet:uri_safe_alphabet ~pad:false token) 105 105 106 106 let is_2fa_enabled ~did db = 107 107 - match%lwt Util.use_pool db @@ Queries.is_2fa_enabled ~did with 107 107 + match%lwt Util.Sqlite.use_pool db @@ Queries.is_2fa_enabled ~did with 108 108 | Some 1 -> 109 109 Lwt.return_true 110 110 | _ -> ··· 113 113 let get_status ~did db = 114 114 let%lwt totp_enabled = Totp.is_enabled ~did db in 115 115 let%lwt email_2fa = 116 116 - match%lwt Util.use_pool db @@ Queries.get_email_2fa_enabled ~did with 116 116 + match%lwt Util.Sqlite.use_pool db @@ Queries.get_email_2fa_enabled ~did with 117 117 | Some 1 -> 118 118 Lwt.return_true 119 119 | _ -> ··· 132 132 let get_available_methods ~did db = 133 133 let%lwt totp_enabled = Totp.is_enabled ~did db in 134 134 let%lwt email_2fa = 135 135 - match%lwt Util.use_pool db @@ Queries.get_email_2fa_enabled ~did with 135 135 + match%lwt Util.Sqlite.use_pool db @@ Queries.get_email_2fa_enabled ~did with 136 136 | Some 1 -> 137 137 Lwt.return_true 138 138 | _ -> ··· 149 149 (* create a pending 2FA session after password verification *) 150 150 let create_pending_session ~did db = 151 151 let session_token = generate_session_token () in 152 152 - let now = Util.now_ms () in 152 152 + let now = Util.Time.now_ms () in 153 153 let expires_at = now + pending_session_expiry_ms in 154 154 let%lwt () = 155 155 - Util.use_pool db 155 155 + Util.Sqlite.use_pool db 156 156 @@ Queries.insert_pending_2fa ~session_token ~did ~password_verified_at:now 157 157 ~expires_at ~created_at:now 158 158 in 159 159 Lwt.return session_token 160 160 161 161 let get_pending_session ~session_token db = 162 162 - let now = Util.now_ms () in 163 163 - Util.use_pool db @@ Queries.get_pending_2fa session_token now 162 162 + let now = Util.Time.now_ms () in 163 163 + Util.Sqlite.use_pool db @@ Queries.get_pending_2fa session_token now 164 164 165 165 let get_pending_session_for_did ~did db = 166 166 - let now = Util.now_ms () in 167 167 - Util.use_pool db @@ Queries.get_pending_2fa_for_did did now 166 166 + let now = Util.Time.now_ms () in 167 167 + Util.Sqlite.use_pool db @@ Queries.get_pending_2fa_for_did did now 168 168 169 169 let delete_pending_session ~session_token db = 170 170 - Util.use_pool db @@ Queries.delete_pending_2fa ~session_token 170 170 + Util.Sqlite.use_pool db @@ Queries.delete_pending_2fa ~session_token 171 171 172 172 let send_email_code ~session_token ~actor db = 173 173 let code = Util.make_code () in 174 174 - let now = Util.now_ms () in 174 174 + let now = Util.Time.now_ms () in 175 175 let expires_at = now + email_code_expiry_ms in 176 176 let%lwt () = 177 177 - Util.use_pool db 177 177 + Util.Sqlite.use_pool db 178 178 @@ Queries.update_email_code ~session_token ~email_code:code 179 179 ~email_code_expires_at:expires_at 180 180 in ··· 189 189 let _verify_email_code ~code ~session = 190 190 match (session.email_code, session.email_code_expires_at) with 191 191 | Some stored_code, Some expires_at -> 192 192 - let now = Util.now_ms () in 192 192 + let now = Util.Time.now_ms () in 193 193 if now > expires_at then Lwt.return_error "Email code expired" 194 194 else if stored_code = code then Lwt.return_ok session.did 195 195 else Lwt.return_error "Invalid code" ··· 231 231 else Lwt.return_error "Invalid backup code" 232 232 233 233 let enable_email_2fa ~did db = 234 234 - Util.use_pool db @@ Queries.set_email_2fa_enabled ~did ~enabled:1 234 234 + Util.Sqlite.use_pool db @@ Queries.set_email_2fa_enabled ~did ~enabled:1 235 235 236 236 let disable_email_2fa ~did db = 237 237 - Util.use_pool db @@ Queries.set_email_2fa_enabled ~did ~enabled:0 237 237 + Util.Sqlite.use_pool db @@ Queries.set_email_2fa_enabled ~did ~enabled:0 238 238 239 239 let is_email_2fa_enabled ~did db = 240 240 - match%lwt Util.use_pool db @@ Queries.get_email_2fa_enabled ~did with 240 240 + match%lwt Util.Sqlite.use_pool db @@ Queries.get_email_2fa_enabled ~did with 241 241 | Some 1 -> 242 242 Lwt.return_true 243 243 | _ ->

+40 -40

pegasus/lib/user_store.ml

··· 457 457 process_chunks chunks 458 458 end 459 459 460 460 - type t = {did: string; db: Util.caqti_pool} 460 460 + type t = {did: string; db: Util.Sqlite.caqti_pool} 461 461 462 462 let pool_cache : (string, t) Hashtbl.t = Hashtbl.create 64 463 463 ··· 475 475 Lwt.return cached 476 476 | None -> 477 477 let%lwt db = 478 478 - Util.connect_sqlite ?create ~write:true 478 478 + Util.Sqlite.connect ?create ~write:true 479 479 (Util.Constants.user_db_location did) 480 480 in 481 481 let%lwt () = Migrations.run_migrations User_store db in ··· 487 487 if create = Some true then 488 488 Util.mkfile_p (Util.Constants.user_db_filepath did) ~perm:0o644 ; 489 489 let%lwt db = 490 490 - Util.connect_sqlite ?create ~write:false 490 490 + Util.Sqlite.connect ?create ~write:false 491 491 (Util.Constants.user_db_location did) 492 492 in 493 493 let%lwt () = Migrations.run_migrations User_store db in ··· 496 496 (* mst blocks; implements Writable_blockstore *) 497 497 498 498 let get_bytes t cid : Blob.t option Lwt.t = 499 499 - Util.use_pool t.db @@ Queries.get_block cid 499 499 + Util.Sqlite.use_pool t.db @@ Queries.get_block cid 500 500 >|= function Some {data; _} -> Some data | None -> None 501 501 502 502 let get_blocks t cids : Block_map.with_missing Lwt.t = 503 503 if List.is_empty cids then 504 504 Lwt.return ({blocks= Block_map.empty; missing= []} : Block_map.with_missing) 505 505 else 506 506 - let%lwt blocks = Util.use_pool t.db @@ Queries.get_blocks cids in 506 506 + let%lwt blocks = Util.Sqlite.use_pool t.db @@ Queries.get_blocks cids in 507 507 let found_map = 508 508 List.fold_left 509 509 (fun acc ({cid; data} : block) -> Block_map.set cid data acc) ··· 521 521 cids ) 522 522 523 523 let has t cid : bool Lwt.t = 524 524 - Util.use_pool t.db @@ Queries.has_block cid 524 524 + Util.Sqlite.use_pool t.db @@ Queries.has_block cid 525 525 >|= function Some _ -> true | None -> false 526 526 527 527 let put_block t cid block : (bool, exn) Lwt_result.t = 528 528 Lwt_result.catch 529 529 @@ fun () -> 530 530 - match%lwt Util.use_pool t.db @@ Queries.put_block cid block with 530 530 + match%lwt Util.Sqlite.use_pool t.db @@ Queries.put_block cid block with 531 531 | Some _ -> 532 532 Lwt.return true 533 533 | None -> ··· 539 539 else 540 540 Lwt_result.catch (fun () -> 541 541 let%lwt () = 542 542 - Util.use_pool t.db (fun conn -> Bulk.put_blocks entries conn) 542 542 + Util.Sqlite.use_pool t.db (fun conn -> Bulk.put_blocks entries conn) 543 543 in 544 544 Lwt.return (List.length entries) ) 545 545 546 546 let delete_block t cid : (bool, exn) Lwt_result.t = 547 547 Lwt_result.catch 548 548 - @@ fun () -> Util.use_pool t.db @@ Queries.delete_block cid >|= fun _ -> true 548 548 + @@ fun () -> Util.Sqlite.use_pool t.db @@ Queries.delete_block cid >|= fun _ -> true 549 549 550 550 let delete_many t cids : (int, exn) Lwt_result.t = 551 551 Lwt_result.catch 552 552 - @@ fun () -> Util.use_pool t.db @@ Queries.delete_blocks cids >|= List.length 552 552 + @@ fun () -> Util.Sqlite.use_pool t.db @@ Queries.delete_blocks cids >|= List.length 553 553 554 554 let clear_mst t : unit Lwt.t = 555 555 - let%lwt () = Util.use_pool t.db Queries.clear_mst in 555 555 + let%lwt () = Util.Sqlite.use_pool t.db Queries.clear_mst in 556 556 Lwt.return_unit 557 557 558 558 (* mst misc *) 559 559 560 560 - let count_blocks t : int Lwt.t = Util.use_pool t.db @@ Queries.count_blocks () 560 560 + let count_blocks t : int Lwt.t = Util.Sqlite.use_pool t.db @@ Queries.count_blocks () 561 561 562 562 (* repo commit *) 563 563 564 564 let get_commit t : (Cid.t * signed_commit) option Lwt.t = 565 565 - let%lwt commit = Util.use_pool t.db Queries.get_commit in 565 565 + let%lwt commit = Util.Sqlite.use_pool t.db Queries.get_commit in 566 566 Lwt.return 567 567 @@ Option.map 568 568 (fun (cid, data) -> ··· 575 575 let data = commit |> signed_commit_to_yojson |> Dag_cbor.encode_yojson in 576 576 let cid = Cid.create Dcbor data in 577 577 ( Lwt_result.catch 578 578 - @@ fun () -> Util.use_pool t.db @@ Queries.put_commit cid data ) 578 578 + @@ fun () -> Util.Sqlite.use_pool t.db @@ Queries.put_commit cid data ) 579 579 |> Lwt_result.map (fun () -> cid) 580 580 581 581 (* records *) 582 582 583 583 let get_record t path : record option Lwt.t = 584 584 - Util.use_pool t.db @@ Queries.get_record ~path 584 584 + Util.Sqlite.use_pool t.db @@ Queries.get_record ~path 585 585 >|= Option.map (fun (cid, data, since) -> 586 586 {path; cid; value= Lex.of_cbor data; since} ) 587 587 588 588 let get_record_cid t path : Cid.t option Lwt.t = 589 589 - Util.use_pool t.db @@ Queries.get_record_cid ~path 589 589 + Util.Sqlite.use_pool t.db @@ Queries.get_record_cid ~path 590 590 591 591 let get_all_record_cids t : (string * Cid.t) list Lwt.t = 592 592 - Util.use_pool t.db Queries.get_all_record_cids 592 592 + Util.Sqlite.use_pool t.db Queries.get_all_record_cids 593 593 594 594 let get_records_by_cids t cids : (Cid.t * Blob.t) list Lwt.t = 595 595 if List.is_empty cids then Lwt.return [] 596 596 else 597 597 - Util.use_pool t.db @@ Queries.get_records_by_cids cids 597 597 + Util.Sqlite.use_pool t.db @@ Queries.get_records_by_cids cids 598 598 >|= List.map (fun ({cid; data} : block) -> (cid, data)) 599 599 600 600 let list_records t ?(limit = 100) ?(cursor = "") ?(reverse = false) collection : ··· 602 602 let fn = 603 603 if reverse then Queries.list_records_reverse else Queries.list_records 604 604 in 605 605 - Util.use_pool t.db @@ fn ~collection ~limit ~cursor 605 605 + Util.Sqlite.use_pool t.db @@ fn ~collection ~limit ~cursor 606 606 >|= List.map (fun (path, cid, data, since) -> 607 607 {path; cid; value= Lex.of_cbor data; since} ) 608 608 609 609 - let count_records t : int Lwt.t = Util.use_pool t.db @@ Queries.count_records () 609 609 + let count_records t : int Lwt.t = Util.Sqlite.use_pool t.db @@ Queries.count_records () 610 610 611 611 let list_collections t : string list Lwt.t = 612 612 - Util.use_pool t.db @@ Queries.list_collections 612 612 + Util.Sqlite.use_pool t.db @@ Queries.list_collections 613 613 614 614 let put_record t record path : (Cid.t * bytes) Lwt.t = 615 615 let cid, data = Lex.to_cbor_block record in 616 616 let since = Tid.now () in 617 617 let%lwt () = 618 618 - Util.use_pool t.db @@ Queries.put_record ~path ~cid ~data ~since 618 618 + Util.Sqlite.use_pool t.db @@ Queries.put_record ~path ~cid ~data ~since 619 619 in 620 620 Lwt.return (cid, data) 621 621 622 622 let put_record_raw t ~path ~cid ~data ~since : unit Lwt.t = 623 623 - Util.use_pool t.db @@ Queries.put_record ~path ~cid ~data ~since 623 623 + Util.Sqlite.use_pool t.db @@ Queries.put_record ~path ~cid ~data ~since 624 624 625 625 let delete_record t path : unit Lwt.t = 626 626 - Util.use_pool t.db (fun conn -> 627 627 - Util.transact conn (fun () -> 626 626 + Util.Sqlite.use_pool t.db (fun conn -> 627 627 + Util.Sqlite.transact conn (fun () -> 628 628 let del = Queries.delete_record path conn in 629 629 let$! () = del in 630 630 let$! deleted_blobs = ··· 642 642 (* blobs *) 643 643 644 644 let get_blob t cid : blob_with_contents option Lwt.t = 645 645 - match%lwt Util.use_pool t.db @@ Queries.get_blob ~cid with 645 645 + match%lwt Util.Sqlite.use_pool t.db @@ Queries.get_blob ~cid with 646 646 | None -> 647 647 Lwt.return_none 648 648 | Some (cid, mimetype, storage_str) -> ( ··· 655 655 Lwt.return_none ) 656 656 657 657 let get_blob_metadata t cid : blob option Lwt.t = 658 658 - match%lwt Util.use_pool t.db @@ Queries.get_blob ~cid with 658 658 + match%lwt Util.Sqlite.use_pool t.db @@ Queries.get_blob ~cid with 659 659 | None -> 660 660 Lwt.return_none 661 661 | Some (cid, mimetype, storage_str) -> ··· 663 663 Lwt.return_some {cid; mimetype; storage} 664 664 665 665 let list_blobs ?since t ~limit ~cursor : Cid.t list Lwt.t = 666 666 - Util.use_pool t.db 666 666 + Util.Sqlite.use_pool t.db 667 667 @@ 668 668 match since with 669 669 | Some since -> ··· 673 673 674 674 let list_missing_blobs ?(limit = 500) ?(cursor = "") t : 675 675 (string * Cid.t) list Lwt.t = 676 676 - Util.use_pool t.db @@ Queries.list_missing_blobs ~limit ~cursor 676 676 + Util.Sqlite.use_pool t.db @@ Queries.list_missing_blobs ~limit ~cursor 677 677 678 678 - let count_blobs t : int Lwt.t = Util.use_pool t.db @@ Queries.count_blobs () 678 678 + let count_blobs t : int Lwt.t = Util.Sqlite.use_pool t.db @@ Queries.count_blobs () 679 679 680 680 let count_referenced_blobs t : int Lwt.t = 681 681 - Util.use_pool t.db @@ Queries.count_referenced_blobs () 681 681 + Util.Sqlite.use_pool t.db @@ Queries.count_referenced_blobs () 682 682 683 683 let put_blob t cid mimetype data : Cid.t Lwt.t = 684 684 let%lwt storage = Blob_store.put ~did:t.did ~cid ~data in 685 685 let storage_str = Blob_store.storage_to_string storage in 686 686 - Util.use_pool t.db @@ Queries.put_blob cid mimetype storage_str 686 686 + Util.Sqlite.use_pool t.db @@ Queries.put_blob cid mimetype storage_str 687 687 688 688 let delete_blob t cid : unit Lwt.t = 689 689 let%lwt blob_opt = get_blob_metadata t cid in ··· 692 692 delete_blob_file ~did:t.did ~cid ~storage 693 693 | None -> 694 694 () ) ; 695 695 - Util.use_pool t.db @@ Queries.delete_blob cid 695 695 + Util.Sqlite.use_pool t.db @@ Queries.delete_blob cid 696 696 697 697 let delete_orphaned_blobs_by_record_path t path : 698 698 (Cid.t * Blob_store.storage) list Lwt.t = 699 699 let%lwt results = 700 700 - Util.use_pool t.db @@ Queries.delete_orphaned_blobs_by_record_path path 700 700 + Util.Sqlite.use_pool t.db @@ Queries.delete_orphaned_blobs_by_record_path path 701 701 in 702 702 Lwt.return 703 703 @@ List.map ··· 706 706 results 707 707 708 708 let list_blob_refs t path : Cid.t list Lwt.t = 709 709 - Util.use_pool t.db @@ Queries.list_blob_refs path 709 709 + Util.Sqlite.use_pool t.db @@ Queries.list_blob_refs path 710 710 711 711 let put_blob_ref t path cid : unit Lwt.t = 712 712 - Util.use_pool t.db @@ Queries.put_blob_ref path cid 712 712 + Util.Sqlite.use_pool t.db @@ Queries.put_blob_ref path cid 713 713 714 714 let put_blob_refs t path cids : (unit, exn) Lwt_result.t = 715 715 if List.is_empty cids then Lwt.return_ok () 716 716 else 717 717 Lwt_result.map (fun _ -> ()) 718 718 - @@ Util.multi_query t.db 718 718 + @@ Util.Sqlite.multi_query t.db 719 719 (List.map (fun cid -> Queries.put_blob_ref cid path) cids) 720 720 721 721 let clear_blob_refs t path cids : unit Lwt.t = 722 722 if List.is_empty cids then Lwt.return_unit 723 723 - else Util.use_pool t.db @@ Queries.clear_blob_refs path cids 723 723 + else Util.Sqlite.use_pool t.db @@ Queries.clear_blob_refs path cids 724 724 725 725 let update_blob_storage t cid storage : unit Lwt.t = 726 726 let storage_str = Blob_store.storage_to_string storage in 727 727 - Util.use_pool t.db @@ Queries.update_blob_storage cid storage_str 727 727 + Util.Sqlite.use_pool t.db @@ Queries.update_blob_storage cid storage_str 728 728 729 729 let list_blobs_by_storage t ~storage ~limit ~cursor : 730 730 (Cid.t * string) list Lwt.t = 731 731 let storage_str = Blob_store.storage_to_string storage in 732 732 - Util.use_pool t.db 732 732 + Util.Sqlite.use_pool t.db 733 733 @@ Queries.list_blobs_by_storage ~storage:storage_str ~limit ~cursor

-600

pegasus/lib/util.ml

··· 1 1 - module Constants = struct 2 2 - let data_dir = 3 3 - Core.Filename.to_absolute_exn Env.data_dir 4 4 - ~relative_to:(Core_unix.getcwd ()) 5 5 - 6 6 - let pegasus_db_filepath = Filename.concat data_dir "pegasus.db" 7 7 - 8 8 - let pegasus_db_location = "sqlite3://" ^ pegasus_db_filepath |> Uri.of_string 9 9 - 10 10 - let user_db_filepath did = 11 11 - let dirname = Filename.concat data_dir "store" in 12 12 - let filename = Str.global_replace (Str.regexp ":") "_" did in 13 13 - Filename.concat dirname filename ^ ".db" 14 14 - 15 15 - let user_db_location did = 16 16 - "sqlite3://" ^ user_db_filepath did |> Uri.of_string 17 17 - 18 18 - let user_blobs_location did = 19 19 - did 20 20 - |> Str.global_replace (Str.regexp ":") "_" 21 21 - |> (Filename.concat data_dir "blobs" |> Filename.concat) 22 22 - end 23 23 - 24 24 - module Syntax = struct 25 25 - let unwrap m = 26 26 - match%lwt m with 27 27 - | Ok x -> 28 28 - Lwt.return x 29 29 - | Error e -> 30 30 - raise (Caqti_error.Exn e) 31 31 - 32 32 - (* unwraps an Lwt result, raising an exception if there's an error *) 33 33 - let ( let$! ) m f = 34 34 - match%lwt m with Ok x -> f x | Error e -> raise (Caqti_error.Exn e) 35 35 - 36 36 - (* unwraps an Lwt result, raising an exception if there's an error *) 37 37 - let ( >$! ) m f = 38 38 - match%lwt m with 39 39 - | Ok x -> 40 40 - Lwt.return (f x) 41 41 - | Error e -> 42 42 - raise (Caqti_error.Exn e) 43 43 - end 44 44 - 45 45 - module Rapper = struct 46 46 - module CID : Rapper.CUSTOM with type t = Cid.t = struct 47 47 - type t = Cid.t 48 48 - 49 49 - let t = 50 50 - let encode cid = 51 51 - try Ok (Cid.to_string cid) with e -> Error (Printexc.to_string e) 52 52 - in 53 53 - Caqti_type.(custom ~encode ~decode:Cid.of_string string) 54 54 - end 55 55 - 56 56 - module Blob : Rapper.CUSTOM with type t = bytes = struct 57 57 - type t = bytes 58 58 - 59 59 - let t = 60 60 - let encode blob = 61 61 - try Ok (Bytes.to_string blob) with e -> Error (Printexc.to_string e) 62 62 - in 63 63 - let decode blob = 64 64 - try Ok (Bytes.of_string blob) with e -> Error (Printexc.to_string e) 65 65 - in 66 66 - Caqti_type.(custom ~encode ~decode string) 67 67 - end 68 68 - 69 69 - module Json : Rapper.CUSTOM with type t = Yojson.Safe.t = struct 70 70 - type t = Yojson.Safe.t 71 71 - 72 72 - let t = 73 73 - let encode json = 74 74 - try Ok (Yojson.Safe.to_string json ~std:true) 75 75 - with e -> Error (Printexc.to_string e) 76 76 - in 77 77 - let decode json = 78 78 - try Ok (Yojson.Safe.from_string json) 79 79 - with e -> Error (Printexc.to_string e) 80 80 - in 81 81 - Caqti_type.(custom ~encode ~decode string) 82 82 - end 83 83 - end 84 84 - 85 85 - module Did_doc_types = struct 86 86 - type string_or_null = string option 87 87 - 88 88 - let string_or_null_to_yojson = function Some s -> `String s | None -> `Null 89 89 - 90 90 - let string_or_null_of_yojson = function 91 91 - | `String s -> 92 92 - Ok (Some s) 93 93 - | `Null -> 94 94 - Ok None 95 95 - | _ -> 96 96 - Error "invalid field value" 97 97 - 98 98 - type string_or_strings = [`String of string | `Strings of string list] 99 99 - 100 100 - let string_or_strings_to_yojson = function 101 101 - | `String c -> 102 102 - `String c 103 103 - | `Strings cs -> 104 104 - `List (List.map (fun c -> `String c) cs) 105 105 - 106 106 - let string_or_strings_of_yojson = function 107 107 - | `String c -> 108 108 - Ok (`Strings [c]) 109 109 - | `List cs -> 110 110 - Ok (`Strings (Yojson.Safe.Util.filter_string cs)) 111 111 - | _ -> 112 112 - Error "invalid field value" 113 113 - 114 114 - type string_map = (string * string) list 115 115 - 116 116 - let string_map_to_yojson = function 117 117 - | [] -> 118 118 - `Assoc [] 119 119 - | m -> 120 120 - `Assoc (List.map (fun (k, v) -> (k, `String v)) m) 121 121 - 122 122 - let string_map_of_yojson = function 123 123 - | `Null -> 124 124 - Ok [] 125 125 - | `Assoc m -> 126 126 - Ok 127 127 - (List.filter_map 128 128 - (fun (k, v) -> 129 129 - match (k, v) with _, `String s -> Some (k, s) | _, _ -> None ) 130 130 - m ) 131 131 - | _ -> 132 132 - Error "invalid field value" 133 133 - 134 134 - type string_or_string_map = [`String of string | `String_map of string_map] 135 135 - 136 136 - let string_or_string_map_to_yojson = function 137 137 - | `String c -> 138 138 - `String c 139 139 - | `String_map m -> 140 140 - `Assoc (List.map (fun (k, v) -> (k, `String v)) m) 141 141 - 142 142 - let string_or_string_map_of_yojson = function 143 143 - | `String c -> 144 144 - Ok (`String c) 145 145 - | `Assoc m -> 146 146 - string_map_of_yojson (`Assoc m) |> Result.map (fun m -> `String_map m) 147 147 - | _ -> 148 148 - Error "invalid field value" 149 149 - 150 150 - type string_or_string_map_or_either_list = 151 151 - [ `String of string 152 152 - | `String_map of string_map 153 153 - | `List of string_or_string_map list ] 154 154 - 155 155 - let string_or_string_map_or_either_list_to_yojson = function 156 156 - | `String c -> 157 157 - `String c 158 158 - | `String_map m -> 159 159 - `Assoc (List.map (fun (k, v) -> (k, `String v)) m) 160 160 - | `List l -> 161 161 - `List (List.map string_or_string_map_to_yojson l) 162 162 - 163 163 - let string_or_string_map_or_either_list_of_yojson = function 164 164 - | `String c -> 165 165 - Ok (`String c) 166 166 - | `Assoc m -> 167 167 - string_map_of_yojson (`Assoc m) |> Result.map (fun m -> `String_map m) 168 168 - | `List l -> 169 169 - Ok 170 170 - (`List 171 171 - ( List.map string_or_string_map_of_yojson l 172 172 - |> List.filter_map (function Ok x -> Some x | Error _ -> None) ) ) 173 173 - | _ -> 174 174 - Error "invalid field value" 175 175 - end 176 176 - 177 177 - type caqti_pool = (Caqti_lwt.connection, Caqti_error.t) Caqti_lwt_unix.Pool.t 178 178 - 179 179 - (* turns a caqti error into an exception *) 180 180 - let caqti_result_exn = function 181 181 - | Ok x -> 182 182 - Ok x 183 183 - | Error caqti_err -> 184 184 - Error (Caqti_error.Exn caqti_err) 185 185 - 186 186 - let _init_connection (module Db : Rapper_helper.CONNECTION) : 187 187 - (unit, Caqti_error.t) Lwt_result.t = 188 188 - let open Lwt_result.Syntax in 189 189 - let open Caqti_request.Infix in 190 190 - let open Caqti_type in 191 191 - let* _ = 192 192 - Db.find (((unit ->! string) ~oneshot:true) "PRAGMA journal_mode=WAL") () 193 193 - in 194 194 - let* _ = 195 195 - Db.exec (((unit ->. unit) ~oneshot:true) "PRAGMA foreign_keys=ON") () 196 196 - in 197 197 - let* _ = 198 198 - Db.exec (((unit ->. unit) ~oneshot:true) "PRAGMA synchronous=NORMAL") () 199 199 - in 200 200 - let* _ = 201 201 - Db.find (((unit ->! int) ~oneshot:true) "PRAGMA busy_timeout=5000") () 202 202 - in 203 203 - Lwt.return_ok () 204 204 - 205 205 - (* creates an sqlite pool *) 206 206 - let connect_sqlite ?(create = false) ?(write = true) db_uri : caqti_pool Lwt.t = 207 207 - let uri = 208 208 - Uri.add_query_params' db_uri 209 209 - [("create", string_of_bool create); ("write", string_of_bool write)] 210 210 - in 211 211 - let pool_config = Caqti_pool_config.create ~max_size:16 ~max_idle_size:4 () in 212 212 - match 213 213 - Caqti_lwt_unix.connect_pool ~pool_config ~post_connect:_init_connection uri 214 214 - with 215 215 - | Ok pool -> 216 216 - Lwt.return pool 217 217 - | Error e -> 218 218 - raise (Caqti_error.Exn e) 219 219 - 220 220 - let with_connection db_uri f = 221 221 - match%lwt 222 222 - Caqti_lwt_unix.with_connection db_uri (fun conn -> 223 223 - match%lwt _init_connection conn with 224 224 - | Ok () -> 225 225 - f conn 226 226 - | Error e -> 227 227 - Lwt.return_error e ) 228 228 - with 229 229 - | Ok result -> 230 230 - Lwt.return result 231 231 - | Error e -> 232 232 - raise (Caqti_error.Exn e) 233 233 - 234 234 - let use_pool ?(timeout = 60.0) pool 235 235 - (f : Caqti_lwt.connection -> ('a, Caqti_error.t) Lwt_result.t) : 'a Lwt.t = 236 236 - match%lwt 237 237 - Lwt_unix.with_timeout timeout (fun () -> Caqti_lwt_unix.Pool.use f pool) 238 238 - with 239 239 - | Ok res -> 240 240 - Lwt.return res 241 241 - | Error e -> 242 242 - raise (Caqti_error.Exn e) 243 243 - 244 244 - let transact conn fn : (unit, 'e) Lwt_result.t = 245 245 - let module C = (val conn : Caqti_lwt.CONNECTION) in 246 246 - match%lwt C.start () with 247 247 - | Ok () -> ( 248 248 - try%lwt 249 249 - match%lwt fn () with 250 250 - | Ok _ -> ( 251 251 - match%lwt C.commit () with 252 252 - | Ok () -> 253 253 - Lwt.return_ok () 254 254 - | Error e -> ( 255 255 - match%lwt C.rollback () with 256 256 - | Ok () -> 257 257 - Lwt.return_error e 258 258 - | Error e -> 259 259 - Lwt.return_error e ) ) 260 260 - | Error e -> ( 261 261 - match%lwt C.rollback () with 262 262 - | Ok () -> 263 263 - Lwt.return_error e 264 264 - | Error e -> 265 265 - Lwt.return_error e ) 266 266 - with e -> ( 267 267 - match%lwt C.rollback () with 268 268 - | Ok () -> 269 269 - Lwt.return_error 270 270 - ( match e with 271 271 - | Caqti_error.Exn e -> 272 272 - e 273 273 - | e -> 274 274 - Caqti_error.request_failed ~query:"unknown" 275 275 - ~uri:(Uri.of_string "//unknown") 276 276 - (Caqti_error.Msg (Printexc.to_string e)) ) 277 277 - | Error e -> 278 278 - Lwt.return_error e ) ) 279 279 - | Error e -> 280 280 - Lwt.return_error e 281 281 - 282 282 - (* runs a bunch of queries in a transaction, catches duplicate insertion, returning how many succeeded *) 283 283 - let multi_query pool 284 284 - (queries : (Caqti_lwt.connection -> ('a, Caqti_error.t) Lwt_result.t) list) 285 285 - : (int, exn) Lwt_result.t = 286 286 - let open Syntax in 287 287 - Lwt_result.catch (fun () -> 288 288 - use_pool pool (fun connection -> 289 289 - let module C = (val connection : Caqti_lwt.CONNECTION) in 290 290 - let$! () = C.start () in 291 291 - let is_ignorable_error e = 292 292 - match (e : Caqti_error.t) with 293 293 - | `Request_failed qe | `Response_failed qe -> ( 294 294 - match Caqti_error.cause (`Request_failed qe) with 295 295 - | `Not_null_violation | `Unique_violation -> 296 296 - true 297 297 - | _ -> 298 298 - false ) 299 299 - | _ -> 300 300 - false 301 301 - in 302 302 - let rec aux acc queries = 303 303 - match acc with 304 304 - | Error e -> 305 305 - Lwt.return_error e 306 306 - | Ok count -> ( 307 307 - match queries with 308 308 - | [] -> 309 309 - Lwt.return (Ok count) 310 310 - | query :: rest -> ( 311 311 - let%lwt result = query connection in 312 312 - match result with 313 313 - | Ok _ -> 314 314 - aux (Ok (count + 1)) rest 315 315 - | Error e -> 316 316 - if is_ignorable_error e then aux (Ok count) rest 317 317 - else Lwt.return_error e ) ) 318 318 - in 319 319 - let%lwt result = aux (Ok 0) queries in 320 320 - match result with 321 321 - | Ok count -> 322 322 - let$! () = C.commit () in 323 323 - Lwt.return_ok count 324 324 - | Error e -> 325 325 - let%lwt _ = C.rollback () in 326 326 - Lwt.return_error e ) ) 327 327 - 328 328 - let minute = 60 * 1000 329 329 - 330 330 - let hour = 60 * minute 331 331 - 332 332 - let day = 24 * hour 333 333 - 334 334 - (* unix timestamp *) 335 335 - let now_ms () : int = int_of_float (Unix.gettimeofday () *. 1000.) 336 336 - 337 337 - let ms_to_iso8601 ms = 338 338 - let s = float_of_int ms /. 1000. in 339 339 - Timedesc.(of_timestamp_float_s_exn s |> to_iso8601) 340 340 - 341 341 - (* returns all blob refs in a record *) 342 342 - let rec find_blob_refs (record : Mist.Lex.repo_record) : Mist.Blob_ref.t list = 343 343 - let rec aux acc entries = 344 344 - List.fold_left 345 345 - (fun acc value -> 346 346 - match value with 347 347 - | `BlobRef blob -> 348 348 - blob :: acc 349 349 - | `LexMap map -> 350 350 - find_blob_refs map @ acc 351 351 - | `LexArray arr -> 352 352 - aux acc (Array.to_list arr) @ acc 353 353 - | _ -> 354 354 - acc ) 355 355 - acc entries 356 356 - in 357 357 - aux [] (Mist.Lex.String_map.bindings record |> List.map snd) 358 358 - |> List.sort_uniq (fun (r1 : Mist.Blob_ref.t) r2 -> Cid.compare r1.ref r2.ref) 359 359 - 360 360 - type validate_handle_error = 361 361 - | InvalidFormat of string 362 362 - | TooShort of string 363 363 - | TooLong of string 364 364 - 365 365 - let validate_handle handle = 366 366 - (* if it's a custom domain, just check that it contains a period *) 367 367 - if not (String.ends_with ~suffix:("." ^ Env.hostname) handle) then 368 368 - if not (String.contains handle '.') then 369 369 - Error (InvalidFormat ("must end with " ^ "." ^ Env.hostname)) 370 370 - else Ok () 371 371 - else 372 372 - let front = 373 373 - String.sub handle 0 374 374 - (String.length handle - (String.length Env.hostname + 1)) 375 375 - in 376 376 - if String.contains front '.' then 377 377 - Error (InvalidFormat "can't contain periods") 378 378 - else 379 379 - match String.length front with 380 380 - | l when l < 3 -> 381 381 - Error (TooShort "must be at least 3 characters") 382 382 - | l when l > 18 -> 383 383 - Error (TooLong "must be at most 18 characters") 384 384 - | _ -> 385 385 - Ok () 386 386 - 387 387 - let mkfile_p path ~perm = 388 388 - Core_unix.mkdir_p (Filename.dirname path) ~perm:0o755 ; 389 389 - Core_unix.openfile ~mode:[O_CREAT; O_WRONLY] ~perm path |> Core_unix.close 390 390 - 391 391 - let sig_matches_some_did_key ~did_keys ~signature ~msg = 392 392 - List.find_opt 393 393 - (fun key -> 394 394 - let raw, (module Curve) = 395 395 - Kleidos.parse_multikey_str (String.sub key 8 (String.length key - 8)) 396 396 - in 397 397 - let valid = 398 398 - Curve.verify ~pubkey:(Curve.normalize_pubkey_to_raw raw) ~signature ~msg 399 399 - in 400 400 - valid ) 401 401 - did_keys 402 402 - <> None 403 403 - 404 404 - let request_ip req = 405 405 - Dream.header req "X-Forwarded-For" 406 406 - |> Option.value ~default:(Dream.client req) 407 407 - |> String.split_on_char ',' |> List.hd |> String.split_on_char ':' |> List.hd 408 408 - |> String.trim 409 409 - 410 410 - let rec http_get ?(max_redirects = 5) ?(no_drain = false) ?headers uri = 411 411 - let ua = "pegasus (" ^ Env.host_endpoint ^ ")" in 412 412 - let headers = 413 413 - match headers with 414 414 - | Some headers -> 415 415 - Http.Header.add_unless_exists headers "User-Agent" ua 416 416 - | None -> 417 417 - Http.Header.of_list [("User-Agent", ua)] 418 418 - in 419 419 - let%lwt ans = Cohttp_lwt_unix.Client.get ~headers uri in 420 420 - follow_redirect ~max_redirects ~no_drain uri ans 421 421 - 422 422 - and follow_redirect ~max_redirects ~no_drain request_uri (response, body) = 423 423 - let status = Http.Response.status response in 424 424 - (* the unconsumed body would otherwise leak memory *) 425 425 - let%lwt () = 426 426 - if status <> `OK && not no_drain then Cohttp_lwt.Body.drain_body body 427 427 - else Lwt.return_unit 428 428 - in 429 429 - match status with 430 430 - | `Permanent_redirect | `Moved_permanently -> 431 431 - handle_redirect ~permanent:true ~max_redirects request_uri response 432 432 - | `Found | `Temporary_redirect -> 433 433 - handle_redirect ~permanent:false ~max_redirects request_uri response 434 434 - | _ -> 435 435 - Lwt.return (response, body) 436 436 - 437 437 - and handle_redirect ~permanent ~max_redirects request_uri response = 438 438 - if max_redirects <= 0 then failwith "too many redirects" 439 439 - else 440 440 - let headers = Http.Response.headers response in 441 441 - let location = Http.Header.get headers "location" in 442 442 - match location with 443 443 - | None -> 444 444 - failwith "redirection without Location header" 445 445 - | Some url -> 446 446 - let uri = Uri.of_string url in 447 447 - let%lwt () = 448 448 - if permanent then 449 449 - Logs_lwt.warn (fun m -> 450 450 - m "Permanent redirection from %s to %s" 451 451 - (Uri.to_string request_uri) 452 452 - url ) 453 453 - else Lwt.return_unit 454 454 - in 455 455 - http_get uri ~max_redirects:(max_redirects - 1) 456 456 - 457 457 - let copy_query req = Dream.all_queries req |> List.map (fun (k, v) -> (k, [v])) 458 458 - 459 459 - let make_headers headers = 460 460 - List.fold_left 461 461 - (fun headers (k, v) -> 462 462 - match v with 463 463 - | Some value -> 464 464 - Http.Header.add headers k value 465 465 - | None -> 466 466 - headers ) 467 467 - (Http.Header.init ()) headers 468 468 - 469 469 - let str_contains ~affix str = 470 470 - let re = Str.regexp_string affix in 471 471 - try 472 472 - ignore (Str.search_forward re str 0) ; 473 473 - true 474 474 - with Not_found -> false 475 475 - 476 476 - let make_code () = 477 477 - let () = Mirage_crypto_rng_unix.use_default () in 478 478 - let token = 479 479 - Multibase.Base32.encode_string ~pad:false 480 480 - @@ Mirage_crypto_rng_unix.getrandom 8 481 481 - in 482 482 - String.sub token 0 5 ^ "-" ^ String.sub token 5 5 483 483 - 484 484 - module type Template = sig 485 485 - type props 486 486 - 487 487 - val props_of_json : Yojson.Basic.t -> props 488 488 - 489 489 - val props_to_json : props -> Yojson.Basic.t 490 490 - 491 491 - val make : ?key:string -> props:props -> unit -> React.element 492 492 - end 493 493 - 494 494 - let render_html ?status ?title (type props) 495 495 - (template : (module Template with type props = props)) ~props = 496 496 - let module Template = (val template : Template with type props = props) in 497 497 - let props_json = Template.props_to_json props |> Yojson.Basic.to_string in 498 498 - let page_data = Printf.sprintf "window.__PAGE__ = {props: %s};" props_json in 499 499 - let app = Template.make ~props () in 500 500 - let page = 501 501 - Frontend.Layout.make ?title ~favicon:Env.favicon_url ~children:app () 502 502 - in 503 503 - Dream.stream ?status 504 504 - ~headers:[("Content-Type", "text/html")] 505 505 - (fun stream -> 506 506 - [%lwt 507 507 - let html, subscribe = 508 508 - ReactServerDOM.render_html ~skipRoot:false 509 509 - ~bootstrapScriptContent:page_data 510 510 - ~bootstrapScripts:["/public/client.js"] page 511 511 - in 512 512 - [%lwt 513 513 - let () = Dream.write stream html in 514 514 - [%lwt 515 515 - let () = Dream.flush stream in 516 516 - [%lwt 517 517 - let () = 518 518 - subscribe (fun chunk -> 519 519 - [%lwt 520 520 - let () = Dream.write stream chunk in 521 521 - Dream.flush stream] ) 522 522 - in 523 523 - Dream.flush stream]]]] ) 524 524 - 525 525 - let make_data_uri ~mimetype ~data = 526 526 - let base64_data = data |> Bytes.to_string |> Base64.encode_string in 527 527 - Printf.sprintf "data:%s;base64,%s" mimetype base64_data 528 528 - 529 529 - let at_uri_regexp = 530 530 - Re.Pcre.re 531 531 - {|^at:\/\/([a-zA-Z0-9._:%-]+)(?:\/([a-zA-Z0-9-.]+)(?:\/([a-zA-Z0-9._~:@!$&%')(*+,;=-]+))?)?(?:#(\/[a-zA-Z0-9._~:@!$&%')(*+,;=\-[\]\/\\]*))?$|} 532 532 - |> Re.compile 533 533 - 534 534 - type at_uri = 535 535 - {repo: string; collection: string; rkey: string; fragment: string option} 536 536 - 537 537 - let parse_at_uri uri = 538 538 - match Re.exec_opt at_uri_regexp uri with 539 539 - | None -> 540 540 - None 541 541 - | Some m -> ( 542 542 - try 543 543 - Some 544 544 - { repo= Re.Group.get m 1 545 545 - ; collection= Re.Group.get m 2 546 546 - ; rkey= Re.Group.get m 3 547 547 - ; fragment= Re.Group.get_opt m 4 } 548 548 - with _ -> None ) 549 549 - 550 550 - let make_at_uri ~repo ~collection ~rkey ~fragment = 551 551 - Printf.sprintf "at://%s/%s/%s%s" repo collection rkey 552 552 - (Option.value ~default:"" fragment) 553 553 - 554 554 - let nsid_authority nsid = 555 555 - match String.rindex_opt nsid '.' with 556 556 - | None -> 557 557 - nsid 558 558 - | Some idx -> 559 559 - String.sub nsid 0 idx 560 560 - 561 561 - let send_email_or_log ~(recipients : Letters.recipient list) ~subject 562 562 - ~(body : Letters.body) = 563 563 - let log_email () = 564 564 - match body with 565 565 - | Plain text | Html text | Mixed (text, _, _) -> 566 566 - let to_addr = 567 567 - List.find_map 568 568 - (fun (r : Letters.recipient) -> 569 569 - match r with To addr -> Some addr | _ -> None ) 570 570 - recipients 571 571 - |> Option.get 572 572 - in 573 573 - Log.info (fun log -> log "email to %s: %s" to_addr text) 574 574 - in 575 575 - match (Env.smtp_config, Env.smtp_sender) with 576 576 - | Some config, Some sender -> ( 577 577 - match Letters.create_email ~from:sender ~recipients ~subject ~body () with 578 578 - | Error e -> 579 579 - failwith (Printf.sprintf "failed to construct email: %s" e) 580 580 - | Ok message -> ( 581 581 - try%lwt Letters.send ~config ~sender ~recipients ~message 582 582 - with e -> 583 583 - Log.log_exn e ; 584 584 - Lwt.return (log_email ()) ) ) 585 585 - | _ -> 586 586 - Lwt.return (log_email ()) 587 587 - 588 588 - let s3_error_to_string : Aws_s3_lwt.S3.error -> string = function 589 589 - | Redirect endpoint -> 590 590 - "redirect to " ^ endpoint.host 591 591 - | Throttled -> 592 592 - "throttled" 593 593 - | Unknown (code, msg) -> 594 594 - Printf.sprintf "unknown error %d: %s" code msg 595 595 - | Failed exn -> 596 596 - Printf.sprintf "failed: %s" (Printexc.to_string exn) 597 597 - | Forbidden -> 598 598 - "forbidden" 599 599 - | Not_found -> 600 600 - "not found"

+20

pegasus/lib/util/constants.ml

··· 1 1 + let data_dir = 2 2 + Core.Filename.to_absolute_exn Env.data_dir 3 3 + ~relative_to:(Core_unix.getcwd ()) 4 4 + 5 5 + let pegasus_db_filepath = Filename.concat data_dir "pegasus.db" 6 6 + 7 7 + let pegasus_db_location = "sqlite3://" ^ pegasus_db_filepath |> Uri.of_string 8 8 + 9 9 + let user_db_filepath did = 10 10 + let dirname = Filename.concat data_dir "store" in 11 11 + let filename = Str.global_replace (Str.regexp ":") "_" did in 12 12 + Filename.concat dirname filename ^ ".db" 13 13 + 14 14 + let user_db_location did = 15 15 + "sqlite3://" ^ user_db_filepath did |> Uri.of_string 16 16 + 17 17 + let user_blobs_location did = 18 18 + did 19 19 + |> Str.global_replace (Str.regexp ":") "_" 20 20 + |> (Filename.concat data_dir "blobs" |> Filename.concat)

+44

pegasus/lib/util/html.ml

··· 1 1 + module type Template = sig 2 2 + type props 3 3 + 4 4 + val props_of_json : Yojson.Basic.t -> props 5 5 + 6 6 + val props_to_json : props -> Yojson.Basic.t 7 7 + 8 8 + val make : ?key:string -> props:props -> unit -> React.element 9 9 + end 10 10 + 11 11 + let render_page ?status ?title (type props) 12 12 + (template : (module Template with type props = props)) ~props = 13 13 + let module Template = (val template : Template with type props = props) in 14 14 + let props_json = Template.props_to_json props |> Yojson.Basic.to_string in 15 15 + let page_data = Printf.sprintf "window.__PAGE__ = {props: %s};" props_json in 16 16 + let app = Template.make ~props () in 17 17 + let page = 18 18 + Frontend.Layout.make ?title ~favicon:Env.favicon_url ~children:app () 19 19 + in 20 20 + Dream.stream ?status 21 21 + ~headers:[("Content-Type", "text/html")] 22 22 + (fun stream -> 23 23 + [%lwt 24 24 + let html, subscribe = 25 25 + ReactServerDOM.render_html ~skipRoot:false 26 26 + ~bootstrapScriptContent:page_data 27 27 + ~bootstrapScripts:["/public/client.js"] page 28 28 + in 29 29 + [%lwt 30 30 + let () = Dream.write stream html in 31 31 + [%lwt 32 32 + let () = Dream.flush stream in 33 33 + [%lwt 34 34 + let () = 35 35 + subscribe (fun chunk -> 36 36 + [%lwt 37 37 + let () = Dream.write stream chunk in 38 38 + Dream.flush stream] ) 39 39 + in 40 40 + Dream.flush stream]]]] ) 41 41 + 42 42 + let make_data_uri ~mimetype ~data = 43 43 + let base64_data = data |> Bytes.to_string |> Base64.encode_string in 44 44 + Printf.sprintf "data:%s;base64,%s" mimetype base64_data

+58

pegasus/lib/util/http_.ml

··· 1 1 + let rec get ?(max_redirects = 5) ?(no_drain = false) ?headers uri = 2 2 + let ua = "pegasus (" ^ Env.host_endpoint ^ ")" in 3 3 + let headers = 4 4 + match headers with 5 5 + | Some headers -> 6 6 + Http.Header.add_unless_exists headers "User-Agent" ua 7 7 + | None -> 8 8 + Http.Header.of_list [("User-Agent", ua)] 9 9 + in 10 10 + let%lwt ans = Cohttp_lwt_unix.Client.get ~headers uri in 11 11 + follow_redirect ~max_redirects ~no_drain uri ans 12 12 + 13 13 + and follow_redirect ~max_redirects ~no_drain request_uri (response, body) = 14 14 + let status = Http.Response.status response in 15 15 + (* the unconsumed body would otherwise leak memory *) 16 16 + let%lwt () = 17 17 + if status <> `OK && not no_drain then Cohttp_lwt.Body.drain_body body 18 18 + else Lwt.return_unit 19 19 + in 20 20 + match status with 21 21 + | `Permanent_redirect | `Moved_permanently -> 22 22 + handle_redirect ~permanent:true ~max_redirects request_uri response 23 23 + | `Found | `Temporary_redirect -> 24 24 + handle_redirect ~permanent:false ~max_redirects request_uri response 25 25 + | _ -> 26 26 + Lwt.return (response, body) 27 27 + 28 28 + and handle_redirect ~permanent ~max_redirects request_uri response = 29 29 + if max_redirects <= 0 then failwith "too many redirects" 30 30 + else 31 31 + let headers = Http.Response.headers response in 32 32 + let location = Http.Header.get headers "location" in 33 33 + match location with 34 34 + | None -> 35 35 + failwith "redirection without Location header" 36 36 + | Some url -> 37 37 + let uri = Uri.of_string url in 38 38 + let%lwt () = 39 39 + if permanent then 40 40 + Logs_lwt.warn (fun m -> 41 41 + m "Permanent redirection from %s to %s" 42 42 + (Uri.to_string request_uri) 43 43 + url ) 44 44 + else Lwt.return_unit 45 45 + in 46 46 + get uri ~max_redirects:(max_redirects - 1) 47 47 + 48 48 + let copy_query req = Dream.all_queries req |> List.map (fun (k, v) -> (k, [v])) 49 49 + 50 50 + let make_headers headers = 51 51 + List.fold_left 52 52 + (fun headers (k, v) -> 53 53 + match v with 54 54 + | Some value -> 55 55 + Http.Header.add headers k value 56 56 + | None -> 57 57 + headers ) 58 58 + (Http.Header.init ()) headers

+37

pegasus/lib/util/rapper_.ml

··· 1 1 + module CID : Rapper.CUSTOM with type t = Cid.t = struct 2 2 + type t = Cid.t 3 3 + 4 4 + let t = 5 5 + let encode cid = 6 6 + try Ok (Cid.to_string cid) with e -> Error (Printexc.to_string e) 7 7 + in 8 8 + Caqti_type.(custom ~encode ~decode:Cid.of_string string) 9 9 + end 10 10 + 11 11 + module Blob : Rapper.CUSTOM with type t = bytes = struct 12 12 + type t = bytes 13 13 + 14 14 + let t = 15 15 + let encode blob = 16 16 + try Ok (Bytes.to_string blob) with e -> Error (Printexc.to_string e) 17 17 + in 18 18 + let decode blob = 19 19 + try Ok (Bytes.of_string blob) with e -> Error (Printexc.to_string e) 20 20 + in 21 21 + Caqti_type.(custom ~encode ~decode string) 22 22 + end 23 23 + 24 24 + module Json : Rapper.CUSTOM with type t = Yojson.Safe.t = struct 25 25 + type t = Yojson.Safe.t 26 26 + 27 27 + let t = 28 28 + let encode json = 29 29 + try Ok (Yojson.Safe.to_string json ~std:true) 30 30 + with e -> Error (Printexc.to_string e) 31 31 + in 32 32 + let decode json = 33 33 + try Ok (Yojson.Safe.from_string json) 34 34 + with e -> Error (Printexc.to_string e) 35 35 + in 36 36 + Caqti_type.(custom ~encode ~decode string) 37 37 + end

+150

pegasus/lib/util/sqlite_.ml

··· 1 1 + type caqti_pool = (Caqti_lwt.connection, Caqti_error.t) Caqti_lwt_unix.Pool.t 2 2 + 3 3 + (* turns a caqti error into an exception *) 4 4 + let caqti_result_exn = function 5 5 + | Ok x -> 6 6 + Ok x 7 7 + | Error caqti_err -> 8 8 + Error (Caqti_error.Exn caqti_err) 9 9 + 10 10 + let _init_connection (module Db : Rapper_helper.CONNECTION) : 11 11 + (unit, Caqti_error.t) Lwt_result.t = 12 12 + let open Lwt_result.Syntax in 13 13 + let open Caqti_request.Infix in 14 14 + let open Caqti_type in 15 15 + let* _ = 16 16 + Db.find (((unit ->! string) ~oneshot:true) "PRAGMA journal_mode=WAL") () 17 17 + in 18 18 + let* _ = 19 19 + Db.exec (((unit ->. unit) ~oneshot:true) "PRAGMA foreign_keys=ON") () 20 20 + in 21 21 + let* _ = 22 22 + Db.exec (((unit ->. unit) ~oneshot:true) "PRAGMA synchronous=NORMAL") () 23 23 + in 24 24 + let* _ = 25 25 + Db.find (((unit ->! int) ~oneshot:true) "PRAGMA busy_timeout=5000") () 26 26 + in 27 27 + Lwt.return_ok () 28 28 + 29 29 + (* creates an sqlite pool *) 30 30 + let connect ?(create = false) ?(write = true) db_uri : caqti_pool Lwt.t = 31 31 + let uri = 32 32 + Uri.add_query_params' db_uri 33 33 + [("create", string_of_bool create); ("write", string_of_bool write)] 34 34 + in 35 35 + let pool_config = Caqti_pool_config.create ~max_size:16 ~max_idle_size:4 () in 36 36 + match 37 37 + Caqti_lwt_unix.connect_pool ~pool_config ~post_connect:_init_connection uri 38 38 + with 39 39 + | Ok pool -> 40 40 + Lwt.return pool 41 41 + | Error e -> 42 42 + raise (Caqti_error.Exn e) 43 43 + 44 44 + let with_connection db_uri f = 45 45 + match%lwt 46 46 + Caqti_lwt_unix.with_connection db_uri (fun conn -> 47 47 + match%lwt _init_connection conn with 48 48 + | Ok () -> 49 49 + f conn 50 50 + | Error e -> 51 51 + Lwt.return_error e ) 52 52 + with 53 53 + | Ok result -> 54 54 + Lwt.return result 55 55 + | Error e -> 56 56 + raise (Caqti_error.Exn e) 57 57 + 58 58 + let use_pool ?(timeout = 60.0) pool 59 59 + (f : Caqti_lwt.connection -> ('a, Caqti_error.t) Lwt_result.t) : 'a Lwt.t = 60 60 + match%lwt 61 61 + Lwt_unix.with_timeout timeout (fun () -> Caqti_lwt_unix.Pool.use f pool) 62 62 + with 63 63 + | Ok res -> 64 64 + Lwt.return res 65 65 + | Error e -> 66 66 + raise (Caqti_error.Exn e) 67 67 + 68 68 + let transact conn fn : (unit, 'e) Lwt_result.t = 69 69 + let module C = (val conn : Caqti_lwt.CONNECTION) in 70 70 + match%lwt C.start () with 71 71 + | Ok () -> ( 72 72 + try%lwt 73 73 + match%lwt fn () with 74 74 + | Ok _ -> ( 75 75 + match%lwt C.commit () with 76 76 + | Ok () -> 77 77 + Lwt.return_ok () 78 78 + | Error e -> ( 79 79 + match%lwt C.rollback () with 80 80 + | Ok () -> 81 81 + Lwt.return_error e 82 82 + | Error e -> 83 83 + Lwt.return_error e ) ) 84 84 + | Error e -> ( 85 85 + match%lwt C.rollback () with 86 86 + | Ok () -> 87 87 + Lwt.return_error e 88 88 + | Error e -> 89 89 + Lwt.return_error e ) 90 90 + with e -> ( 91 91 + match%lwt C.rollback () with 92 92 + | Ok () -> 93 93 + Lwt.return_error 94 94 + ( match e with 95 95 + | Caqti_error.Exn e -> 96 96 + e 97 97 + | e -> 98 98 + Caqti_error.request_failed ~query:"unknown" 99 99 + ~uri:(Uri.of_string "//unknown") 100 100 + (Caqti_error.Msg (Printexc.to_string e)) ) 101 101 + | Error e -> 102 102 + Lwt.return_error e ) ) 103 103 + | Error e -> 104 104 + Lwt.return_error e 105 105 + 106 106 + (* runs a bunch of queries in a transaction, catches duplicate insertion, returning how many succeeded *) 107 107 + let multi_query pool 108 108 + (queries : (Caqti_lwt.connection -> ('a, Caqti_error.t) Lwt_result.t) list) 109 109 + : (int, exn) Lwt_result.t = 110 110 + let open Syntax in 111 111 + Lwt_result.catch (fun () -> 112 112 + use_pool pool (fun connection -> 113 113 + let module C = (val connection : Caqti_lwt.CONNECTION) in 114 114 + let$! () = C.start () in 115 115 + let is_ignorable_error e = 116 116 + match (e : Caqti_error.t) with 117 117 + | `Request_failed qe | `Response_failed qe -> ( 118 118 + match Caqti_error.cause (`Request_failed qe) with 119 119 + | `Not_null_violation | `Unique_violation -> 120 120 + true 121 121 + | _ -> 122 122 + false ) 123 123 + | _ -> 124 124 + false 125 125 + in 126 126 + let rec aux acc queries = 127 127 + match acc with 128 128 + | Error e -> 129 129 + Lwt.return_error e 130 130 + | Ok count -> ( 131 131 + match queries with 132 132 + | [] -> 133 133 + Lwt.return (Ok count) 134 134 + | query :: rest -> ( 135 135 + let%lwt result = query connection in 136 136 + match result with 137 137 + | Ok _ -> 138 138 + aux (Ok (count + 1)) rest 139 139 + | Error e -> 140 140 + if is_ignorable_error e then aux (Ok count) rest 141 141 + else Lwt.return_error e ) ) 142 142 + in 143 143 + let%lwt result = aux (Ok 0) queries in 144 144 + match result with 145 145 + | Ok count -> 146 146 + let$! () = C.commit () in 147 147 + Lwt.return_ok count 148 148 + | Error e -> 149 149 + let%lwt _ = C.rollback () in 150 150 + Lwt.return_error e ) )

+50

pegasus/lib/util/syntax.ml

··· 1 1 + let unwrap m = 2 2 + match%lwt m with 3 3 + | Ok x -> 4 4 + Lwt.return x 5 5 + | Error e -> 6 6 + raise (Caqti_error.Exn e) 7 7 + 8 8 + (* unwraps an Lwt result, raising an exception if there's an error *) 9 9 + let ( let$! ) m f = 10 10 + match%lwt m with Ok x -> f x | Error e -> raise (Caqti_error.Exn e) 11 11 + 12 12 + (* unwraps an Lwt result, raising an exception if there's an error *) 13 13 + let ( >$! ) m f = 14 14 + match%lwt m with 15 15 + | Ok x -> 16 16 + Lwt.return (f x) 17 17 + | Error e -> 18 18 + raise (Caqti_error.Exn e) 19 19 + 20 20 + let at_uri_regexp = 21 21 + Re.Pcre.re 22 22 + {|^at:\/\/([a-zA-Z0-9._:%-]+)(?:\/([a-zA-Z0-9-.]+)(?:\/([a-zA-Z0-9._~:@!$&%')(*+,;=-]+))?)?(?:#(\/[a-zA-Z0-9._~:@!$&%')(*+,;=\-[\]\/\\]*))?$|} 23 23 + |> Re.compile 24 24 + 25 25 + type at_uri = 26 26 + {repo: string; collection: string; rkey: string; fragment: string option} 27 27 + 28 28 + let parse_at_uri uri = 29 29 + match Re.exec_opt at_uri_regexp uri with 30 30 + | None -> 31 31 + None 32 32 + | Some m -> ( 33 33 + try 34 34 + Some 35 35 + { repo= Re.Group.get m 1 36 36 + ; collection= Re.Group.get m 2 37 37 + ; rkey= Re.Group.get m 3 38 38 + ; fragment= Re.Group.get_opt m 4 } 39 39 + with _ -> None ) 40 40 + 41 41 + let make_at_uri ~repo ~collection ~rkey ~fragment = 42 42 + Printf.sprintf "at://%s/%s/%s%s" repo collection rkey 43 43 + (Option.value ~default:"" fragment) 44 44 + 45 45 + let nsid_authority nsid = 46 46 + match String.rindex_opt nsid '.' with 47 47 + | None -> 48 48 + nsid 49 49 + | Some idx -> 50 50 + String.sub nsid 0 idx

+12

pegasus/lib/util/time.ml

··· 1 1 + let minute = 60 * 1000 2 2 + 3 3 + let hour = 60 * minute 4 4 + 5 5 + let day = 24 * hour 6 6 + 7 7 + (* unix timestamp *) 8 8 + let now_ms () : int = int_of_float (Unix.gettimeofday () *. 1000.) 9 9 + 10 10 + let ms_to_iso8601 ms = 11 11 + let s = float_of_int ms /. 1000. in 12 12 + Timedesc.(of_timestamp_float_s_exn s |> to_iso8601)

+89

pegasus/lib/util/types.ml

··· 1 1 + type string_or_null = string option 2 2 + 3 3 + let string_or_null_to_yojson = function Some s -> `String s | None -> `Null 4 4 + 5 5 + let string_or_null_of_yojson = function 6 6 + | `String s -> 7 7 + Ok (Some s) 8 8 + | `Null -> 9 9 + Ok None 10 10 + | _ -> 11 11 + Error "invalid field value" 12 12 + 13 13 + type string_or_strings = [`String of string | `Strings of string list] 14 14 + 15 15 + let string_or_strings_to_yojson = function 16 16 + | `String c -> 17 17 + `String c 18 18 + | `Strings cs -> 19 19 + `List (List.map (fun c -> `String c) cs) 20 20 + 21 21 + let string_or_strings_of_yojson = function 22 22 + | `String c -> 23 23 + Ok (`Strings [c]) 24 24 + | `List cs -> 25 25 + Ok (`Strings (Yojson.Safe.Util.filter_string cs)) 26 26 + | _ -> 27 27 + Error "invalid field value" 28 28 + 29 29 + type string_map = (string * string) list 30 30 + 31 31 + let string_map_to_yojson = function 32 32 + | [] -> 33 33 + `Assoc [] 34 34 + | m -> 35 35 + `Assoc (List.map (fun (k, v) -> (k, `String v)) m) 36 36 + 37 37 + let string_map_of_yojson = function 38 38 + | `Null -> 39 39 + Ok [] 40 40 + | `Assoc m -> 41 41 + Ok 42 42 + (List.filter_map 43 43 + (fun (k, v) -> 44 44 + match (k, v) with _, `String s -> Some (k, s) | _, _ -> None ) 45 45 + m ) 46 46 + | _ -> 47 47 + Error "invalid field value" 48 48 + 49 49 + type string_or_string_map = [`String of string | `String_map of string_map] 50 50 + 51 51 + let string_or_string_map_to_yojson = function 52 52 + | `String c -> 53 53 + `String c 54 54 + | `String_map m -> 55 55 + `Assoc (List.map (fun (k, v) -> (k, `String v)) m) 56 56 + 57 57 + let string_or_string_map_of_yojson = function 58 58 + | `String c -> 59 59 + Ok (`String c) 60 60 + | `Assoc m -> 61 61 + string_map_of_yojson (`Assoc m) |> Result.map (fun m -> `String_map m) 62 62 + | _ -> 63 63 + Error "invalid field value" 64 64 + 65 65 + type string_or_string_map_or_either_list = 66 66 + [ `String of string 67 67 + | `String_map of string_map 68 68 + | `List of string_or_string_map list ] 69 69 + 70 70 + let string_or_string_map_or_either_list_to_yojson = function 71 71 + | `String c -> 72 72 + `String c 73 73 + | `String_map m -> 74 74 + `Assoc (List.map (fun (k, v) -> (k, `String v)) m) 75 75 + | `List l -> 76 76 + `List (List.map string_or_string_map_to_yojson l) 77 77 + 78 78 + let string_or_string_map_or_either_list_of_yojson = function 79 79 + | `String c -> 80 80 + Ok (`String c) 81 81 + | `Assoc m -> 82 82 + string_map_of_yojson (`Assoc m) |> Result.map (fun m -> `String_map m) 83 83 + | `List l -> 84 84 + Ok 85 85 + (`List 86 86 + ( List.map string_or_string_map_of_yojson l 87 87 + |> List.filter_map (function Ok x -> Some x | Error _ -> None) ) ) 88 88 + | _ -> 89 89 + Error "invalid field value"

+113

pegasus/lib/util/util.ml

··· 1 1 + module Constants = Constants 2 2 + 3 3 + module Syntax = Syntax 4 4 + 5 5 + module Rapper = Rapper_ 6 6 + 7 7 + module Types = Types 8 8 + 9 9 + module Sqlite = Sqlite_ 10 10 + 11 11 + module Time = Time 12 12 + 13 13 + module Http = Http_ 14 14 + 15 15 + module Html = Html 16 16 + 17 17 + (* returns all blob refs in a record *) 18 18 + let rec find_blob_refs (record : Mist.Lex.repo_record) : Mist.Blob_ref.t list = 19 19 + let rec aux acc entries = 20 20 + List.fold_left 21 21 + (fun acc value -> 22 22 + match value with 23 23 + | `BlobRef blob -> 24 24 + blob :: acc 25 25 + | `LexMap map -> 26 26 + find_blob_refs map @ acc 27 27 + | `LexArray arr -> 28 28 + aux acc (Array.to_list arr) @ acc 29 29 + | _ -> 30 30 + acc ) 31 31 + acc entries 32 32 + in 33 33 + aux [] (Mist.Lex.String_map.bindings record |> List.map snd) 34 34 + |> List.sort_uniq (fun (r1 : Mist.Blob_ref.t) r2 -> Cid.compare r1.ref r2.ref) 35 35 + 36 36 + let mkfile_p path ~perm = 37 37 + Core_unix.mkdir_p (Filename.dirname path) ~perm:0o755 ; 38 38 + Core_unix.openfile ~mode:[O_CREAT; O_WRONLY] ~perm path |> Core_unix.close 39 39 + 40 40 + let sig_matches_some_did_key ~did_keys ~signature ~msg = 41 41 + List.find_opt 42 42 + (fun key -> 43 43 + let raw, (module Curve) = 44 44 + Kleidos.parse_multikey_str (String.sub key 8 (String.length key - 8)) 45 45 + in 46 46 + let valid = 47 47 + Curve.verify ~pubkey:(Curve.normalize_pubkey_to_raw raw) ~signature ~msg 48 48 + in 49 49 + valid ) 50 50 + did_keys 51 51 + <> None 52 52 + 53 53 + let request_ip req = 54 54 + Dream.header req "X-Forwarded-For" 55 55 + |> Option.value ~default:(Dream.client req) 56 56 + |> String.split_on_char ',' |> List.hd |> String.split_on_char ':' |> List.hd 57 57 + |> String.trim 58 58 + 59 59 + let str_contains ~affix str = 60 60 + let re = Str.regexp_string affix in 61 61 + try 62 62 + ignore (Str.search_forward re str 0) ; 63 63 + true 64 64 + with Not_found -> false 65 65 + 66 66 + let make_code () = 67 67 + let () = Mirage_crypto_rng_unix.use_default () in 68 68 + let token = 69 69 + Multibase.Base32.encode_string ~pad:false 70 70 + @@ Mirage_crypto_rng_unix.getrandom 8 71 71 + in 72 72 + String.sub token 0 5 ^ "-" ^ String.sub token 5 5 73 73 + 74 74 + let send_email_or_log ~(recipients : Letters.recipient list) ~subject 75 75 + ~(body : Letters.body) = 76 76 + let log_email () = 77 77 + match body with 78 78 + | Plain text | Html text | Mixed (text, _, _) -> 79 79 + let to_addr = 80 80 + List.find_map 81 81 + (fun (r : Letters.recipient) -> 82 82 + match r with To addr -> Some addr | _ -> None ) 83 83 + recipients 84 84 + |> Option.get 85 85 + in 86 86 + Log.info (fun log -> log "email to %s: %s" to_addr text) 87 87 + in 88 88 + match (Env.smtp_config, Env.smtp_sender) with 89 89 + | Some config, Some sender -> ( 90 90 + match Letters.create_email ~from:sender ~recipients ~subject ~body () with 91 91 + | Error e -> 92 92 + failwith (Printf.sprintf "failed to construct email: %s" e) 93 93 + | Ok message -> ( 94 94 + try%lwt Letters.send ~config ~sender ~recipients ~message 95 95 + with e -> 96 96 + Log.log_exn e ; 97 97 + Lwt.return (log_email ()) ) ) 98 98 + | _ -> 99 99 + Lwt.return (log_email ()) 100 100 + 101 101 + let s3_error_to_string : Aws_s3_lwt.S3.error -> string = function 102 102 + | Redirect endpoint -> 103 103 + "redirect to " ^ endpoint.host 104 104 + | Throttled -> 105 105 + "throttled" 106 106 + | Unknown (code, msg) -> 107 107 + Printf.sprintf "unknown error %d: %s" code msg 108 108 + | Failed exn -> 109 109 + Printf.sprintf "failed: %s" (Printexc.to_string exn) 110 110 + | Forbidden -> 111 111 + "forbidden" 112 112 + | Not_found -> 113 113 + "not found"

+3 -3

pegasus/lib/xrpc.ml

··· 276 276 let signing_key = Kleidos.parse_multikey_str signing_multikey in 277 277 let jwt = Jwt.generate_service_jwt ~did ~aud ~lxm ~signing_key in 278 278 let path, _ = Dream.split_target (Dream.target ctx.req) in 279 279 - let query = Util.copy_query ctx.req in 279 279 + let query = Util.Http.copy_query ctx.req in 280 280 let uri = Uri.make ~scheme ~host ~path ~query () in 281 281 let headers = 282 282 - Util.make_headers 282 282 + Util.Http.make_headers 283 283 [ ("accept-language", Dream.header ctx.req "accept-language") 284 284 ; ("content-type", Dream.header ctx.req "content-type") 285 285 ; ( "atproto-accept-labelers" ··· 291 291 Lwt_unix.with_timeout 30.0 (fun () -> 292 292 match Dream.method_ ctx.req with 293 293 | `GET -> 294 294 - Util.http_get uri ~headers ~no_drain:true 294 294 + Util.Http.get uri ~headers ~no_drain:true 295 295 | `POST -> 296 296 let%lwt req_body = Dream.body ctx.req in 297 297 Client.post uri ~headers ~body:(Body.of_string req_body)

+3 -3

pegasus/test/test_scopes.ml

··· 5 5 6 6 let test_nsid_authority () = 7 7 check test_string "three segments" "com.example" 8 8 - (Pegasus.Util.nsid_authority "com.example.foo") ; 8 8 + (Pegasus.Util.Syntax.nsid_authority "com.example.foo") ; 9 9 check test_string "four segments" "com.example.app" 10 10 - (Pegasus.Util.nsid_authority "com.example.app.auth") ; 10 10 + (Pegasus.Util.Syntax.nsid_authority "com.example.app.auth") ; 11 11 check test_string "two segments" "com" 12 12 - (Pegasus.Util.nsid_authority "com.example") 12 12 + (Pegasus.Util.Syntax.nsid_authority "com.example") 13 13 14 14 let test_is_parent_authority () = 15 15 check bool "same authority" true

+3 -3

pegasus/test/test_sequencer.ml

··· 24 24 let with_db (f : Data_store.t -> unit Lwt.t) : unit Lwt.t = 25 25 let tmp = Filename.temp_file "pegasus_sequencer_test" ".db" in 26 26 let%lwt pool = 27 27 - Util.connect_sqlite ~create:true ~write:true 27 27 + Util.Sqlite.connect ~create:true ~write:true 28 28 (Uri.of_string ("sqlite3://" ^ tmp)) 29 29 in 30 30 let%lwt () = Migrations.run_migrations Data_store pool in ··· 79 79 with_db (fun conn -> 80 80 let did = "did:example:bob" in 81 81 (* add 3 identity events to db without publishing to bus *) 82 82 - let time0 = Util.now_ms () in 82 82 + let time0 = Util.Time.now_ms () in 83 83 let mk_raw did = 84 84 let evt : Sequencer.Types.identity_evt = {did; handle= None} in 85 85 Dag_cbor.encode_yojson @@ Sequencer.Encode.format_identity evt ··· 136 136 let test_gap_healing () = 137 137 with_db (fun conn -> 138 138 let did = "did:example:carol" in 139 139 - let time0 = Util.now_ms () in 139 139 + let time0 = Util.Time.now_ms () in 140 140 (* add 2 identity events to db without publishing *) 141 141 let mk_raw did = 142 142 let evt : Sequencer.Types.identity_evt = {did; handle= None} in