Cache db pools, run pragma statements in separate queries

futurGH · futurGH · commit c11a3dfd67c1 · 2025-12-26T12:36:40.000-05:00
diff --git a/pegasus/lib/api/admin_/users.ml b/pegasus/lib/api/admin_/users.ml
@@ -183,7 +183,7 @@ let post_handler =
                                     ~perm:0o644
                                 in
                                 let%lwt repo =
-                                  Repository.load ~write:true ~create:true
+                                  Repository.load ~create:true
                                     ~ds:ctx.db new_did
                                 in
                                 let%lwt _ =
diff --git a/pegasus/lib/api/repo/describeRepo.ml b/pegasus/lib/api/repo/describeRepo.ml
@@ -25,7 +25,7 @@ let handler =
           "at://%s"
           (fun h -> h)
       in
-      let%lwt repo = Repository.load ~write:false did in
+      let%lwt repo = Repository.load did in
       let%lwt collections = Repository.list_collections repo in
       Dream.json @@ Yojson.Safe.to_string
       @@ response_to_yojson
diff --git a/pegasus/lib/api/repo/importRepo.ml b/pegasus/lib/api/repo/importRepo.ml
@@ -13,9 +13,7 @@ let handler =
       let did = Auth.get_authed_did_exn ctx.auth in
       let bytes_stream = Dream.body_stream ctx.req in
       let car_stream = stream_to_seq bytes_stream in
-      let%lwt repo =
-        Repository.load did ~ds:ctx.db ~ensure_active:true ~write:true
-      in
+      let%lwt repo = Repository.load did ~ds:ctx.db ~ensure_active:true in
       let%lwt result = Repository.import_car repo car_stream in
       match result with
       | Ok _ ->
