From f757960182cea835dfd58e41776e4967b4e50491 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Sat, 17 Feb 2024 12:21:00 +0100 Subject: [PATCH] virtual-list: batch queries and fix reactivity issues --- bin/db_worker/db_worker.ml | 57 +++++++++++++++++++++++++++---------- bin/player.ml | 22 +++++++++------ bin/ui_playlist.ml | 58 +++++++++++++++++++++++--------------- lib/db/db_worker_api.ml | 2 +- 4 files changed, 92 insertions(+), 47 deletions(-) diff --git a/bin/db_worker/db_worker.ml b/bin/db_worker/db_worker.ml index 3d3601f..ddab1ad 100644 --- a/bin/db_worker/db_worker.ml +++ b/bin/db_worker/db_worker.ml @@ -7,6 +7,21 @@ module IS = Db.Item_store let () = Random.self_init () +let map_error f = + let open Fut.Syntax in + let+ f = f in + Result.map_err (fun jv -> `Jv jv) f + +let as_fut q = IDB.Request.fut q |> map_error + +let fut_of_array (fs : 'a Fut.t array) : 'a array Fut.t = + let fut p = Jv.obj [| ("fut", p) |] in + let promise' f = Jv.get (Jv.repr f) "fut" in + let arr = Jv.of_array promise' fs in + let all = Jv.Promise.all arr in + let to_array l = Jv.Promise.resolve (Jv.to_array Obj.magic l) in + Obj.magic @@ fut @@ Jv.Promise.bind all to_array + module Worker () = struct let check_db idb source = let server_id, source = source in @@ -39,6 +54,7 @@ module Worker () = struct let open Fut.Result_syntax in try Fut.ok @@ Hashtbl.find view_memo src_views with Not_found -> + Console.debug [ "View not found" ]; let f = Performance.now_ms G.performance in let idx = IS.index (module IS.Index.Kind_View) store in let+ all_keys = @@ -48,7 +64,7 @@ module Worker () = struct IDB.Key_range.bound ~lower ~upper ~lower_open:true ~upper_open:false () in - IS.Index.Kind_View.get_all_keys ~query idx |> IDB.Request.fut + IS.Index.Kind_View.get_all_keys ~query idx |> as_fut in let keys = match src_views with @@ -72,7 +88,7 @@ module Worker () = struct Result.map_err (fun jv -> `Jv jv) res | Get_all () -> let* store = read_only_store () in - let+ req = Db.I.get_all store |> IDB.Request.fut in + let+ req = Db.I.get_all store |> as_fut in Array.map ~f:(fun i -> i.Db.Stores.Items.item) req |> Array.to_list | Get_libraries () -> let* store = read_only_store () in @@ -83,13 +99,10 @@ module Worker () = struct IDB.Key_range.bound ~lower ~upper ~lower_open:true ~upper_open:false () in - let* keys = - IS.Index.Type_Name.get_all_keys ~query index |> IDB.Request.fut - in + let* keys = IS.Index.Type_Name.get_all_keys ~query index |> as_fut in let open Fut.Syntax in let+ items = - List.map (Array.to_list keys) ~f:(fun k -> - IS.get k store |> IDB.Request.fut) + List.map (Array.to_list keys) ~f:(fun k -> IS.get k store |> as_fut) |> Fut.of_list in let items = @@ -105,18 +118,32 @@ module Worker () = struct let item_count = Array.length keys in let order = Db.View.Order.of_sort ~size:item_count request.sort in { Db.View.uuid; request; order; start_offset = 0; item_count } - | Get (view, index) -> ( + | Get (view, indexes) -> (* This request is critical to virtual lists performances and should be as fast as possible. *) - let index = index + view.start_offset in - let index = Db.View.Order.apply view.order index in let* store = read_only_store () in let* keys = get_view_keys store view.request in - let key = keys.(index) in - let* res = IS.get key store |> IDB.Request.fut in - match res with - | Some res -> Fut.ok res - | None -> Fut.return (Error (`Msg "Item not found"))) + let open Fut.Syntax in + let+ results = + Array.map indexes ~f:(fun index -> + try + let index = index + view.start_offset in + let index = Db.View.Order.apply view.order index in + (* This could be optimize when access is sequential *) + let key = keys.(index) in + let open Fut.Syntax in + let+ result = IS.get key store |> IDB.Request.fut in + match result with + | Ok None -> None + | Error err -> + Console.error + [ "An error occured while loading item"; key; err ]; + None + | Ok (Some v) -> Some v + with _ -> Fut.return None) + |> fut_of_array + in + Ok results end include Make_worker (Worker) diff --git a/bin/player.ml b/bin/player.ml index 883bd45..ceb100e 100644 --- a/bin/player.ml +++ b/bin/player.ml @@ -33,7 +33,9 @@ let audio_url (server : DS.connexion) item_id = module Playback_controller (P : sig val fetch : - Db.View.t -> int -> (Db.Stores.Items.t, Db.Worker_api.error) Fut.result + Db.View.t -> + int array -> + (Db.Stores.Items.t option array, Db.Worker_api.error) Fut.result end) = struct let set_play_url playlist current_index = @@ -42,14 +44,16 @@ struct | Some playlist -> let open Fut.Result_syntax in let+ item = - let+ { Db.Stores.Items.item = { server_id; id; name; _ }; _ } = - P.fetch playlist current_index - in - let servers = Lwd_seq.to_list (Lwd.peek Servers.var) in - let server : Servers.server = List.assq server_id servers in - let url = audio_url server.connexion id in - let () = Console.log [ "Now playing:"; name; Jv.of_string url ] in - { item_id = id; url } + let+ result = P.fetch playlist [| current_index |] in + match result with + | [| Some { Db.Stores.Items.item = { server_id; id; name; _ }; _ } |] + -> + let servers = Lwd_seq.to_list (Lwd.peek Servers.var) in + let server : Servers.server = List.assq server_id servers in + let url = audio_url server.connexion id in + let () = Console.log [ "Now playing:"; name; Jv.of_string url ] in + { item_id = id; url } + | _ -> raise Not_found in Lwd.set now_playing (Some item) diff --git a/bin/ui_playlist.ml b/bin/ui_playlist.ml index 689902d..68c2fc9 100644 --- a/bin/ui_playlist.ml +++ b/bin/ui_playlist.ml @@ -41,6 +41,11 @@ module Uniqueue (O : Set.OrderedType) = struct i let length t = Queue.length t.queue + + let clear t = + let new_queue = create () in + t.queue <- new_queue.queue; + t.uniq <- new_queue.uniq end module Int_uniqueue = Uniqueue (Int) @@ -53,7 +58,7 @@ type 'a row_data = { type ('data, 'error) data_source = { total_items : (int, 'error) Fut.result; - fetch : int -> ('data, 'error) Fut.result; + fetch : int array -> ('data option array, 'error) Fut.result; render : int -> 'data -> Elwd.t Elwd.col; } @@ -73,7 +78,7 @@ let lazy_table (type data) ~(ui_table : Table.fixed_row_height) let row_index = Hashtbl.create 2048 in let unload_queue = Int_uniqueue.create () in - let add ~fetch ?(max_items = 200) i = + let add ~fetch ?(max_items = 200) indexes = let unload i = let open Option.Infix in (let* row = Hashtbl.get row_index i in @@ -81,13 +86,18 @@ let lazy_table (type data) ~(ui_table : Table.fixed_row_height) Lwd_table.set row { row_data with content = None }) |> ignore in - let load i = - let open Option.Infix in - (let* row = Hashtbl.get row_index i in - let+ row_data = Lwd_table.get row in - let open Fut.Result_syntax in - let+ data = fetch row_data.index in - Lwd_table.set row { row_data with content = Some data }) + let load indexes = + (let open Fut.Result_syntax in + let+ (data : data option array) = fetch indexes in + Array.iter2 indexes data ~f:(fun i data -> + (let open Option.Infix in + let* row = Hashtbl.get row_index i in + let+ row_data = Lwd_table.get row in + let data = + match data with Some data -> data | _ -> raise Not_found + in + Lwd_table.set row { row_data with content = Some data }) + |> ignore)) |> ignore in let cleanup () = @@ -98,9 +108,11 @@ let lazy_table (type data) ~(ui_table : Table.fixed_row_height) unload index done in - if Int_uniqueue.add i unload_queue then ( - load i; - cleanup ()) + let to_load = + List.filter indexes ~f:(fun i -> Int_uniqueue.add i unload_queue) + in + load (Array.of_list to_load); + cleanup () in let num_rows = Lwd.var 0 in @@ -128,7 +140,7 @@ let lazy_table (type data) ~(ui_table : Table.fixed_row_height) let number_of_visible_rows = total_height /. row_height |> int_of_float in - let bleeding = number_of_visible_rows / 2 in + let bleeding = number_of_visible_rows in let scroll_y = scroll_y -. float_of_int header_height in let first_visible_row = int_of_float (scroll_y /. row_height) + 1 in let last_visible_row = first_visible_row + number_of_visible_rows in @@ -144,11 +156,10 @@ let lazy_table (type data) ~(ui_table : Table.fixed_row_height) in last_visible_row + bleeding |> min num_rows in - for i = first to last do - (* todo: We do way too much work and rebuild the queue each - time... it's very ineficient *) - add ~max_items:(4 * number_of_visible_rows) i - done + (* todo: We do way too much work and rebuild the queue each + time... it's very ineficient *) + let indexes = List.init (last - first) ~f:(fun i -> first + i) in + add ~max_items:(4 * number_of_visible_rows) indexes in let last_update = ref 0. in let timeout = ref (-1) in @@ -169,15 +180,18 @@ let lazy_table (type data) ~(ui_table : Table.fixed_row_height) in let _ = let open Fut.Result_syntax in + let () = Int_uniqueue.clear unload_queue in let+ total = total_items in if not (Lwd.peek num_rows = total) then Lwd.set num_rows total; + Lwd_table.clear table; for i = 0 to total - 1 do - let _uuid = new_uuid_v4 () |> Uuidm.to_string in let set = { index = i; content = None; render } in - Hashtbl.add row_index i @@ Lwd_table.append ~set table; - if i < 20 then add i (* preload the first items *) - done + Hashtbl.add row_index i @@ Lwd_table.append ~set table + done; + (* preload the first items *) + add (List.init 100 ~f:Fun.id) in + Elwd.handler Ev.scroll (fun ev -> let div = Ev.target ev |> Ev.target_to_jv |> El.of_jv in scroll_handler div)) diff --git a/lib/db/db_worker_api.ml b/lib/db/db_worker_api.ml index c25fbf2..ad7f9a0 100644 --- a/lib/db/db_worker_api.ml +++ b/lib/db/db_worker_api.ml @@ -10,7 +10,7 @@ module Queries = struct | Get_all : unit -> Api.Item.t list query | Get_libraries : unit -> Stores.Items.t list query | Create_view : View.req -> View.t query - | Get : View.t * int -> Stores.Items.t query + | Get : View.t * int array -> Stores.Items.t option array query type 'a event = Servers_status_update : (string * Sync.report) event end