// Project:           Scheme-PG
// Author:            David J. Neu, djneu@acm.org
// Maintainer:        David J. Neu, djneu@acm.org
// Project Home Page: http://scheme-pg.sourceforge.net
// Copyright:         Copyright (c) 2004 Universal Technical Resource Services, Inc.
// License:           MIT License, see license.txt
// CVS Id:            $Id: s-pg.c,v 1.10 2005/03/21 22:58:18 djneu Exp $

/*
208 to 299 migration notes:

SCHEME_STRINGP(x) => SCHEME_CHAR_STRINGP(x)

SCHEME_STR_VAL(x) => SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(x))

SCHEME_STRLEN_VAL(x) => SCHEME_CHAR_STRLEN_VAL(x)

scheme_make_string(x) => scheme_byte_string_to_char_string(scheme_make_byte_string(x))
*/

/*
See s-pg-types.h for data type constants. The file s-pg-types.h was
manually constructed from the source mentioned.
*/

/*
BUILD and USAGE on a FreeBSD box:
     mzc --cc ++ccf -Iinclude ++ccf -I/usr/local/include s-pg.c
     mzc ++ldf -L/usr/local/lib ++ldf -lpq --ld s-pg.so s-pg.o

     # mzscheme
     #> (load-extension "s-pg.so")
     > (require (lib "s-pg.ss" "spg"))
     > (require "s-pg.so")
     > (define lconnection (connection-open "dbname=mydbname user=myuser password=mypassword"))
     > (define lresult (result-open lconnection "SELECT * FROM mytable"))
     > (display (result-ref lresult 0))
     > (result-close lresult)
*/

#include "escheme.h"
#include "libpq-fe.h"
#include "s-pg-types.h"
#include "s-pg.h"

enum action {GET_SCHEME_OBJECT, GET_METADATA};


Scheme_Object *sch_connection_open(int aargc, Scheme_Object **aargv)
{
  PGconn     *lconnection;
  if (!SCHEME_CHAR_STRINGP(aargv[0]))
    {
      scheme_wrong_type("connection-open", "string", 0, aargc, aargv);
    }
  lconnection = PQconnectdb(SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[0])));
  if (PQstatus(lconnection) == CONNECTION_BAD)
    {
      //exn:scheme-pg:connection-open
      scheme_signal_error("%sCONNECTION INFOMATION:  %s", 
			  PQerrorMessage(lconnection), 
			  SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[0])));
    }
  return scheme_make_cptr(lconnection, "connection");
}


Scheme_Object *sch_is_connection(int aargc, Scheme_Object **aargv)
{ 
  PGconn     *lconnection;
  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "connection"))
    {
      return scheme_false;
    }
  else
    {
      return scheme_true;
    }

}


Scheme_Object *sch_connection_close(int aargc, Scheme_Object **aargv)
{ 
  PGconn     *lconnection;
  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "connection"))
    {
      scheme_wrong_type("connection-close", "c-ptr:connection", 0, aargc, aargv);
    }
  else
    {
      lconnection = (PGconn *)SCHEME_CPTR_VAL(aargv[0]);
    }
  PQfinish(lconnection);
  return scheme_void;
}


Scheme_Object *sch_execute_sql(int aargc, Scheme_Object **aargv)
{
  PGconn     *lconnection;
  PGresult   *lresult;
  long lnumber_rows_affected;

  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "connection"))
    {
      scheme_wrong_type("execute-sql", "c-ptr:connection", 0, aargc, aargv);
    }
  else
    {
      lconnection = (PGconn *)SCHEME_CPTR_VAL(aargv[0]);
    }

  if (!SCHEME_CHAR_STRINGP(aargv[1]))
    {
      scheme_wrong_type("execute-sql", "string", 1, aargc, aargv);
    }

  lresult = PQexec(lconnection, SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[1])));

  if (PQresultStatus(lresult) != PGRES_COMMAND_OK)
    {
      if (PQresultStatus(lresult) == PGRES_TUPLES_OK)
	{
	  //exn:scheme-pg:execute-sql:non-query
	  scheme_signal_error("ERROR:  execute-sql should not be used to retrieve data.\nSQL STATEMENT:  %s",
			      PQresultErrorMessage(lresult), SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[1])));
	  PQclear(lresult);
	}
      else
	{
	  //exn:scheme-pg:execute-sql
	  scheme_signal_error("%sSQL STATEMENT:  %s", 
			      PQresultErrorMessage(lresult), 
			      SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[1])));
	  PQclear(lresult);
	}
    }
  lnumber_rows_affected = atol(PQcmdTuples(lresult));
  PQclear(lresult);
  return scheme_make_integer(lnumber_rows_affected);
}


