(**************************************************************************)
(*                   Cameleon                                             *)
(*                                                                        *)
(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
(*      en Automatique. All rights reserved.                              *)
(*                                                                        *)
(*      This program 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  *)
(*      any later version.                                                *)
(*                                                                        *)
(*      This program 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 this program; if not, write to the Free Software       *)
(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
(*      02111-1307  USA                                                   *)
(*                                                                        *)
(*      Contact: Maxence.Guesdon@inria.fr                                *)
(**************************************************************************)

(** The class for PostgreSQL databases through Alain Frisch's postgres library. *)

open Dbf_types.Current

module M = Dbf_messages

type col_type =
(* boolean type *)
  | BOOL

(* geometry *)
  | BOX
  | CIRCLE
  | LINE
  | LSEG
  | POINT
  | POLYGON
  | PATH

(* character types *)
  | CHAR
  | CHAR_X
  | NAME
  | TEXT
  | VARCHAR_X

(* numeric types *)
  | DECIMAL
  | FLOAT4
  | FLOAT8
  | INT2
  | INT4
  | INT8
  | NUMERIC
  | SERIAL

(* time types *)
  | DATE
  | INTERVAL
  | TIME
  | TIME_TZ
  | TIMESTAMP
  | TIMESTAMP_TZ

(* IP Version 4 Networks and Host Addresses *)
  | CIDR
  | INET

(* money type *)
  | MONEY

  | OTHER_X

let bool = "BOOL"

let box = "BOX"
let circle = "CIRCLE"
let line = "LINE"
let lseg = "LSEG"
let point = "POINT"
let polygon = "POLYGON"
let path = "PATH"

let char = "CHAR"
let char_x = "CHAR(M)"
let name = "NAME"
let text = "TEXT"
let varchar_x = "VARCHAR(M)"

let decimal = "DECIMAL"
let float4 = "FLOAT4"
let float8 = "FLOAT8"
let int2 = "INT2"
let int4 = "INT4"
let int8 = "INT8"
let numeric = "NUMERIC"
let serial = "SERIAL"

let date = "DATE"
let interval = "INTERVAL"
let time = "TIME"
let time_tz = "TIME_TZ"
let timestamp = "TIMESTAMP"
let timestamp_tz = "TIMESTAMP_TZ"

let cidr = "CIDR"
let inet = "INET"

let money = "MONEY"

let other = "Other"

let type_strings = [
  bool, BOOL;

  box, BOX;
  circle, CIRCLE;
  line, LINE;
  lseg, LSEG;
  point, POINT;
  polygon, POLYGON;
  path, PATH;

  char, CHAR;
  char_x, CHAR_X;
  name, NAME;
  text, TEXT;
  varchar_x, VARCHAR_X;

  decimal, DECIMAL;
  float4, FLOAT4;
  float8, FLOAT8;
  int2, INT2;
  int4, INT4;
  int8, INT8;
  numeric, NUMERIC;
  serial, SERIAL;

  date, DATE;
  interval, INTERVAL;
  time, TIME;
  time_tz, TIME_TZ;
  timestamp, TIMESTAMP;
  timestamp_tz, TIMESTAMP_TZ;

  cidr, CIDR;
  inet, INET;

  money, MONEY;
] 

class postgres_spec =
  object
    method dbms = Postgres
    method name = "PostgreSQL"

    method types = [
      bool, None;

      box, None;
      circle, None;
      line, None;
      lseg, None;
      point, None;
      polygon, None;
      path, None;

      char, None;
      char_x, Some "M";
      name, None;
      text, None;
      varchar_x, Some "M";

      decimal, None;
      float4, None;
      float8, None;
      int2, None;
      int4, None;
      int8, None;
      numeric, None;
      serial, None;

      date, None;
      interval, None;
      time, None;
      time_tz, None;
      timestamp, None;
      timestamp_tz, None;

      cidr, None;
      inet, None;

      money, None;

      other, Some ""
    ] 

    method header = 
"open Postgres

let mExecError req = \""^Dbf_messages.mExecError^" \"^req

let string_of_pred_list l =
  let rec iter acc = function
      [] -> acc
    | (c,Some v) :: [] -> acc^c^\"=\"^v
    | (c,None) :: [] -> acc^c^\" IS NULL\"
    | (c,Some v) :: q -> iter (acc^c^\"=\"^v^\" AND \") q
    | (c,None) :: q -> iter (acc^c^\" IS NULL AND \") q
  in
  iter \"\" l\n\n

let escape_string s =
  let rec iter acc s =
    let len = String.length s in
    if len = 0 then
      acc
    else
      match s.[0] with
        '\\'' -> iter (acc ^ \"\\\\'\") (String.sub s 1 (len -1))
      | '\\\\' -> iter (acc ^ \"\\\\\\\\\") (String.sub s 1 (len -1))
      | _ -> iter (acc ^ (String.sub s 0 1)) (String.sub s 1 (len -1))
  in
  iter \"\" s
    
let string_of_sqlstring s = s

let sqlstring_of_string s =  \"'\"^(escape_string s)^\"'\"

(* Return a the string [\"NULL\"] if None or the given string if Some.*)
let string_or_null s_opt =
  match s_opt with
    None -> \"NULL\"
  | Some s -> s

(* Return an optional string from a string returned by ODBC
   ([None] means that the given string is [\"\"]*)
let string_opt s =
   match s with
     \"\" -> None
   | _ -> Some s

(* Apply a function to an optional value. *)
let apply_opt f v_opt =
   match v_opt with
     None -> None
   | Some v -> Some (f v)

(* Generic update function used in the [update] function of each table.*)
let update_table db table
    pred_list set_list =
  let query = \"update \"^table^\" set \"^
      (String.concat \", \" set_list)^
	 (match pred_list with
	   [] -> \"\"
	 | _ -> \" where \"^(String.concat \" AND \" pred_list))
  in
  try
    let res = db#exec query in
    match res#status with
     Postgres.Result.Bad_response 
   | Postgres.Result.Nonfatal_error 
   | Postgres.Result.Fatal_error ->
       let s = Postgres.Result.string_of_status res#status in
       raise (Failure ((mExecError query)^\" \"^s))
   | _ ->
      ()
  with
    Error e ->
      let s = Postgres.string_of_error e in
      raise (Failure ((mExecError query)^\" \"^s))

type db = Postgres.connection

let connect
    ?(host : string option) 
    ?(port : int option) 
    ?password user database =
  try 
    new Postgres.connection
      (Postgres.conninfo
        ?host
        ?port:(apply_opt string_of_int port)
        ~dbname: database
        ~user: user
        ?password
        ())
  with Postgres.Error e -> 
    raise (Failure (Postgres.string_of_error e))

"

    method col_attributes = [ ("Misc",  Att_string) ]
   
    method col_keys = ([Primary_key ; Key] : t_key list)

    method funs_2ml = [ "int_of_string" ; "float_of_string" ;
			"string_of_sqlstring"]
    method funs_ml2 = [ "string_of_int" ; "string_of_float" ;
			"sqlstring_of_string"]

 end


let spec = ((new postgres_spec) :> Dbf_dbms.dbms_spec)

let p = Format.fprintf

(** Code generation to use Postgres. *)
class postgres_gen spec =
  object (self)
    inherit Dbf_odbc.odbc_gen spec

    (** Get the SQL code to define the given column. *)
    method column_def c =
      let cdbms = List.assoc spec#dbms c.col_dbms in
      let t = 
	let (s, v_opt, args_opt) = cdbms.col_type_sql in
	let s_args = match args_opt with None -> "" | Some a -> a in
        let maybe_int_code s =
          try ignore (int_of_string s); s
          with _ -> Printf.sprintf "\"^(string_of_int (%s))^\"" s
        in
	let s_type = 
	  match v_opt with
	  | _ when s = bool -> "BOOL" 

	  | _ when s = box -> "BOX"
	  | _ when s = circle -> "CIRCLE"
	  | _ when s = line -> "LINE"
	  | _ when s = lseg -> "LSEG"
	  | _ when s = point -> "POINT"
	  | _ when s = polygon-> "POLYGON"
	  | _ when s = path -> "PATH"

	  | _ when s = char -> "CHAR"
	  | Some x when s = char_x -> "CHAR("^(maybe_int_code x)^")"
	  | _ when s = name -> "NAME"
	  | _ when s = text -> "TEXT"
	  | Some x when s = varchar_x -> "VARCHAR("^(maybe_int_code x)^")"

	  | _ when s = decimal -> "DECIMAL"
	  | _ when s = float4 -> "FLOAT4"
	  | _ when s = float8 -> "FLOAT8"
	  | _ when s = int2 -> "INT2"
	  | _ when s = int4 -> "INT4"
	  | _ when s = int8 -> "INT8"
	  | _ when s = numeric -> "NUMERIC"
	  | _ when s = serial -> "SERIAL"

	  | _ when s = date -> "DATE"
	  | _ when s = interval -> "INTERVAL"
	  | _ when s = time -> "TIME"
	  | _ when s = time_tz -> "TIME WITH TIME ZONE"
	  | _ when s = timestamp -> "TIMESTAMP"
	  | _ when s = timestamp_tz -> "TIMESTAMP WITH TIME ZONE"

	  | _ when s = cidr -> "CIDR"
	  | _ when s = inet -> "INET"

	  | _ when s = money -> "MONEY"

	  | Some x when s = other -> x
	  | _ -> raise (Failure (Format.sprintf "%s: %s %s" 
				   M.incorrect_type_definition
				   s (match v_opt with None -> "<None>" | Some n -> n)))
	in
	s_type^" "^(String.escaped s_args)
      in
      c.col_name^" "^t^
      (match c.col_nullable with
	true -> ""
      |	false -> " not null")^
      (match cdbms.col_key with
	None -> ""
      |	Some Primary_key -> 
         if c.col_nullable then
            raise (Failure "in postgres, a primay key column can not be nullable")
         else
            " primary key"
      |	Some Key -> assert false
      )^
      (match cdbms.col_default with
	None -> ""
      |	Some v -> " default "^v)	

    method gen_exec fmt =
      p fmt "%s\n\n"
	("      try\n"^
         "       let res = db#exec query in\n"^
         "       match res#status with\n"^
         "         Postgres.Result.Bad_response \n"^
         "       | Postgres.Result.Nonfatal_error\n"^
         "       | Postgres.Result.Fatal_error ->\n"^
         "         let s = Postgres.Result.string_of_status res#status in\n"^
         "         raise (Failure ((mExecError query)^\" \"^s))\n"^
         "       | _ ->\n"^
         "         ()\n"^
         "      with\n"^
         "       Error e ->\n"^
         "         let s = Postgres.string_of_error e in\n"^
         "         raise (Failure ((mExecError query)^\" \"^s))"
        )

    method gen_select_exec fmt table =
      p fmt "%s"
	("      try\n"^
	 "        let res = db#exec query in\n");
      self#gen_debug fmt "prerr_endline \"res = Mysql.exec db OK, let's see res#status...\";";
      p fmt "%s"                   
        ("       match res#status with\n"^
         "         Postgres.Result.Bad_response \n"^
         "       | Postgres.Result.Nonfatal_error\n"^
         "       | Postgres.Result.Fatal_error ->\n"
        );
      self#gen_debug fmt "prerr_endline \"status indicates an error\";";
      p fmt "%s"
	("         let s = Postgres.Result.string_of_status res#status in\n"^
         "         raise (Failure ((mExecError query)^\" \"^s))\n"
        );
      p fmt "%s"
	("       | Postgres.Result.Tuples_ok ->\n");
      self#gen_debug fmt "prerr_endline \"status indicates Tuples are available\";";
      p fmt "%s"
	("           (\n"^
         "            let l = ref [] in\n"^
	 "            let len = res#ntuples in\n"^
	 "            for i = 0 to len - 1 do\n"^
	 "              let t = {\n"
	);
      let rec iter n cols =
	match cols with
	  [] -> ()
	| col :: q ->
	    p fmt "                    %s = %s%s (%s(res#getvalue (len-1-i) %d));\n"
	      (String.lowercase col.col_name)
              (if col.col_nullable then "apply_opt " else "")
	      (self#col_2ml col)
	      (if col.col_nullable then "string_opt " else "")
	      n;
	    iter (n+1) q
      in
      iter 0 table.ta_columns;
      p fmt "%s\n"
	("              } in\n"^
	 "              l := t :: !l\n"^
	 "            done;\n"^
	 "            !l"
	);
      p fmt "           )\n";
      p fmt "%s"
	("       | _ ->\n");
      self#gen_debug fmt "prerr_endline \"status indicates no error but no tuples either\";";
      p fmt "          []\n";

      p fmt "%s\n"
	(
	 "      with\n"^
	 "      | Error e ->\n"^
	 "          let s = Postgres.string_of_error e in\n"^
         "         raise (Failure ((mExecError query)^\" \"^s))\n"
	)


end
