(*
 * <COPYRIGHT>
 * Copyright 2003 Gerd Stolpmann
 *
 * <GPL>
 * This file is part of WTimer.
 *
 * WTimer is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * WTimer 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
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with WDialog; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 * </>
 *)

(* $Id: db_pg.ml,v 1.5 2003/03/23 11:59:13 gerd Exp $
 * ----------------------------------------------------------------------
 *
 *)

(* Access PostgreSQL by ocamlodbc: *)

module Connection = struct
  module D = Ocamlodbc (* abbr *)

  type bind_data = 
      (string * string * string)   (* dbname, username, passwd *)

  type conn_handle =
      Unbound
    | Bound of bind_data
    | Connected of (D.connection * bind_data * float * bool)
        (* The float is the time when the last query was executed. A negative
	 * number means that the alarm is inactive.
	 * The bool means that there is a transaction.
	 *)
  type connection = conn_handle ref
      
  open Printf

  let _exec conn s =
    (* prerr_endline ("EXECUTE " ^ s); *)
    let code, recs = D.execute conn s in
    if code <> 0 then
      failwith "Database error";

    (*
    List.iter
      (fun row ->
	 prerr_endline ("ROW: " ^ String.concat "," row)
      )
      recs;
    *)

    recs

  let _exec_nr conn s = ignore(_exec conn s)

  let _begin_transaction =
    ref
      (fun c ->
	 _exec_nr c "begin work";
	 (* Since PG-7.3, the "set" changes only apply to the current transaction *)
	 _exec_nr c "set transaction isolation level read committed";
	 _exec_nr c "set constraints all immediate";
	 _exec_nr c "set datestyle = iso"
      )

  let _rollback_transaction = 
    ref
      (fun c -> _exec_nr c "rollback")

  let _commit_transaction =
    ref
      (fun c -> _exec_nr c "commit")

  let _disconnect c =
    D.disconnect c

  let _connect (db_name, db_user, db_passwd) =
    let c = D.connect db_name db_user db_passwd in
    c

  let create () =
    ref Unbound

  let close_after_timeout c t =
    let now = Unix.time() in
    match !c with
	Connected(c',bd,last,trans) ->
	  if last > 0.0 && now -. last > float t then (
	    (* timeout! *)
	    c := Bound bd;
	    if trans then !_rollback_transaction c';
	    _disconnect c';
	  )
      | _ ->
	  ()

  let bind ~db_name ~user_name ~passwd c =
    match !c with
	Unbound -> c := Bound (db_name, user_name, passwd)
      | _ -> failwith "Db_pg.bind"

  let unbind c =
    match !c with
	Unbound -> ()
      | Bound(_,_,_) -> c := Unbound
      | Connected (c',_,_,trans) -> 
	  c := Unbound;
	  if trans then !_rollback_transaction c';
	  _disconnect c'

  let exec c s =
    match !c with
	Unbound -> failwith "Db_pg.exec"
      | Bound (db_name, db_user, db_passwd as bd) -> 
	  let c' = _connect (db_name, db_user, db_passwd) in
	  c := Connected(c', bd, -1.0, true);
	  !_begin_transaction c';
	  _exec c' s
      | Connected(c',bd,_,trans) ->
	  c := Connected(c', bd, -1.0, true);
	  if not trans then !_begin_transaction c';
	  _exec c' s

  let exec_nr conn s = ignore(exec conn s)

  let commit c =
    match !c with
	Connected(c',bd,_,trans) ->
	  c := Connected(c', bd, Unix.time(),false);
	  if trans then (
	    try !_commit_transaction c'
	    with
		error ->
		  c := Bound bd;
		  _disconnect c';
		  raise error
	  )
      | _ ->
	  assert false

  let rollback c =
    match !c with
	Connected(c',bd,_,trans) ->
	  c := Connected(c', bd, Unix.time(),false);
	  if trans then (
	    try !_rollback_transaction c'
	    with
		error ->
		  c := Bound bd;
		  _disconnect c';
		  raise error
	  )
      | _ ->
	  assert false

  let is_connected c =
    match !c with
	Connected _ -> true
      | _ -> false

  (* ----------------------- SPECIAL FUNCTIONS ----------------------- *)

  let have_on_delete_cascade = true		     

  let have_time_keyword = "time"

  let have_interval_keyword = "interval"

  let day_interval d =
    sprintf "interval '%d days'" d

  let quote_re = Netstring_str.regexp "[\\']"

  let quote s =
    Netstring_str.global_replace quote_re "\\\\\\0" s

  let bool_true = "true"
  let bool_false = "false"

  let is_bool_true =
    function
	"1" | "t" | "true" | "y" | "yes" -> true
      | _   -> false

  let is_bool_false =
    function
	"0" | "f" | "false" | "n" | "no" -> true
      | _   -> false

  let expr_next_serial_value table column =
    (* Return the SQL expression to increment the counter for [table] and
     * [column], and to return the new value.
     *)
    sprintf "nextval('%s_%s_seq')" table column

  let expr_last_serial_value table column =
    (* Return the SQL expression to return the counter for [table] and
     * [column] again
     *)
    sprintf "currval('%s_%s_seq')" table column

  let get_last_serial_value c table column =
    let l = exec c (sprintf "select %s" 
		      (expr_last_serial_value table column)) in
    match l with
	[[ r ]] -> int_of_string r
      | _ -> failwith "get_last_serial_value"

end

(* ======================================================================
 * History:
 * 
 * $Log: db_pg.ml,v $
 * Revision 1.5  2003/03/23 11:59:13  gerd
 * 	GPL
 *
 * Revision 1.4  2003/02/04 01:42:40  gerd
 * 	The code does no longer use signals to get rid of inactive
 * database connections. Instead, new features of ocamlnet are used
 * (js_idle_worker).
 *
 * Revision 1.3  2003/02/03 01:28:59  gerd
 * 	Continued.
 *
 * Revision 1.2  2003/01/16 01:42:03  gerd
 * 	MySQL port
 *
 * Revision 1.1  2003/01/16 00:31:10  gerd
 * 	Initial revision.
 *
 * 
 *)