//creates an empty result
/*
Scheme_Object *sch_result_empty(int aargc, Scheme_Object **aargv)
{
  PGconn     *lconnection;
  PGresult   *lresult;

  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "connection"))
    {
      scheme_wrong_type("result-open", "c-ptr:connection", 0, aargc, aargv);
    }
  else
    {
      lconnection = (PGconn *)SCHEME_CPTR_VAL(aargv[0]);
    }

  lresult = PQmakeEmptyPGresult(lconnection, NULL);

  return lresult;
}
*/


Scheme_Object *sch_result_open(int aargc, Scheme_Object **aargv)
{
  PGconn     *lconnection;
  PGresult   *lresult;

  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "connection"))
    {
      scheme_wrong_type("result-open", "c-ptr:connection", 0, aargc, aargv);
    }
  else
    {
      lconnection = (PGconn *)SCHEME_CPTR_VAL(aargv[0]);
    }

  if (!SCHEME_CHAR_STRINGP(aargv[1]))
    {
      scheme_wrong_type("result-open", "string", 1, aargc, aargv);
    }

  lresult = PQexec(lconnection, SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[1])));
  
  if (PQresultStatus(lresult) != PGRES_TUPLES_OK)
    {
      //exn:scheme-pg:result-open
      scheme_signal_error("%sSQL STATEMENT:  %s", 
			  PQresultErrorMessage(lresult), 
			  SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[1])));
      PQclear(lresult);
    }
  return scheme_make_cptr(lresult, "result");
}


Scheme_Object *sch_is_result(int aargc, Scheme_Object **aargv)
{ 
  PGconn     *lconnection;
  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "result"))
    {
      return scheme_false;
    }
  else
    {
      return scheme_true;
    }

}


Scheme_Object *sch_result_ref(int aargc, Scheme_Object **aargv)
{ 
  PGresult *lresult;
  long lrow_number;
  int lcolumn_number;
  //lrow is an association list consisting of lpair's
  Scheme_Object *lrow = scheme_null;
 //lpair is an length two improper list, with the car being the field name as a symbol and the cadr the field value
  Scheme_Object *lpair;
  Scheme_Object *lvalue;

  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "result"))
    {
      scheme_wrong_type("result-ref", "c-ptr:result", 0, aargc, aargv);
    }
  else
    {
      lresult = (PGresult *)SCHEME_CPTR_VAL(aargv[0]);
    }

  if (!SCHEME_INTP(aargv[1]))
    {
      scheme_wrong_type("result-ref", "integer", 1, aargc, aargv);
    }
  else
    {
      lrow_number = SCHEME_INT_VAL(aargv[1]);
    }

  //note: this also raises an exception when the result is empty
  if (lrow_number < 0 || lrow_number > PQntuples(lresult)-1)
    {
      //exn:scheme-db:result-ref:index
      scheme_signal_error("index out of range");
    }

  for (lcolumn_number = PQnfields(lresult)-1; lcolumn_number >= 0; lcolumn_number--) //notice the descreasing order
    {
      if (PQgetisnull(lresult, lrow_number, lcolumn_number))
	{
	  lvalue = scheme_intern_symbol("null-object");
	}
      else
	{
	  if (1==1) //TO DO: DO else option if user wants result column values returned as strings
	    lvalue = sch_dbms_to_scheme(lresult, lrow_number, lcolumn_number, GET_SCHEME_OBJECT);
	  else
	    lvalue = scheme_byte_string_to_char_string(scheme_make_byte_string(PQgetvalue(lresult, lrow_number, lcolumn_number)));
	}
      lpair = scheme_make_pair(scheme_intern_symbol(PQfname(lresult,  lcolumn_number)), lvalue);
      lrow = scheme_make_pair(lpair, lrow);
    }
  return lrow;
}


Scheme_Object *sch_column_metadata(PGresult *aresult, int acolumn_number, char *atype)
{
  // lmetadata is an association list
  Scheme_Object *lmetadata = scheme_null;
  Scheme_Object *lpair = scheme_null;

  lpair = scheme_make_pair(scheme_intern_symbol("type"), scheme_intern_symbol(atype));
  lmetadata = scheme_make_pair(lpair, lmetadata);

  lpair = scheme_make_pair(scheme_intern_symbol("column"), scheme_intern_symbol(PQfname(aresult, acolumn_number)));
  lmetadata = scheme_make_pair(lpair, lmetadata);

  //Need access to a connection so can run the following SELECT to retrieve the actual table name
  //"SELECT relname FROM pg_class WHERE oid=%ld", PQftable(aresult, acolumn_number);
  lpair = scheme_make_pair(scheme_intern_symbol("table"), scheme_make_integer(PQftable(aresult, acolumn_number)));
  lmetadata = scheme_make_pair(lpair, lmetadata);

  return lmetadata;
}


