add and test drop pool function

sihl/src/contract_database.ml

@@ -122,6 +122,13 @@ module type Sig = sig
       should be kept open. The default is 10. *)
   val add_pool : ?pool_size:int -> string -> string -> unit
 
+  (** [drop_pool name] closes all resources for the pool.
+
+      The pool can be referenced with its [name]. The service context can
+      contain the pool name under the key `pool` to force the usage of a certain
+      pool. *)
+  val drop_pool : string -> unit Lwt.t
+
   (** [find_opt ?ctx request input] runs a caqti [request] where [input] is the
       input of the caqti request and returns one row or [None]. Returns [None]
       if no rows are found.

sihl/src/database.ml

@@ -210,6 +210,17 @@ let add_pool ?(pool_size = 10) name database_url =
     raise (Contract_database.Exception ("Failed to create pool: " ^ msg))
 ;;
 
+let drop_pool name =
+  match Hashtbl.find_opt pools name with
+  | None ->
+    Logs.warn (fun m -> m "Connection pool with name '%s' doesn't exist" name);
+    Lwt.return_unit
+  | Some connection ->
+    let%lwt () = Caqti_lwt.Pool.drain connection in
+    let () = Hashtbl.remove pools name in
+    Lwt.return_unit
+;;
+
 let raise_error err =
   match err with
   | Error err -> raise @@ Contract_database.Exception (Caqti_error.show err)

sihl/test/database.ml

@@ -162,6 +162,35 @@ let choose_database_pool _ () =
   Lwt.return ()
 ;;
 
+let drop_database_pool _ () =
+  let open Sihl.Database in
+  let%lwt () = fetch_pool () |> Caqti_lwt.Pool.drain in
+  let database_url =
+    Option.value
+      ~default:"not found"
+      (Sihl.Configuration.read_string "DATABASE_URL")
+  in
+  let label = "foo" in
+  let ctx = [ "pool", label ] in
+  let%lwt check_connection =
+    try
+      (* Best indicator in Sihl at the moment is to check if "Database already
+         exists" is raised when "drop_pool" didn't work. An unknown pool name
+         results in running the query on the main database. *)
+      let%lwt () = drop_pool label in
+      let () = add_pool label database_url in
+      let%lwt () = query ~ctx drop_table_if_exists in
+      let%lwt () = drop_pool label in
+      let () = add_pool label database_url in
+      query ~ctx drop_table_if_exists |> Lwt_result.ok
+    with
+    | msg -> Printexc.to_string msg |> Lwt.return_error
+  in
+  Alcotest.(
+    check (result unit string) "dropping table worked" (Ok ()) check_connection);
+  Lwt.return_unit
+;;
+
 let suite =
   Alcotest_lwt.
     [ ( "database"
@@ -178,6 +207,7 @@ let suite =
             `Quick
             transaction_does_not_exhaust_pool
         ; test_case "choose database pool" `Quick choose_database_pool
+        ; test_case "drop database pool" `Quick drop_database_pool
         ] )
     ]
 ;;