;;; Sam Thibault
;;; ODBC/SQL interface for scsh
;;; Spring 1999

;;; This is file: odbc1.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Comments
;;; ----------------
;;; This file contains several items:
;;;
;;;     1. Mappings of sql/odbc/c datatypes to integer values used by ODBC.
;;;
;;;     2. Definitions of records used by the scsh-sql interface and some
;;;        additional tools for accessing the records/vector structures.
;;;
;;;     3. Error handling tools for scsh-sql.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; The headers below will be included in C file the generated by cig

(foreign-source
  "#if 0"
  "#include \"cli0cli.h\""
  "#include \"cli0defs.h\""
  "#include \"cli0env.h\""
  "#else"
  "#include <windows.h>"
  "#include <sql.h>"
  "#include <sqlext.h>"
  "#endif"
  "")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Datatypes
;;; ---------
;;; These value assign sql/odbc/c datatypes to the values used by odbc.  There
;;; is also a function to decode the integer values so error messages can b
;;; more useful.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define sql/char 1)
(define sql/numeric 2)
(define sql/decimal 3)
(define sql/integer 4)
(define sql/smallint 5)
(define sql/float 6)
(define sql/real 7)
(define sql/double 8)
(define sql/varchar 12)
(define sql/date 9)
(define sql/time 10)
(define sql/timestamp 11)
(define sql/longvarchar -1)
(define sql/binary -2)
(define sql/varbinary -3)
(define sql/longvarbinary -4)
(define sql/bigint -5)
(define sql/tinyint -6)
(define sql/bit -7)

