diff --git a/pool/app/pool_context/pool_context.ml b/pool/app/pool_context/pool_context.ml index 7b927bee4..fb46232dd 100644 --- a/pool/app/pool_context/pool_context.ml +++ b/pool/app/pool_context/pool_context.ml @@ -12,6 +12,12 @@ let get_admin_user = function | Admin admin -> Ok admin ;; +let get_user_id : user -> Pool_common.Id.t option = function + | Guest -> None + | Admin admin -> Admin.(id admin |> Id.to_common |> CCOption.return) + | Contact contact -> Contact.(id contact |> CCOption.return) +;; + module Utils = struct let find_authorizable_opt ?(admin_only = false) database_label user = let open Utils.Lwt_result.Infix in diff --git a/pool/app/pool_context/pool_context.mli b/pool/app/pool_context/pool_context.mli index 2be16ae39..11842e192 100644 --- a/pool/app/pool_context/pool_context.mli +++ b/pool/app/pool_context/pool_context.mli @@ -70,6 +70,7 @@ val sexp_of_t : t -> Sexplib.Sexp.t val is_from_root : t -> bool val user_is_admin : user -> bool val get_admin_user : user -> (Admin.t, Pool_common.Message.error) result +val get_user_id : user -> Pool_common.Id.t option module Utils : sig val find_authorizable_opt diff --git a/pool/app/query/query.ml b/pool/app/query/query.ml index 975414d89..a87615a07 100644 --- a/pool/app/query/query.ml +++ b/pool/app/query/query.ml @@ -1,6 +1,25 @@ include Entity +module Cache = struct + open Hashtbl + + (* TODO: How to determine when to clear the cache? Add param to reset button? + Clear after some time without reading? *) + type key = Pool_common.Id.t * string [@@deriving show] + + let tbl : (key, Entity.t) t = create 50 + let find = find_opt tbl + let add = add tbl + let clear = remove tbl + + let should_reset req = + Sihl.Web.Request.query "reset" req + |> CCOption.map_or ~default:false Utils.Bool.of_string + ;; +end + let from_request + ?(cached_key : Cache.key option) ?(filterable_by : Filter.human option) ?(searchable_by : Column.t list option) ?(sortable_by : Column.t list option) @@ -38,12 +57,9 @@ let from_request | [] -> None | conditions -> Some conditions in - let pagination = - let open Pagination in - let limit = find Limit.field >>= CCInt.of_string in - let page = find Page.field >>= CCInt.of_string in - create ?limit ?page () - in + let limit = find Pagination.Limit.field >>= CCInt.of_string in + let page = find Pagination.Page.field >>= CCInt.of_string in + let pagination () = Pagination.create ?limit ?page () in let search = let open Search in searchable_by @@ -64,7 +80,25 @@ let from_request >>= fun columns -> find Field.Order >|= Field.read >>= Sort.create ?order columns in - create ~pagination ?filter ?search ?sort () |> apply_default ~default + let anything_set = + match filter, limit, page, search, sort with + | None, None, None, None, None -> false + | _ -> true + in + let from_request = create ~pagination:(pagination ()) ?filter ?search ?sort in + apply_default ~default + @@ + match anything_set with + | true -> + let query = from_request () in + let () = cached_key |> map_or ~default:() (CCFun.flip Cache.add query) in + query + | false -> + (match Cache.should_reset req with + | false -> cached_key >>= Cache.find |> value ~default:(from_request ()) + | true -> + let () = cached_key |> map_or ~default:() Cache.clear in + from_request ()) ;; let empty () = create () diff --git a/pool/app/query/query.mli b/pool/app/query/query.mli index 0124ad731..8e81feb86 100644 --- a/pool/app/query/query.mli +++ b/pool/app/query/query.mli @@ -144,6 +144,15 @@ val to_uri_query val with_sort_order : Sort.SortOrder.t -> t -> t val with_sort_column : Column.t -> t -> t +module Cache : sig + type key = Pool_common.Id.t * string + + val show_key : key -> string + val find : key -> t option + val add : key -> t -> unit + val clear : key -> unit +end + val create : ?filter:Filter.t -> ?pagination:Pagination.t @@ -153,7 +162,8 @@ val create -> t val from_request - : ?filterable_by:Filter.human + : ?cached_key:Cache.key + -> ?filterable_by:Filter.human -> ?searchable_by:Column.t list -> ?sortable_by:Column.t list -> ?default:t diff --git a/pool/web/handler/admin_experiments.ml b/pool/web/handler/admin_experiments.ml index 66b937dac..7b354680b 100644 --- a/pool/web/handler/admin_experiments.ml +++ b/pool/web/handler/admin_experiments.ml @@ -106,15 +106,15 @@ let index req = HttpUtils.Htmx.handler ~active_navigation:"/admin/experiments" ~error_path:"/admin/experiments" + ~query_cache_key:"experiment-index" ~create_layout ~query:(module Experiment) req @@ fun ({ Pool_context.database_label; user; _ } as context) query -> let open Utils.Lwt_result.Infix in - let find_actor = + let* actor = Pool_context.Utils.find_authorizable ~admin_only:true database_label user in - let* actor = find_actor in let%lwt experiments, query = Experiment.find_all ~query diff --git a/pool/web/utils/http_utils.ml b/pool/web/utils/http_utils.ml index 8e9718a4a..4bbdc1720 100644 --- a/pool/web/utils/http_utils.ml +++ b/pool/web/utils/http_utils.ml @@ -409,7 +409,7 @@ module Htmx = struct ;; let handler - : ?active_navigation:string -> error_path:string + : ?active_navigation:string -> error_path:string -> ?query_cache_key:string -> query:(module Queryable) -> create_layout: (Rock.Request.t @@ -425,12 +425,23 @@ module Htmx = struct -> ('page Tyxml_html.elt, Pool_common.Message.error) Lwt_result.t) -> Rock.Response.t Lwt.t = - fun ?active_navigation ~error_path ~query:(module Q) ~create_layout req run -> + fun ?active_navigation + ~error_path + ?query_cache_key + ~query:(module Q) + ~create_layout + req + run -> let open Utils.Lwt_result.Infix in extract_happy_path ~src req - @@ fun context -> + @@ fun ({ Pool_context.user; _ } as context) -> + let cached_key = + let user_id = user |> Pool_context.get_user_id in + CCOption.( and* ) user_id query_cache_key + in let query = Query.from_request + ?cached_key ?filterable_by:Q.filterable_by ~searchable_by:Q.searchable_by ~sortable_by:Q.sortable_by diff --git a/pool/web/view/component/data_table.ml b/pool/web/view/component/data_table.ml index 5db1c7942..33584542d 100644 --- a/pool/web/view/component/data_table.ml +++ b/pool/web/view/component/data_table.ml @@ -339,7 +339,10 @@ let resetbar language = div ~a:[ a_class [ "flexrow"; "justify-end"; "filter-bar-reset" ] ] [ a - ~a:[ a_class [ "has-icon"; "undecorated"; "color-dark" ]; a_href "?" ] + ~a: + [ a_class [ "has-icon"; "undecorated"; "color-dark" ] + ; a_href "?reset=true" + ] [ Component_icon.(to_html RefreshOutline) ; txt (Utils.control_to_string