From 011257ac22aa44b34b71e35480cd0d2014da1ddb Mon Sep 17 00:00:00 2001 From: Malcolm Date: Wed, 20 Nov 2024 22:01:28 +0100 Subject: [PATCH] PRO-614 REFACTOR Make Abb_cache testable anda dd tests --- code/Makefile | 2 + code/pds.conf | 31 +- code/src/abb_cache/abb_cache.ml | 426 ++++++++++---------- code/src/abb_cache/abb_cache.mli | 142 +++---- code/src/abbs/abbs_cache.ml | 1 + code/src/terrat/terrat_evaluator3.ml | 16 +- code/src/terrat/terrat_github_evaluator3.ml | 16 +- code/tests/abb_cache/test.ml | 317 +++++++++++++++ 8 files changed, 651 insertions(+), 300 deletions(-) create mode 100644 code/src/abbs/abbs_cache.ml create mode 100644 code/tests/abb_cache/test.ml diff --git a/code/Makefile b/code/Makefile index 84c8a1a4..b2a9bdea 100644 --- a/code/Makefile +++ b/code/Makefile @@ -25,6 +25,8 @@ terrat: test-release_terrat test-release_terrat_github_webhooks terrat: test-release_jsonu +terrat: test-release_abb_cache + terrat: release_terrat_code_indexer debug_terrat_code_indexer terrat-api: release_openapi_cli diff --git a/code/pds.conf b/code/pds.conf index df1f0368..e8ebafd6 100644 --- a/code/pds.conf +++ b/code/pds.conf @@ -269,7 +269,14 @@ deps = [ "abb_fut", "abb_intf", "abb_thread_pool", "containers", "iter", "mtime. [src.abb_cache] install = true -deps = [ "abb", "abb_future_combinators", "containers", "duration", "lru",] +deps = [ + "abb", + "abb_future_combinators", + "abb_intf", + "containers", + "duration", + "lru", +] [src.jwk] install = true @@ -573,7 +580,19 @@ deps = [ "cmdliner", "containers", "process", "toml", "snabela",] [src.abbs] install = true -deps = [ "abb", "abb_channel", "abb_channel_queue", "abb_future_combinators", "abb_happy_eyeballs", "abb_io", "abb_service_local", "abb_service_serializer", "abb_tcp_server", "abb_time",] +deps = [ + "abb", + "abb_cache", + "abb_channel", + "abb_channel_queue", + "abb_future_combinators", + "abb_happy_eyeballs", + "abb_io", + "abb_service_local", + "abb_service_serializer", + "abb_tcp_server", + "abb_time", +] [src.opentofu_mods_cli] install = false @@ -732,3 +751,11 @@ deps = [ "abb_intf", "abb_test", "abb_scheduler_kqueue",] [src.kqueue.selector.linux.debug] meta_linkopts = "-cclib -lkqueue" extra_compiler_opts = "-g -strict-sequence -strict-formats -safe-string -w '@d@f@p@u@s@40' -ccopt -I/usr/include/kqueue" + +[tests.abb_cache] +deps = [ + "abb_cache", + "abb_scheduler_select", + "containers", + "oth_abb", +] diff --git a/code/src/abb_cache/abb_cache.ml b/code/src/abb_cache/abb_cache.ml index 7e6217f5..36ff0522 100644 --- a/code/src/abb_cache/abb_cache.ml +++ b/code/src/abb_cache/abb_cache.ml @@ -1,229 +1,231 @@ -module Fut_comb = Abb_future_combinators.Make (Abb.Future) - -module type S = sig - type k - type args - type v - type err - - val fetch : args -> (v, err) result Abb.Future.t - val equal_k : k -> k -> bool - val weight : v -> int -end - -module type SRC = sig - type opts - type t - type k - type args - type v - type err - - val create : opts -> t - val fetch : t -> k -> args -> (v, err) result Abb.Future.t -end - -module Passthrough = struct - module Make (M : S) = struct - type opts = unit - type t = unit - type k = M.k - type args = M.args - type v = M.v - type err = M.err - - let create () = () - let fetch () _ = M.fetch +module Make (Abb : Abb_intf.S) = struct + module Fut_comb = Abb_future_combinators.Make (Abb.Future) + + module type S = sig + type k + type args + type v + type err + + val fetch : args -> (v, err) result Abb.Future.t + val equal_k : k -> k -> bool + val weight : v -> int end -end - -module Memo = struct - type opts = { - on_hit : unit -> unit; - on_miss : unit -> unit; - } - module Make (M : S) = struct - type nonrec opts = opts + module type SRC = sig + type opts + type t + type k + type args + type v + type err - type t = { - opts : opts; - cache : (M.k, (M.v, M.err) result Abb.Future.t) Hashtbl.t; - } - - type k = M.k - type args = M.args - type v = M.v - type err = M.err - - let create opts = { opts; cache = Hashtbl.create 10 } - - let fetch t k args = - match CCHashtbl.get t.cache k with - | Some v -> - t.opts.on_hit (); - v - | None -> - let open Abb.Future.Infix_monad in - t.opts.on_miss (); - let ret = - Fut_comb.guard (fun () -> - M.fetch args - >>= function - | Ok _ as r -> Abb.Future.return r - | Error _ as err -> - Hashtbl.remove t.cache k; - Abb.Future.return err) - in - Hashtbl.replace t.cache k ret; - Abb.Future.fork ret >>= fun _ -> ret + val create : opts -> t + val fetch : t -> k -> args -> (v, err) result Abb.Future.t end -end -module Lru = struct - type opts = { - on_hit : unit -> unit; - on_miss : unit -> unit; - capacity : int; - } - - module Make (M : S) = struct - module Lru_k = struct - type t = M.k - - let equal = M.equal_k - let hash = Hashtbl.hash - end - - module Lru_v = struct - type t = (M.v, M.err) result Abb.Future.t - - let weight v = - match Abb.Future.state v with - | `Det (Ok v) -> - let weight = M.weight v in - assert (weight >= 0); - CCInt.max 1 weight - | `Undet -> 1 - | `Det (Error _) | `Aborted | `Exn _ -> - (* All errors are 1, but errors are removed immediately so this is - really more of a dummy value. *) - 1 + module Passthrough = struct + module Make (M : S) = struct + type opts = unit + type t = unit + type k = M.k + type args = M.args + type v = M.v + type err = M.err + + let create () = () + let fetch () _ = M.fetch end + end - module Lru = Lru.M.Make (Lru_k) (Lru_v) + module Memo = struct + type opts = { + on_hit : unit -> unit; + on_miss : unit -> unit; + } - type nonrec opts = opts + module Make (M : S) = struct + type nonrec opts = opts + + type t = { + opts : opts; + cache : (M.k, (M.v, M.err) result Abb.Future.t) Hashtbl.t; + } + + type k = M.k + type args = M.args + type v = M.v + type err = M.err + + let create opts = { opts; cache = Hashtbl.create 10 } + + let fetch t k args = + match CCHashtbl.get t.cache k with + | Some v -> + t.opts.on_hit (); + v + | None -> + let open Abb.Future.Infix_monad in + t.opts.on_miss (); + let ret = + Fut_comb.guard (fun () -> + M.fetch args + >>= function + | Ok _ as r -> Abb.Future.return r + | Error _ as err -> + Hashtbl.remove t.cache k; + Abb.Future.return err) + in + Hashtbl.replace t.cache k ret; + Abb.Future.fork ret >>= fun _ -> ret + end + end - type t = { - opts : opts; - cache : Lru.t; + module Lru = struct + type opts = { + on_hit : unit -> unit; + on_miss : unit -> unit; + capacity : int; } - type k = M.k - type args = M.args - type v = M.v - type err = M.err - - let create opts = { opts; cache = Lru.create opts.capacity } - - let fetch t k args = - match Lru.find k t.cache with - | Some ret -> - t.opts.on_hit (); - Lru.promote k t.cache; - Lru.trim t.cache; - ret - | None -> - let open Abb.Future.Infix_monad in - t.opts.on_miss (); - let ret = - Fut_comb.guard (fun () -> - M.fetch args - >>= function - | Ok _ as r -> Abb.Future.return r - | Error _ as err -> - Lru.remove k t.cache; - Abb.Future.return err) - in - Lru.add k ret t.cache; - Lru.trim t.cache; - Abb.Future.fork ret >>= fun _ -> ret + module Make (M : S) = struct + module Lru_k = struct + type t = M.k + + let equal = M.equal_k + let hash = Hashtbl.hash + end + + module Lru_v = struct + type t = (M.v, M.err) result Abb.Future.t + + let weight v = + match Abb.Future.state v with + | `Det (Ok v) -> + let weight = M.weight v in + assert (weight >= 0); + CCInt.max 1 weight + | `Undet -> 1 + | `Det (Error _) | `Aborted | `Exn _ -> + (* All errors are 1, but errors are removed immediately so this is + really more of a dummy value. *) + 1 + end + + module Lru = Lru.M.Make (Lru_k) (Lru_v) + + type nonrec opts = opts + + type t = { + opts : opts; + cache : Lru.t; + } + + type k = M.k + type args = M.args + type v = M.v + type err = M.err + + let create opts = { opts; cache = Lru.create opts.capacity } + + let fetch t k args = + match Lru.find k t.cache with + | Some ret -> + t.opts.on_hit (); + Lru.promote k t.cache; + Lru.trim t.cache; + ret + | None -> + let open Abb.Future.Infix_monad in + t.opts.on_miss (); + let ret = + Fut_comb.guard (fun () -> + M.fetch args + >>= function + | Ok _ as r -> Abb.Future.return r + | Error _ as err -> + Lru.remove k t.cache; + Abb.Future.return err) + in + Lru.add k ret t.cache; + Lru.trim t.cache; + Abb.Future.fork ret >>= fun _ -> ret + end end -end -module Expiring = struct - type opts = { - on_hit : unit -> unit; - on_miss : unit -> unit; - duration : Duration.t; - capacity : int; - } - - module Make (M : S) = struct - module Expiration_index = CCMap.Make (struct - type t = float [@@deriving ord] - end) - - type nonrec opts = opts - - type t = { - opts : opts; - cache : (M.k, (M.v, M.err) result Abb.Future.t * float) Hashtbl.t; - mutable expiration_index : (M.k * int) list Expiration_index.t; - mutable load : int; + module Expiring = struct + type opts = { + on_hit : unit -> unit; + on_miss : unit -> unit; + duration : Duration.t; + capacity : int; } - type k = M.k - type args = M.args - type v = M.v - type err = M.err - - let rec evict_until_capacity t = - if t.load > t.opts.capacity then - match Expiration_index.min_binding_opt t.expiration_index with - | Some (expiration, weights) -> - t.expiration_index <- Expiration_index.remove expiration t.expiration_index; - CCList.iter - (fun (k, weight) -> - Hashtbl.remove t.cache k; - t.load <- t.load - weight) - weights; - evict_until_capacity t - | None -> () - - let create opts = - { opts; cache = Hashtbl.create 10; expiration_index = Expiration_index.empty; load = 0 } - - let fetch t k args = - let open Abb.Future.Infix_monad in - Abb.Sys.monotonic () - >>= fun now -> - evict_until_capacity t; - match CCHashtbl.get t.cache k with - | Some (v, expiration) when now < expiration -> - t.opts.on_hit (); - v - | Some _ | None -> - t.opts.on_miss (); - let ret = - Fut_comb.guard (fun () -> - M.fetch args - >>= function - | Ok v as r -> - let weight = CCInt.max 1 (M.weight v) in - t.expiration_index <- - Expiration_index.add_to_list - (now +. Duration.to_f t.opts.duration) - (k, weight) - t.expiration_index; - t.load <- t.load + weight; - Abb.Future.return r - | Error _ as err -> - Hashtbl.remove t.cache k; - Abb.Future.return err) - in - Hashtbl.replace t.cache k (ret, now +. Duration.to_f t.opts.duration); - Abb.Future.fork ret >>= fun _ -> ret + module Make (M : S) = struct + module Expiration_index = CCMap.Make (struct + type t = float [@@deriving ord] + end) + + type nonrec opts = opts + + type t = { + opts : opts; + cache : (M.k, (M.v, M.err) result Abb.Future.t * float) Hashtbl.t; + mutable expiration_index : (M.k * int) list Expiration_index.t; + mutable load : int; + } + + type k = M.k + type args = M.args + type v = M.v + type err = M.err + + let rec evict_until_capacity t = + if t.load > t.opts.capacity then + match Expiration_index.min_binding_opt t.expiration_index with + | Some (expiration, weights) -> + t.expiration_index <- Expiration_index.remove expiration t.expiration_index; + CCList.iter + (fun (k, weight) -> + Hashtbl.remove t.cache k; + t.load <- t.load - weight) + weights; + evict_until_capacity t + | None -> () + + let create opts = + { opts; cache = Hashtbl.create 10; expiration_index = Expiration_index.empty; load = 0 } + + let fetch t k args = + let open Abb.Future.Infix_monad in + Abb.Sys.monotonic () + >>= fun now -> + evict_until_capacity t; + match CCHashtbl.get t.cache k with + | Some (v, expiration) when now < expiration -> + t.opts.on_hit (); + v + | Some _ | None -> + t.opts.on_miss (); + let ret = + Fut_comb.guard (fun () -> + M.fetch args + >>= function + | Ok v as r -> + let weight = CCInt.max 1 (M.weight v) in + t.expiration_index <- + Expiration_index.add_to_list + (now +. Duration.to_f t.opts.duration) + (k, weight) + t.expiration_index; + t.load <- t.load + weight; + Abb.Future.return r + | Error _ as err -> + Hashtbl.remove t.cache k; + Abb.Future.return err) + in + Hashtbl.replace t.cache k (ret, now +. Duration.to_f t.opts.duration); + Abb.Future.fork ret >>= fun _ -> ret + end end end diff --git a/code/src/abb_cache/abb_cache.mli b/code/src/abb_cache/abb_cache.mli index ed35ed2b..ace97778 100644 --- a/code/src/abb_cache/abb_cache.mli +++ b/code/src/abb_cache/abb_cache.mli @@ -1,83 +1,85 @@ -module type S = sig - type k - type args - type v - type err +module Make (Abb : Abb_intf.S) : sig + module type S = sig + type k + type args + type v + type err - val fetch : args -> (v, err) result Abb.Future.t - val equal_k : k -> k -> bool + val fetch : args -> (v, err) result Abb.Future.t + val equal_k : k -> k -> bool - (** Given a value, return how much capacity it consumes. Must return a number + (** Given a value, return how much capacity it consumes. Must return a number greater than or equal to 0. *) - val weight : v -> int -end + val weight : v -> int + end -module type SRC = sig - type opts - type t - type k - type args - type v - type err + module type SRC = sig + type opts + type t + type k + type args + type v + type err - val create : opts -> t - val fetch : t -> k -> args -> (v, err) result Abb.Future.t -end + val create : opts -> t + val fetch : t -> k -> args -> (v, err) result Abb.Future.t + end -module Passthrough : sig - module Make (M : S) : - SRC - with type opts = unit - and type k = M.k - and type args = M.args - and type v = M.v - and type err = M.err -end + module Passthrough : sig + module Make (M : S) : + SRC + with type opts = unit + and type k = M.k + and type args = M.args + and type v = M.v + and type err = M.err + end -module Memo : sig - type opts = { - on_hit : unit -> unit; - on_miss : unit -> unit; - } + module Memo : sig + type opts = { + on_hit : unit -> unit; + on_miss : unit -> unit; + } - module Make (M : S) : - SRC - with type opts = opts - and type k = M.k - and type args = M.args - and type v = M.v - and type err = M.err -end + module Make (M : S) : + SRC + with type opts = opts + and type k = M.k + and type args = M.args + and type v = M.v + and type err = M.err + end -module Lru : sig - type opts = { - on_hit : unit -> unit; - on_miss : unit -> unit; - capacity : int; - } + module Lru : sig + type opts = { + on_hit : unit -> unit; + on_miss : unit -> unit; + capacity : int; + } - module Make (M : S) : - SRC - with type opts = opts - and type k = M.k - and type args = M.args - and type v = M.v - and type err = M.err -end + module Make (M : S) : + SRC + with type opts = opts + and type k = M.k + and type args = M.args + and type v = M.v + and type err = M.err + end -module Expiring : sig - type opts = { - on_hit : unit -> unit; - on_miss : unit -> unit; - duration : Duration.t; - capacity : int; - } + module Expiring : sig + type opts = { + on_hit : unit -> unit; + on_miss : unit -> unit; + duration : Duration.t; + capacity : int; + } - module Make (M : S) : - SRC - with type opts = opts - and type k = M.k - and type args = M.args - and type v = M.v - and type err = M.err + module Make (M : S) : + SRC + with type opts = opts + and type k = M.k + and type args = M.args + and type v = M.v + and type err = M.err + end end diff --git a/code/src/abbs/abbs_cache.ml b/code/src/abbs/abbs_cache.ml new file mode 100644 index 00000000..15bd0185 --- /dev/null +++ b/code/src/abbs/abbs_cache.ml @@ -0,0 +1 @@ +include Abb_cache.Make (Abb) diff --git a/code/src/terrat/terrat_evaluator3.ml b/code/src/terrat/terrat_evaluator3.ml index 9a84a8bf..b9a15151 100644 --- a/code/src/terrat/terrat_evaluator3.ml +++ b/code/src/terrat/terrat_evaluator3.ml @@ -1765,7 +1765,7 @@ module Make (S : S) = struct values but as the values change between resumes the values get updated. *) module Cache = struct - module Matches = Abb_cache.Lru.Make (struct + module Matches = Abbs_cache.Lru.Make (struct type k = string * S.Account.t * S.Repo.t * S.Ref.t * S.Ref.t * [ `Plan | `Apply ] [@@deriving eq] @@ -1782,7 +1782,7 @@ module Make (S : S) = struct let weight v = CCString.length (Matches.show v) end) - module Access_control_eval_tf_op = Abb_cache.Lru.Make (struct + module Access_control_eval_tf_op = Abbs_cache.Lru.Make (struct type k = string * S.Account.t @@ -1805,7 +1805,7 @@ module Make (S : S) = struct let weight v = CCString.length (Terrat_access_control.R.show v) end) - module Repo_config = Abb_cache.Lru.Make (struct + module Repo_config = Abbs_cache.Lru.Make (struct type k = string * S.Account.t * S.Repo.t * S.Ref.t [@@deriving eq] type v = string list * Terrat_base_repo_config_v1.raw Terrat_base_repo_config_v1.t type err = Repo_config.fetch_err @@ -1819,7 +1819,7 @@ module Make (S : S) = struct Terrat_base_repo_config_v1.(View.to_yojson (to_view repo_config))) end) - module Pull_request = Abb_cache.Lru.Make (struct + module Pull_request = Abbs_cache.Lru.Make (struct type k = string * S.Account.t * S.Repo.t * int [@@deriving eq] type v = S.Pull_request.fetched S.Pull_request.t type err = [ `Error ] @@ -1836,7 +1836,7 @@ module Make (S : S) = struct let matches = Matches.create { - Abb_cache.Lru.on_hit = CCFun.const (); + Abbs_cache.Lru.on_hit = CCFun.const (); on_miss = CCFun.const (); capacity = cache_capacity_mb 10; } @@ -1844,7 +1844,7 @@ module Make (S : S) = struct let access_control_eval_tf_op = Access_control_eval_tf_op.create { - Abb_cache.Lru.on_hit = CCFun.const (); + Abbs_cache.Lru.on_hit = CCFun.const (); on_miss = CCFun.const (); capacity = cache_capacity_mb 5; } @@ -1852,7 +1852,7 @@ module Make (S : S) = struct let repo_config = Repo_config.create { - Abb_cache.Lru.on_hit = CCFun.const (); + Abbs_cache.Lru.on_hit = CCFun.const (); on_miss = CCFun.const (); capacity = cache_capacity_mb 10; } @@ -1860,7 +1860,7 @@ module Make (S : S) = struct let pull_request = Pull_request.create { - Abb_cache.Lru.on_hit = CCFun.const (); + Abbs_cache.Lru.on_hit = CCFun.const (); on_miss = CCFun.const (); capacity = cache_capacity_mb 10; } diff --git a/code/src/terrat/terrat_github_evaluator3.ml b/code/src/terrat/terrat_github_evaluator3.ml index b8103598..ab9c60c3 100644 --- a/code/src/terrat/terrat_github_evaluator3.ml +++ b/code/src/terrat/terrat_github_evaluator3.ml @@ -787,7 +787,7 @@ module S = struct let on_hit fn () = Prmths.Counter.inc_one (Metrics.cache_fn_call_count ~l:"global" ~fn "hit") let on_miss fn () = Prmths.Counter.inc_one (Metrics.cache_fn_call_count ~l:"global" ~fn "miss") - module Client_cache = Abb_cache.Expiring.Make (struct + module Client_cache = Abbs_cache.Expiring.Make (struct type k = Account.t [@@deriving eq] type v = Githubc2_abb.t type err = [ `Error ] @@ -814,10 +814,10 @@ module S = struct v end - module By_rev = Abb_cache.Lru.Make (M) + module By_rev = Abbs_cache.Lru.Make (M) end - module Fetch_repo_cache = Abb_cache.Expiring.Make (struct + module Fetch_repo_cache = Abbs_cache.Expiring.Make (struct type k = Account.t * (string * string) [@@deriving eq] type v = Remote_repo.t type err = Terrat_github.fetch_repo_err @@ -840,14 +840,14 @@ module S = struct let weight v = CCList.fold_left (fun weight v -> weight + CCString.length v) 0 v end - module By_rev = Abb_cache.Lru.Make (M) + module By_rev = Abbs_cache.Lru.Make (M) end module Globals = struct let client_cache = Client_cache.create { - Abb_cache.Expiring.on_hit = on_hit "create_client"; + Abbs_cache.Expiring.on_hit = on_hit "create_client"; on_miss = on_miss "create_client"; duration = Duration.of_sec 60; capacity = 10; @@ -856,7 +856,7 @@ module S = struct let fetch_file_by_rev_cache = Fetch_file_cache.By_rev.create { - Abb_cache.Lru.on_hit = on_hit "fetch_file_by_rev"; + Abbs_cache.Lru.on_hit = on_hit "fetch_file_by_rev"; on_miss = on_miss "fetch_file_by_rev"; capacity = cache_capacity_mb 100; } @@ -864,7 +864,7 @@ module S = struct let fetch_repo_cache = Fetch_repo_cache.create { - Abb_cache.Expiring.on_hit = on_hit "fetch_repo"; + Abbs_cache.Expiring.on_hit = on_hit "fetch_repo"; on_miss = on_miss "fetch_repo"; duration = Duration.of_sec 60; capacity = cache_capacity_mb 100; @@ -873,7 +873,7 @@ module S = struct let fetch_tree_by_rev_cache = Fetch_tree_cache.By_rev.create { - Abb_cache.Lru.on_hit = on_hit "fetch_tree_by_rev"; + Abbs_cache.Lru.on_hit = on_hit "fetch_tree_by_rev"; on_miss = on_miss "fetch_tree_by_rev"; capacity = cache_capacity_mb 20; } diff --git a/code/tests/abb_cache/test.ml b/code/tests/abb_cache/test.ml new file mode 100644 index 00000000..cc9fd4ed --- /dev/null +++ b/code/tests/abb_cache/test.ml @@ -0,0 +1,317 @@ +module Abb = Abb_scheduler_select +module Oth_abb = Oth_abb.Make (Abb) +module Abb_cache = Abb_cache.Make (Abb) + +let test_expiring_cache = + Oth_abb.test ~name:"Expiring cache" (fun () -> + let open Abb.Future.Infix_monad in + let module C = Abb_cache.Expiring.Make (struct + type k = string + type args = int ref * string + type v = string + type err = [ `Error ] + + let fetch (r, v) = + incr r; + Abb.Future.return (Ok v) + + let equal_k = CCString.equal + let weight = CCString.length + end) in + let count = ref 0 in + let k1 = "key1" in + let k2 = "key2" in + let v1 = "value1" in + let v2 = "value2" in + let cache = + C.create + { + Abb_cache.Expiring.on_hit = CCFun.const (); + on_miss = CCFun.const (); + duration = Duration.of_sec 1; + capacity = CCString.length (v1 ^ v2); + } + in + C.fetch cache k1 (count, v1) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k2 (count, v2) + >>= fun ret -> + assert (ret = Ok v2); + assert (!count = 2); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 2); + Abb.Future.return ()) + +let test_expiring_cache_expiration_eviction = + Oth_abb.test ~name:"Expiring cache expiration eviction" (fun () -> + let open Abb.Future.Infix_monad in + let module C = Abb_cache.Expiring.Make (struct + type k = string + type args = int ref * string + type v = string + type err = [ `Error ] + + let fetch (r, v) = + incr r; + Abb.Future.return (Ok v) + + let equal_k = CCString.equal + let weight = CCString.length + end) in + let count = ref 0 in + let k1 = "key1" in + let k2 = "key2" in + let v1 = "value1" in + let v2 = "value2" in + let cache = + C.create + { + Abb_cache.Expiring.on_hit = CCFun.const (); + on_miss = CCFun.const (); + duration = Duration.of_sec 1; + capacity = CCString.length (v1 ^ v2); + } + in + C.fetch cache k1 (count, v1) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k2 (count, v2) + >>= fun ret -> + assert (ret = Ok v2); + assert (!count = 2); + Abb.Sys.sleep 1.2 + >>= fun () -> + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v2); + assert (!count = 3); + Abb.Future.return ()) + +let test_expiring_cache_capacity_eviction = + Oth_abb.test ~name:"Expiring cache capacity eviction" (fun () -> + let open Abb.Future.Infix_monad in + let module C = Abb_cache.Expiring.Make (struct + type k = string + type args = int ref * string + type v = string + type err = [ `Error ] + + let fetch (r, v) = + incr r; + Abb.Future.return (Ok v) + + let equal_k = CCString.equal + let weight = CCString.length + end) in + let count = ref 0 in + let k1 = "key1" in + let k2 = "key2" in + let v1 = "value1" in + let v2 = "value2" in + let cache = + C.create + { + Abb_cache.Expiring.on_hit = CCFun.const (); + on_miss = CCFun.const (); + duration = Duration.of_sec 1; + capacity = CCString.length v1; + } + in + C.fetch cache k1 (count, v1) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k2 (count, v2) + >>= fun ret -> + assert (ret = Ok v2); + assert (!count = 2); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v2); + assert (!count = 3); + Abb.Future.return ()) + +let test_lru_cache = + Oth_abb.test ~name:"LRU cache" (fun () -> + let open Abb.Future.Infix_monad in + let module C = Abb_cache.Lru.Make (struct + type k = string + type args = int ref * string + type v = string + type err = [ `Error ] + + let fetch (r, v) = + incr r; + Abb.Future.return (Ok v) + + let equal_k = CCString.equal + let weight = CCString.length + end) in + let count = ref 0 in + let k1 = "key1" in + let k2 = "key2" in + let v1 = "value1" in + let v2 = "value2" in + let cache = + C.create + { + Abb_cache.Lru.on_hit = CCFun.const (); + on_miss = CCFun.const (); + capacity = CCString.length (v1 ^ v2); + } + in + C.fetch cache k1 (count, v1) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k2 (count, v2) + >>= fun ret -> + assert (ret = Ok v2); + assert (!count = 2); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 2); + Abb.Future.return ()) + +let test_lru_cache_eviction = + Oth_abb.test ~name:"LRU cache eviction" (fun () -> + let open Abb.Future.Infix_monad in + let module C = Abb_cache.Lru.Make (struct + type k = string + type args = int ref * string + type v = string + type err = [ `Error ] + + let fetch (r, v) = + incr r; + Abb.Future.return (Ok v) + + let equal_k = CCString.equal + let weight = CCString.length + end) in + let count = ref 0 in + let k1 = "key1" in + let k2 = "key2" in + let k3 = "key3" in + let v1 = "value1" in + let v2 = "value2" in + let v3 = "value3" in + let cache = + C.create + { + Abb_cache.Lru.on_hit = CCFun.const (); + on_miss = CCFun.const (); + capacity = CCString.length (v1 ^ v2) + 3; + } + in + C.fetch cache k1 (count, v1) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k2 (count, v2) + >>= fun ret -> + assert (ret = Ok v2); + assert (!count = 2); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 2); + C.fetch cache k3 (count, v3) + >>= fun ret -> + assert (ret = Ok v3); + assert (!count = 3); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 3); + C.fetch cache k2 (count, v1) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 4); + Abb.Future.return ()) + +let test_lru_cache_capacity_eviction = + Oth_abb.test ~name:"LRU cache capacity eviction" (fun () -> + let open Abb.Future.Infix_monad in + let module C = Abb_cache.Lru.Make (struct + type k = string + type args = int ref * string + type v = string + type err = [ `Error ] + + let fetch (r, v) = + incr r; + Abb.Future.return (Ok v) + + let equal_k = CCString.equal + let weight = CCString.length + end) in + let count = ref 0 in + let k1 = "key1" in + let k2 = "key2" in + let v1 = "value1" in + let v2 = "value2" in + let cache = + C.create + { + Abb_cache.Lru.on_hit = CCFun.const (); + on_miss = CCFun.const (); + capacity = CCString.length v1; + } + in + C.fetch cache k1 (count, v1) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v1); + assert (!count = 1); + C.fetch cache k2 (count, v2) + >>= fun ret -> + assert (ret = Ok v2); + assert (!count = 2); + C.fetch cache k1 (count, v2) + >>= fun ret -> + assert (ret = Ok v2); + assert (!count = 3); + Abb.Future.return ()) + +let test = + Oth_abb.( + to_sync_test + (parallel + [ + test_expiring_cache; + test_expiring_cache_expiration_eviction; + test_expiring_cache_capacity_eviction; + test_lru_cache; + test_lru_cache_eviction; + test_lru_cache_capacity_eviction; + ])) + +let () = + Random.self_init (); + Oth.run test