(define (type-val->string type)
  (cond
   ((= type sql/char) "sql/char")
   ((= type sql/numeric) "sql/numeric")
   ((= type sql/decimal) "sql/decimal")
   ((= type sql/integer) "sql/integer")
   ((= type sql/smallint) "sql/smallint")
   ((= type sql/float) "sql/float")
   ((= type sql/real) "sql/real")
   ((= type sql/double) "sql/double")
   ((= type sql/varchar) "sql/varchar")
   ((= type sql/date) "sql/date")
   ((= type sql/time) "sql/time")
   ((= type sql/timestamp) "sql/timestamp")
   ((= type sql/longvarchar) "sql/longvarchar")
   ((= type sql/binary) "sql/binary")
   ((= type sql/varbinary) "sql/varbinary")
   ((= type sql/longvarbinary) "sql/longvarbinary")
   ((= type sql/bigint) "sql/bigint")
   ((= type sql/tinyint) "sql/tinyint")
   ((= type sql/bit) "sql/bit")
   (else "unknown data type")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Records
;;; -------
;;; Here are definitions of records/vectors for storing table-descriptions and 
;;; cursor information.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;
;;; making a reference chart
;;; 
;;;           +-------+
;;; cursor -> | hstmt |
;;;           +-------+       +---+---+---+---+---+---+ - - - - - - +---+
;;;           | cols -+-----> | 0 | 1 | 2 | 3 | 4 | 5 |             | N |
;;;           +-------+       +---+---+-+-+---+---+---+ - - - - - - +---+
;;;                                     |
;;;                                     |    +-------------+
;;;                                     +--> | column name |
;;;                                          +-------------+
;;;                                          | name size   |
;;;                                          +-------------+
;;;                                          | data type   |
;;;                                          +-------------+
;;;                                          | precision   |
;;;                                          +-------------+
;;;                                          | scale       |
;;;                                          +-------------+
;;;                                          | nullable    |      (alien)
;;;                                          +-------------+     +-------+
;;;                                          | <target>----+---> | data  |
;;;                                          +-------------+     +-------+
;;; 

(define-record column-desc
  name
  size
  type
  precision
  scale
  nullable
  target)

(define-record table-desc
  hstmt ; ODBC statment handle
  cols) ; vector of column-desc records (see above)

;;; These functions reference items in the cursor.

(define (column-name table-desc column-number)
  (column-desc:name (vector-ref (table-desc:cols table-desc) 
				column-number)))

(define (column-size table-desc column-number)
  (column-desc:size (vector-ref (table-desc:cols table-desc) 
				column-number)))

(define (column-type table-desc column-number)
  (column-desc:type (vector-ref (table-desc:cols table-desc) 
				column-number)))

(define (column-precision table-desc column-number)
  (column-desc:precision (vector-ref (table-desc:cols table-desc)
				     column-number)))

(define (column-scale table-desc column-number)
  (column-desc:scale (vector-ref (table-desc:cols table-desc) 
				 column-number)))

(define (column-nullable table-desc column-number)
  (column-desc:nullable (vector-ref (table-desc:cols table-desc) 
				    column-number)))

(define (column-target table-desc column-number)
  (column-desc:target (vector-ref (table-desc:cols table-desc) 
				  column-number)))

;;; These functions are for changing items in a cursor.

(define (set-column-name! table-desc column-number val)
  (set-column-desc:name (vector-ref (table-desc:cols table-desc) 
				    column-number) 
			val))

(define (set-column-size! table-desc column-number val)
  (set-column-desc:size (vector-ref (table-desc:cols table-desc) 
				    column-number) 
			val))

(define (set-column-type! table-desc column-number val)
  (set-column-desc:type (vector-ref (table-desc:cols table-desc) 
				    column-number) 
			val))

(define (set-column-precision! table-desc column-number val)
  (set-column-desc:precision (vector-ref (table-desc:cols table-desc) 
					 column-number) 
			     val))

(define (set-column-scale! table-desc column-number val)
  (set-column-desc:scale (vector-ref (table-desc:cols table-desc) 
				     column-number) 
			 val))

(define (set-column-nullable! table-desc column-number val)
  (set-column-desc:nullable (vector-ref (table-desc:cols table-desc) 
					column-number) 
			    val))

(define (set-column-target! table-desc column-number val)
  (set-column-desc:target (vector-ref (table-desc:cols table-desc) 
				      column-number) 
			  val))

(define-record cursor
  col-data ; a table-desc
  ncols    ; number of cols in desc
  stmt     ; statement handle
  cmd)     ; command that created this cursor (to recycle stmt handle)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Error system
;;; ------------
;;; The functions defined here signal and handle errors in the scsh-sql
;;; interface.  The define-foreigns link to C functions defined in scsh-sql.c.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; These functions get the error message from ODBC

(define-foreign get-henv-error-state
  ("GetHenvErrorState" ((C "SQLHENV ~a") environment))
  static-string
  static-string)

(define-foreign get-hdbc-error-state
  ("GetHdbcErrorState" ((C "SQLHENV ~a") environment)
		       ((C "SQLHDBC ~a") connection))
  static-string
  static-string)

(define-foreign get-hstmt-error-state
  ("GetHstmtErrorState" ((C "SQLHENV ~a") environment)
			((C "SQLHSTMT ~a") statement))
  static-string
  static-string)

(define (sql-error environment connection statement)
  (cond (statement (get-hstmt-error-state (de-ref-env (server-env))
					  (de-ref-stmt statement)))
	(connection (get-hdbc-error-state (de-ref-env (server-env)) 
					  (de-ref-con connection)))
	(else (get-henv-error-state (de-ref-env environment)))))

;;; In order to deal with odbc errors, we will wrap the define-foreigns for 
;;; the ODBC functions in Scheme functions that can raise an appropriate error.
;;; First, we define conditions for 5 of the 7 possible odbc error types.  For
;;; two of the ODBC functions we will return a boolean value.
;;;
;;; code = odbc return type      = scheme condition
;;;------=-----------------------=-----------------
;;; (-2) = SQL_INVALID_HANDLE    = sql-invalid-error
;;; (-1) = SQL_ERROR             = sql-error
;;; 0    = SQL_SUCCESS           = #t
;;; 1    = SQL_SUCCESS_WITH_INFO = sql-info-warning
;;; 2    = SQL_STILL_EXECUTING   = sql-busy-exception
;;; 99   = SQL_NEED_DATA         = sql-param-exception
;;; 100  = SQL_NO_DATA_FOUND     = #f

;;; SQL_INVALID_HANDLE
(define-condition-type 'sql-invalid-error '(error))
(define sql-invalid-error? (condition-predicate 'sql-invalid-error))

(define (raise-sql-invalid-error function code message henv hdbc hstmt)
  (signal 'sql-invalid-error function code message henv hdbc hstmt))

;;; SQL_ERROR
(define-condition-type 'sql-error '(error))
(define sql-error? (condition-predicate 'sql-error))

(define (raise-sql-error function code message henv hdbc hstmt)
  (signal 'sql-error function code message henv hdbc hstmt))

;;; SQL_SUCCESS
;;; #t

;;; SQL_SUCCESS_WITH_INFO
(define-condition-type 'sql-info-warning '())
(define sql-info-warning? (condition-predicate 'sql-info-warning))

(define (raise-sql-info-warning function code message henv hdbc hstmt)
  (signal 'sql-info-warning function code message henv hdbc hstmt))

;;; SQL_STILL_EXECUTING
(define-condition-type 'sql-busy-exception '(error))
(define sql-busy-exception? (condition-predicate 'sql-busy-exception))

(define (raise-sql-busy-exception function code message henv hdbc hstmt)
  (signal 'sql-busy-exception function code message henv hdbc hstmt))

;;; SQL_NEED_DATA
(define-condition-type 'sql-param-exception '(error))
(define sql-param-exception? (condition-predicate 'sql-param-exception))

(define (raise-sql-param-exception function code message henv hdbc hstmt)
  (signal 'sql-param-exception function code message henv hdbc hstmt))

;;; SQL_NO_DATA_FOUND
;;; #f

;;; translate-return is the function which will enclose the define-foreigns of
;;; the ODBC functions.  For the errors/exceptions/warnings which can be
;;; raised there is a handler defined below.

(define (translate-return return-code function henv hdbc hstmt)
  (receive (code message) (sql-error henv hdbc hstmt)
    (case return-code
      ((-2) (raise-sql-invalid-error function code message 
				     henv hdbc hstmt)) ;; INVALID_HANDLE
      ((-1) (raise-sql-error function code message
			     henv hdbc hstmt)) ;; SQL_ERROR
      ((0) #t) ;; SQL_SUCCESS
      ((1) (raise-sql-info-warning function code message
				   henv hdbc hstmt)
	   #t) ;; SQL_SUCCESS_WITH_INFO
      ((2) (raise-sql-busy-exception function code message
				     henv hdbc hstmt)) ;; STILL_EXECUTING
      ((99) (raise-sql-param-exception function code message
				       henv hdbc hstmt)) ;;SQL_NEED_DATA
      ((100) #f) ;;  SQL_NO_DATA_FOUND
      (else (error function
		   "impossible return code: contact samt@ai.mit.edu")))))

;;; Tools for handlers.

(define (with-sql-invalid-handler* handler thunk)
  (with-handler
    (lambda (condition more)
      (if (sql-invalid-error? condition)
	  (let ((stuff (cdr condition))) ; (function code message)
	    (handler (car stuff)    ; function
		     (cadr stuff)   ; error code
		     (caddr stuff)  ; error message
		     (list-ref stuff 3)    ; henv
		     (list-ref stuff 4)    ; hdbc
		     (list-ref stuff 5)))) ; hstmt
      (more))
    thunk))

(define (with-sql-error-handler* handler thunk)
  (with-handler
    (lambda (condition more)
      (if (sql-error? condition)
	  (let ((stuff (cdr condition))) ; (function code message)
	    (handler (car stuff)    ; function
		     (cadr stuff)   ; error code
		     (caddr stuff)  ; error message
		     (list-ref stuff 3)    ; henv
		     (list-ref stuff 4)    ; hdbc
		     (list-ref stuff 5)))) ; hstmt
      (more))
    thunk))

(define (with-sql-info-handler* handler thunk)
  (with-handler
    (lambda (condition more)
      (if (sql-info-warning? condition)
	  (let ((stuff (cdr condition))) ; (function code message)
	    (handler (car stuff)    ; function
		     (cadr stuff)   ; error code
		     (caddr stuff)  ; error message
		     (list-ref stuff 3)    ; henv
		     (list-ref stuff 4)    ; hdbc
		     (list-ref stuff 5)))) ; hstmt
      (more))
    thunk))

(define (with-sql-busy-handler* handler thunk)
  (with-handler
    (lambda (condition more)
      (if (sql-busy-exception? condition)
	  (let ((stuff (cdr condition))) ; (function code message)
	    (handler (car stuff)    ; function
		     (cadr stuff)   ; error code
		     (caddr stuff)  ; error message
		     (list-ref stuff 3)    ; henv
		     (list-ref stuff 4)    ; hdbc
		     (list-ref stuff 5)))) ; hstmt
      (more))
    thunk))

(define (with-sql-param-handler* handler thunk)
  (with-handler
    (lambda (condition more)
      (if (sql-param-exception? condition)
	  (let ((stuff (cdr condition))) ; (function code message)
	    (handler (car stuff)    ; function
		     (cadr stuff)   ; error code
		     (caddr stuff)  ; error message
		     (list-ref stuff 3)    ; henv
		     (list-ref stuff 4)    ; hdbc
		     (list-ref stuff 5)))) ; hstmt
      (more))
    thunk))

;;; Catch all sql errors/exceptions/warnings.

(define (with-sql-handler* handler thunk)
  (with-handler
    (lambda (condition more)
      (if (or (sql-invalid-error? condition)
	      (sql-error? condition)
	      (sql-info-warning? condition)
	      (sql-busy-exception? condition)
	      (sql-param-exception? condition))
	  (let ((stuff (cdr condition))) ; (function code message)
	    (handler (car stuff)    ; function
		     (cadr stuff)   ; error code
		     (caddr stuff)  ; error message
		     (list-ref stuff 3)    ; henv
		     (list-ref stuff 4)    ; hdbc
		     (list-ref stuff 5)))) ; hstmt
      (more))
    thunk))