diff --git a/pegasus/lib/api/server/checkAccountStatus.ml b/pegasus/lib/api/server/checkAccountStatus.ml
@@ -18,7 +18,7 @@ let handler =
           Errors.internal_error ~msg:"actor not found" ()
       | Some actor -> (
           let%lwt {db= us; commit; _} =
-            Repository.load ~write:false ~ds:db did
+            Repository.load ~ds:db did
           in
           let%lwt cid, commit =
             match commit with
diff --git a/pegasus/lib/api/server/createAccount.ml b/pegasus/lib/api/server/createAccount.ml
@@ -120,7 +120,7 @@ let create_account ~email ~handle ~password ?invite_code ?did ?recovery_key db =
                       ~perm:0o644
                   in
                   let%lwt repo =
-                    Repository.load ~write:true ~create:true ~ds:db did
+                    Repository.load ~create:true ~ds:db did
                   in
                   let%lwt _ = Repository.put_initial_commit repo in
                   let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in
diff --git a/pegasus/lib/api/sync/getBlob.ml b/pegasus/lib/api/sync/getBlob.ml
@@ -5,7 +5,7 @@ let handler =
       let {did; cid} = Xrpc.parse_query ctx.req query_of_yojson in
       let cid_parsed = Cid.as_cid cid in
       let%lwt {db; _} =
-        Repository.load did ~ensure_active:true ~write:false ~ds:ctx.db
+        Repository.load did ~ensure_active:true ~ds:ctx.db
       in
       let%lwt blob_meta = User_store.get_blob_metadata db cid_parsed in
       match blob_meta with
diff --git a/pegasus/lib/api/sync/getBlocks.ml b/pegasus/lib/api/sync/getBlocks.ml
@@ -5,7 +5,7 @@ let handler =
   Xrpc.handler (fun ctx ->
       let {did; cids} : query = Xrpc.parse_query ctx.req query_of_yojson in
       let%lwt {db; commit; _} =
-        Repository.load did ~ensure_active:true ~write:false ~ds:ctx.db
+        Repository.load did ~ensure_active:true ~ds:ctx.db
       in
       let commit_cid, commit_signed = Option.get commit in
       let commit_block =
diff --git a/pegasus/lib/api/sync/getLatestCommit.ml b/pegasus/lib/api/sync/getLatestCommit.ml
@@ -6,7 +6,7 @@ let handler =
   Xrpc.handler (fun ctx ->
       let {did} : query = Xrpc.parse_query ctx.req query_of_yojson in
       match%lwt
-        Repository.load did ~ensure_active:true ~write:false ~ds:ctx.db
+        Repository.load did ~ensure_active:true ~ds:ctx.db
       with
       | {commit= Some (cid, {rev; _}); _} ->
           let cid = Cid.to_string cid in
diff --git a/pegasus/lib/api/sync/getRecord.ml b/pegasus/lib/api/sync/getRecord.ml
@@ -10,7 +10,7 @@ let handler =
       in
       let path = collection ^ "/" ^ rkey in
       let%lwt repo =
-        Repository.load did ~ensure_active:true ~write:false ~ds:ctx.db
+        Repository.load did ~ensure_active:true ~ds:ctx.db
       in
       match%lwt Repository.get_record repo path with
       | None ->
diff --git a/pegasus/lib/api/sync/getRepo.ml b/pegasus/lib/api/sync/getRepo.ml
@@ -3,7 +3,7 @@ type query = {did: string} [@@deriving yojson {strict= false}]
 let handler =
   Xrpc.handler (fun ctx ->
       let {did} : query = Xrpc.parse_query ctx.req query_of_yojson in
-      let%lwt repo = Repository.load did ~ensure_active:true ~write:false in
+      let%lwt repo = Repository.load did ~ensure_active:true in
       let%lwt car_stream = Repository.export_car repo in
       Dream.stream
         ~headers:[("Content-Type", "application/vnd.ipld.car")]
diff --git a/pegasus/lib/api/sync/getRepoStatus.ml b/pegasus/lib/api/sync/getRepoStatus.ml
@@ -15,7 +15,7 @@ let handler =
             Errors.invalid_request ~name:"RepoNotFound"
               "couldn't find a repo with that did"
       in
-      let%lwt {db= user_db; _} = Repository.load did ~write:false ~ds:ctx.db in
+      let%lwt {db= user_db; _} = Repository.load did ~ds:ctx.db in
       let%lwt _, commit =
         match%lwt User_store.get_commit user_db with
         | Some c ->
diff --git a/pegasus/lib/api/sync/listBlobs.ml b/pegasus/lib/api/sync/listBlobs.ml
@@ -22,7 +22,7 @@ let handler =
             1000
       in
       let%lwt {db; _} =
-        Repository.load did ~ensure_active:true ~write:false ~ds:ctx.db
+        Repository.load did ~ensure_active:true ~ds:ctx.db
       in
       let%lwt cids = User_store.list_blobs db ~limit ~cursor ?since in
       let cids = List.map Cid.to_string cids in
diff --git a/pegasus/lib/data_store.ml b/pegasus/lib/data_store.ml
@@ -318,14 +318,25 @@ end
 
 type t = Util.caqti_pool
 
-let connect ?create ?write () : t Lwt.t =
-  if create = Some true then
-    Util.mkfile_p Util.Constants.pegasus_db_filepath ~perm:0o644 ;
-  let%lwt db =
-    Util.connect_sqlite ?create ?write Util.Constants.pegasus_db_location
-  in
-  let%lwt () = Migrations.run_migrations Data_store db in
-  Lwt.return db
+let pool : t option ref = ref None
+
+let pool_mutex = Lwt_mutex.create ()
+
+let connect ?create () : t Lwt.t =
+  Lwt_mutex.with_lock pool_mutex (fun () ->
+      match !pool with
+      | Some pool ->
+          Lwt.return pool
+      | None ->
+          if create = Some true then
+            Util.mkfile_p Util.Constants.pegasus_db_filepath ~perm:0o644 ;
+          let%lwt db =
+            Util.connect_sqlite ?create ~write:true
+              Util.Constants.pegasus_db_location
+          in
+          let%lwt () = Migrations.run_migrations Data_store db in
+          pool := Some db ;
+          Lwt.return db )
 
 let create_actor ~did ~handle ~email ~password ~signing_key conn =
   let password_hash = Bcrypt.hash password |> Bcrypt.string_of_hash in
diff --git a/pegasus/lib/repository.ml b/pegasus/lib/repository.ml
diff --git a/pegasus/lib/user_store.ml b/pegasus/lib/user_store.ml
diff --git a/pegasus/lib/util.ml b/pegasus/lib/util.ml
