From e59978ca3c4f1047c2820a29865dccbbb4a6da4d Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Mon, 5 Jun 2023 22:18:13 -0400
Subject: [PATCH] add Tiny_httpd_pool

---
 src/Tiny_httpd.ml       |  1 +
 src/Tiny_httpd.mli      |  4 ++++
 src/Tiny_httpd_pool.ml  | 38 ++++++++++++++++++++++++++++++++++++++
 src/Tiny_httpd_pool.mli | 12 ++++++++++++
 4 files changed, 55 insertions(+)
 create mode 100644 src/Tiny_httpd_pool.ml
 create mode 100644 src/Tiny_httpd_pool.mli

diff --git a/src/Tiny_httpd.ml b/src/Tiny_httpd.ml
index 5213ef34..4011fae2 100644
--- a/src/Tiny_httpd.ml
+++ b/src/Tiny_httpd.ml
@@ -5,3 +5,4 @@ module Util = Tiny_httpd_util
 module Dir = Tiny_httpd_dir
 module Html = Tiny_httpd_html
 module IO = Tiny_httpd_io
+module Pool = Pool
diff --git a/src/Tiny_httpd.mli b/src/Tiny_httpd.mli
index 607d7461..be1a6f24 100644
--- a/src/Tiny_httpd.mli
+++ b/src/Tiny_httpd.mli
@@ -100,6 +100,10 @@ end
 
 module Util = Tiny_httpd_util
 
+(** {2 Resource pool} *)
+
+module Pool = Pool
+
 (** {2 Static directory serving} *)
 
 module Dir = Tiny_httpd_dir
diff --git a/src/Tiny_httpd_pool.ml b/src/Tiny_httpd_pool.ml
new file mode 100644
index 00000000..97b8e1ea
--- /dev/null
+++ b/src/Tiny_httpd_pool.ml
@@ -0,0 +1,38 @@
+module A = Tiny_httpd_atomic_
+
+type 'a list_ = Nil | Cons of int * 'a * 'a list_
+
+type 'a t = {
+  mk_item: unit -> 'a;
+  max_size: int;  (** Max number of items *)
+  items: 'a list_ A.t;
+}
+
+let create ~mk_item ?(max_size = 128) () : _ t =
+  { mk_item; max_size; items = A.make Nil }
+
+let rec acquire_ self =
+  match A.get self.items with
+  | Nil -> self.mk_item ()
+  | Cons (_, x, tl) as l ->
+    if A.compare_and_set self.items l tl then
+      x
+    else
+      acquire_ self
+
+let[@inline] size_ = function
+  | Cons (sz, _, _) -> sz
+  | Nil -> 0
+
+let rec release_ self x : unit =
+  match A.get self.items with
+  | Cons (sz, _, _) when sz >= self.max_size ->
+    (* forget the item *)
+    ()
+  | l ->
+    if not (A.compare_and_set self.items l (Cons (size_ l + 1, x, l))) then
+      release_ self x
+
+let with_resource (self : _ t) f =
+  let x = acquire_ self in
+  Fun.protect ~finally:(fun () -> release_ self x) (fun () -> f x)
diff --git a/src/Tiny_httpd_pool.mli b/src/Tiny_httpd_pool.mli
new file mode 100644
index 00000000..dd702f44
--- /dev/null
+++ b/src/Tiny_httpd_pool.mli
@@ -0,0 +1,12 @@
+(** Resource pool *)
+
+type 'a t
+(** Pool of values of type ['a] *)
+
+val create : mk_item:(unit -> 'a) -> ?max_size:int -> unit -> 'a t
+(** Create a new pool. *)
+
+val with_resource : 'a t -> ('a -> 'b) -> 'b
+(** [with_resource pool f] runs [f x] with [x] a resource;
+    when [f] fails or returns, [x] is returned to the pool for
+    future reuse. *)