(* netcgi_dbi.ml

   Copyright (C) 2005-2006

     Christophe Troestler
     email: Christophe.Troestler@umh.ac.be
     WWW: http://math.umh.ac.be/an/

   This library is free software; see the file LICENSE for more information.

   This library is distributed in the hope that it will be useful, but
   WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the file
   LICENSE for more details.
*)
(* $Id: netcgi_dbi.ml,v 1.2 2005/10/19 20:21:23 chris_77 Exp $ *)

let cvs_version = "$Revision: 1.2 $"


module type DBI_DRIVER = sig
  type connection
  val connect : ?host:string -> ?port:string ->
    ?user:string -> ?password:string -> string ->
    connection
  val close : connection -> unit
  val closed : connection -> bool
  val commit : connection -> unit
  val ping : connection -> bool
  val rollback : connection -> unit
end

module type DBI_POOL = sig
  type connection
  val get : Netcgi.cgi -> ?host:string -> ?port:string ->
    ?user:string -> ?password:string -> string -> connection
end


(* XXX Think about how to do this in general *)
module DbiPool(Dbi_driver : DBI_DRIVER) = struct

  type connection = Dbi_driver.connection

  (* List of pools. The key is the unique combination of host/port/etc. and
   * the value is a list of unused connections for that pool.
   *
   * This code ought to work even for a multi-threaded Apache server.
   *)
  let pools = Hashtbl.create 8

  let get (cgi:Netcgi.cgi) ?host ?port ?user ?password database_name =
    let key = (host, port, user, password, database_name) in

    (* Get the pool (a connection list). *)
    let dbh_list = try Hashtbl.find pools key with Not_found -> [] in

    (* Search for an unused connection. We actually iterate over the
       pool testing the handles (in case they have timed out or
       something).  *)
    let rec loop = function
      | [] ->
	  (* No handles left. Need to create a new connection. *)
	  let dbh =
	    Dbi_driver.connect ?host ?port ?user ?password database_name in
	  dbh, []
      | dbh :: dbhs ->
	  (* Test if dbh is a working handle. If so, return it. *)
	  if Dbi_driver.ping dbh then
	    dbh, dbhs
	  else (
	    Dbi_driver.close dbh;
	    loop dbhs
	  )
    in
    let dbh, remainder = loop dbh_list in

    (* Update the pool. *)
    Hashtbl.replace pools key remainder;

    (* Register a callback so that we return this handle to the pool
       when the request finishes.  *)
    cgi#at_exit
      (fun () ->
	 if not (Dbi_driver.closed dbh) then (
	   Dbi_driver.rollback dbh;
	   let dbh_list = Hashtbl.find pools key in
	   Hashtbl.replace pools key (dbh_list @ [dbh])
	 ));
    dbh

end