// The value of argument aaction determines whether or not a Scheme_Object or metadata is returned
Scheme_Object *sch_dbms_to_scheme(PGresult *aresult, long arow_number, int acolumn_number, int aaction)
{
  switch (PQftype(aresult, acolumn_number))
    {
    case BOOLOID:
      if (aaction == GET_SCHEME_OBJECT)
	if (strcmp(PQgetvalue(aresult, arow_number, acolumn_number), "t") == 0)
	  return scheme_true;
	else if (strcmp(PQgetvalue(aresult, arow_number, acolumn_number), "f") == 0)
	  return scheme_false;
	else 
	  //exn:scheme-db:conversion:boolean
	  scheme_signal_error("Invalid boolean value in row %ld, column %d of result", arow_number, acolumn_number);
      else
	return sch_column_metadata(aresult, acolumn_number, "boolean");
      
      // largest INT8OID is 9223372036854775807
    case INT8OID:
      if (aaction == GET_SCHEME_OBJECT)
	  return scheme_read_bignum_bytes(PQgetvalue(aresult, arow_number, acolumn_number), 0, 10);
      else
	return sch_column_metadata(aresult, acolumn_number, "bigint");

    case VARCHAROID:
      if (aaction == GET_SCHEME_OBJECT)
	return scheme_byte_string_to_char_string(scheme_make_byte_string(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "character-varying");

    case DATEOID:
      if (aaction == GET_SCHEME_OBJECT)
	return scheme_byte_string_to_char_string(scheme_make_byte_string(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "date");

    case FLOAT8OID:
      if (aaction == GET_SCHEME_OBJECT)
	return scheme_make_double(atof(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "double-precision");

      // also handles serial4
    case INT4OID:
      if (aaction == GET_SCHEME_OBJECT)
	  return scheme_make_integer_value(atol(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "integer");

    case FLOAT4OID:
      if (aaction == GET_SCHEME_OBJECT)
	return scheme_make_float(atof(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "real");

    case TEXTOID:
      if (aaction == GET_SCHEME_OBJECT)
	return scheme_byte_string_to_char_string(scheme_make_byte_string(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "text");

    case TIMEOID:
      if (aaction == GET_SCHEME_OBJECT)
	return scheme_byte_string_to_char_string(scheme_make_byte_string(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "time-without-time-zone");

    case TIMETZOID:
      if (aaction == GET_SCHEME_OBJECT)
	return scheme_byte_string_to_char_string(scheme_make_byte_string(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "time-with-time-zone");

    case TIMESTAMPOID:
      if (aaction == GET_SCHEME_OBJECT)
	return scheme_byte_string_to_char_string(scheme_make_byte_string(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "timestamp-without-time-zone");

    case TIMESTAMPTZOID:
      if (aaction == GET_SCHEME_OBJECT)
	return scheme_byte_string_to_char_string(scheme_make_byte_string(PQgetvalue(aresult, arow_number, acolumn_number)));
      else
	return sch_column_metadata(aresult, acolumn_number, "timestamp-with-time-zone");

    default:
      //exn:scheme-db:conversion
      scheme_signal_error("Conversion of column %d of result with OID=%ld not handled",
			  acolumn_number, PQftype(aresult, acolumn_number));
     }
}


Scheme_Object *sch_result_metadata(int aargc, Scheme_Object **aargv)
{
  PGresult *lresult;
  int i;
  Scheme_Object *lmetadata = scheme_null;

  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "result"))
    {
      scheme_wrong_type("sch_result_metadata", "c-ptr:result", 0, aargc, aargv);
    }
  else
    {
      lresult = (PGresult *)SCHEME_CPTR_VAL(aargv[0]);
    }

  for (i = 0; i < PQnfields(lresult); i++)
    {
      lmetadata = scheme_make_pair(sch_dbms_to_scheme(lresult, -1, i, GET_METADATA), lmetadata);
    }

  return lmetadata;
}


Scheme_Object *sch_result_length(int aargc, Scheme_Object **aargv)
{ 
  PGresult *lresult;

  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "result"))
    {
      scheme_wrong_type("result-length", "c-ptr:result", 0, aargc, aargv);
    }
  else
    {
      lresult = (PGresult *)SCHEME_CPTR_VAL(aargv[0]);
    }
  return scheme_make_integer(PQntuples(lresult));
}


Scheme_Object *sch_result_close(int aargc, Scheme_Object **aargv)
{ 
  PGresult *lresult;

  if (!SCHEME_CPTRP(aargv[0]) || strcmp(SCHEME_CPTR_TYPE(aargv[0]), "result"))
    {
      scheme_wrong_type("result-close", "c-ptr:result", 0, aargc, aargv);
    }
  else
    {
      lresult = (PGresult *)SCHEME_CPTR_VAL(aargv[0]);
    }
  PQclear(lresult);
  return scheme_void;
}


Scheme_Object *sch_escape_string(int aargc, Scheme_Object **aargv)
{
  char *lto;
  Scheme_Object *lstr;
  if (!SCHEME_CHAR_STRINGP(aargv[0]))
    {
      scheme_wrong_type("escape-string", "string", 1, aargc, aargv);
    }
  lto = malloc(2*strlen(SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[0])))*sizeof(char)+1);
  PQescapeString(lto, 
		 SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[0])), 
		 SCHEME_BYTE_STR_VAL(scheme_char_string_to_byte_string(aargv[0])));
  lstr = scheme_byte_string_to_char_string(scheme_make_byte_string(lto));
  free(lto);
  return(lstr);
}


Scheme_Object *sch_is_null_object(int aargc, Scheme_Object **aargv)
{ 
  if (SCHEME_SYMBOLP(aargv[0]) && (strcmp(SCHEME_SYM_VAL(aargv[0]), "null-object") == 0))
    {
      return scheme_true;
    }
  else
    {
      return scheme_false;
    }
}


Scheme_Object *scheme_initialize(Scheme_Env *env)
{
  /*
  printf("sizeof(char)=%d\n", sizeof(char));
  printf("sizeof(int)=%d\n", sizeof(int));
  printf("sizeof(long)=%d\n", sizeof(long));
  printf("sizeof(unsigned long)=%d\n", sizeof(unsigned long));
  printf("sizeof(float)=%d\n", sizeof(float));
  printf("sizeof(double)=%d\n", sizeof(double));
  */
  return scheme_reload(env);
}


Scheme_Object *scheme_reload(Scheme_Env *env)
{
  Scheme_Object *proc;

  env = scheme_primitive_module(scheme_intern_symbol("s-pg"), env);

  proc = scheme_make_prim_w_arity(sch_connection_open, "connection-open", 1, 1);
  scheme_add_global("connection-open", proc, env);

  proc = scheme_make_prim_w_arity(sch_is_connection, "connection?", 1, 1);
  scheme_add_global("connection?", proc, env);

  proc = scheme_make_prim_w_arity(sch_connection_close, "connection-close", 1, 1);
  scheme_add_global("connection-close", proc, env);

  proc = scheme_make_prim_w_arity(sch_execute_sql, "execute-sql", 2, 2);
  scheme_add_global("execute-sql", proc, env);

  proc = scheme_make_prim_w_arity(sch_result_open, "result-open", 2, 2);
  scheme_add_global("result-open", proc, env);

  proc = scheme_make_prim_w_arity(sch_is_result, "result?", 1, 1);
  scheme_add_global("result?", proc, env);

  //  proc = scheme_make_prim_w_arity(sch_result_empty, "result-empty", 1, 1);
  //  scheme_add_global("result-empty", proc, env);

  proc = scheme_make_prim_w_arity(sch_result_ref, "result-ref", 2, 2);
  scheme_add_global("result-ref", proc, env);

  proc = scheme_make_prim_w_arity(sch_result_length, "result-length", 1, 1);
  scheme_add_global("result-length", proc, env);

  proc = scheme_make_prim_w_arity(sch_result_metadata, "result-metadata", 1, 1);
  scheme_add_global("result-metadata", proc, env);

  proc = scheme_make_prim_w_arity(sch_result_close, "result-close", 1, 1);
  scheme_add_global("result-close", proc, env);

  proc = scheme_make_prim_w_arity(sch_escape_string, "escape-string", 1, 1);
  scheme_add_global("escape-string", proc, env);

  proc = scheme_make_prim_w_arity(sch_is_null_object, "null-object?", 1, 1);
  scheme_add_global("null-object?", proc, env);

  scheme_finish_primitive_module(env);

  return scheme_void;
}


Scheme_Object *scheme_module_name()
{
  return scheme_intern_symbol("s-pg");
}