;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Package   : sqld-psql.scm
;;; Author    : Hans Oesterholt-Dijkema.
;;; Copyright : (c) 2007.
;;; License   : LGPL
;;; CVS       : $Id: sqld-psql-internal.scm,v 1.1 2007/07/05 20:12:43 hoesterholt Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=pod
;
;=head1 Name
;
;sqld-psql - SQL Driver for PostgreSQL
;
;=head1 Description
;
;This is an FFI PostgreSQL driver for SQLI. It solves some problems
;of the sqld-psql driver that is used through the C<spgsql.plt> planet
;package.
;
;It is a simple driver, that has no optimizations like cursor operations,
;connection pools, etc. However, it is an asynchronous driver. This means,
;that scheme will be able to execute threads while queries are active.
;
;This driver conforms to
;L<the interface description for drivers|SQLD - Interface description for SQLI drivers>.
;
;The driver must be used through SQLI.
;
;=head1 API
;
;=head2 C<(sqld-psql-new connection-info) : closure>
;
;Calling this function with a valid PostgreSQL connection string
;(containing host, dbname, user, etc.),
;will instantiate a new driver, that can be given to a new
;instance of SQLI.
;
;=head1 Synopsis
;
;=syn scm,8
;
; (module test mzscheme
; 	(require (planet "sqli.scm" ("oesterholt" "sqlid.plt" 1 0)))
; 	(require (planet "sqld-psql.scm" ("oesterholt" "sqld-psql-ffi.plt" 1 0)))
; 	(provide main)
;
; (define (main)
;   (let* ((sqld (sqld-psql-new "user=test hostname=localhost dbname=test"))
;          (sqli (sqli-connect sqld)))
;     (...)
;
;=head1 Literate section
;
;This module L<interfaces with a C part|SQLD-PSQL C part> that interfaces to the
;psql library. B<The interface is built for PostgreSQL version E<gt>=8.0>.
;
;=head2 Module definition
;
;The module definition is as follows:
;
;=verbatim scm,8
(module sqld-psql-internal mzscheme
	(require (lib "time.ss" "srfi" "19"))
	(require "c-sqld-psql.scm")
;=verbatim
;
;As can be seen, only one function is exported, the C<sqld-psql-new> function.
;All other function definitions are interface definitions for C functions that
;are called from this module.
;
;=head2 Supportive functions
;
;In the next section, supportive functions and definitions are described.
;
;The C<ierr> function displays a message and returns C<#f>. This function is
;simply used to report errors to the current output port.
;
;=verbatim scm,8
(define (ierr msg)
  (display msg)
  (newline)
  #f)
;=verbatim
;
;=head2 Conversion functions
;
;Conversion functions are used to convert between database representations
;of types and scheme representations of types. They are all straightforward.
;
;Psql is SQL92 compliant, so for all strings, the single quote must be
;escaped. A simple C<pregexp-replace*> call is used to escape the single
;quotes. This function could be made more efficient, using a loop, or
;even a C function to do the same.
;
;=verbatim scm,8
(define (string2db conn s debug)
  (string-append "'" (pg-escape conn s debug) "'"))
;=verbatim
;
;A PostgreSQL date type is constructed
;from the bigloo date type, using a the predescribed PostgreSQL encoding,
;without a zone part.
;
;The interpretation back from the database is done by expecting the
;same encoding. No checking is done for the parts of the
;strings; so, the
;precondition for the use of this function is, that the given string
;conforms to the previous definition.
;
;=verbatim scm,8

;#+ mzscheme
(define-syntax integer->string
  (syntax-rules ()
    ((integer->string s) (number->string s))))

(define-syntax string->integer
  (syntax-rules ()
    ((string->integer s) (string->number s))))
;##


(define (pre-zero2 n)
  (if (< n 10) 
      (string-append "0" (integer->string n))
      (integer->string n)))

(define (date2db dt)
  (string-append "'"
  (date->string dt "~Y~m~dT~H~M~S")
  "'"))


(define (db2date dt)
  (string->date dt "~Y-~m-~d ~H:~M:~S")
)
;=verbatim
;
;All other conversions are done using the standard scheme primitives.
;
;=head2 Connecting
;
;The connection function is called from the closure provided
;by C<sqld-psql-new>, when it is called with the C<'connect>
;argument.  It returns a closure that is used for further
;command processing and that has a connection to the Psql
;database.
;
;The commands to be processed are placed in a C<cond> structure,
;with the probably most commonly used commands at front.
;
;Supportive functions are defined within the closure, to handle
;the interfacing for queries to the C part and fetches.
;
;=verbatim scm,8
(define (sqld-psql-connect connection-info null-value debug sync)
  (let ((db (pg-connect connection-info debug))
        (current-query-result #f)
        (valid-handle         #t)
        (nrows                0)
        (ncols                0)
        (row                  0)
        )

    (define (query q)
      (begin
        (set! current-query-result (pg-query db q debug))
        (set! row -1)
        (set! ncols (pg-ncols current-query-result))
        (set! nrows (pg-nrows current-query-result))))

    (define (fetch)
      (set! row (+ row 1))
      (pg-row current-query-result row null-value))

    (lambda (cmd . args)
      (if (eq? valid-handle #f)
          (ierr "ERROR: disconnected handle")
          (cond

           ((eq? cmd 'string2db)    (string2db db (car args) debug))
           ((eq? cmd 'int2db)       (integer->string (car args)))
           ((eq? cmd 'number2db)    (number->string (car args)))
           ((eq? cmd 'date2db)      (date2db (car args)))
           ((eq? cmd 'bool2db)      (if (eq? (car args) #t) "'t'" "'f'"))

           ((eq? cmd 'db2date)      (db2date (car args)))
           ((eq? cmd 'db2bool)      (if (string=? (car args) "t") #t #f))
           
           ((eq? cmd 'fetchrow)     (if (eq? current-query-result #f) #f (fetch)))
           ((eq? cmd 'lasterr)      (pg-error-message (if (eq? current-query-result #f) db current-query-result)))

           ((eq? cmd 'begin)        (query "BEGIN;"))
           ((eq? cmd 'commit)       (query "COMMIT;"))
           ((eq? cmd 'rollback)     (query "ROLLBACK;"))
           ((eq? cmd 'query)        (query (car args)))
           
           ((eq? cmd 'null-value)   (begin
                                      (if (not (null? args))
                                          (set! null-value (car args)))
                                      null-value))
           
           ((eq? cmd 'debug)        (begin
                                      (if (not (null? args))
                                          (if (eq? (car args) #f)
                                              (set! debug pg-nodebug)
                                              (if (procedure? (car args))
                                                  (set! debug (car args))
                                                  (set! debug pg-debug))))
                                      debug))

           ((eq? cmd 'disconnect)   (begin
                                      (pg-finish db debug)
                                      (set! valid-handle #f)))
	   
           (else (ierr "Unknown command")))))))
;=verbatim
;
;=head2 The main entry function
;
;Now for the main function that this driver provides: C<sqld-psql-new>.
;This function takes C<connection-info> as an argument, which must be
;an Psql database. It returns a closure that handles the C<'connect>,
;C<'clean>, C<'name> and C<'version> calls. It is a very simple function.
;
;The C<'version> call returns the major version number of PostgreSQL * 100 +
;the middle version number * 10  + the minor version number.
;
;=verbatim scm,8
(define (sqld-psql-new _connection-info)
  (let ((connection-info _connection-info)
        (null-value      "")
        (debug           pg-nodebug)
        (synchronous     #t))
    (lambda (cmd . args)
      (cond

       ((eq? cmd 'connect)     (sqld-psql-connect connection-info null-value debug synchronous))
       ((eq? cmd 'clean)       #t)

       ((eq? cmd 'name)        "psql-ffi")
       ((eq? cmd 'version)     (pg-version))
       ((eq? cmd 'null-value)  (begin
                                  (if (not (null? args)) 
                                      (set! null-value (car args)))
                                 null-value))
       ((eq? cmd 'debug)       (begin
                                 (if (not (null? args))
                                     (if (eq? (car args) #f)
                                         (set! debug pg-nodebug)
                                         (if (procedure? (car args))
                                             (set! debug (car args))
                                             (set! debug pg-debug))))
                                 debug))
       ((eq? cmd 'async)       (begin
                                 (set! synchronous #f)
                                 synchronous))
       ((eq? cmd 'sync)        (begin
                                 (set! synchronous #t)
                                 synchronous))
        

       (else (ierr "ERROR: Connect to the datebase first"))))))
;=verbatim
;
;=head2 Setting the null value
;
;The default value returned for null values is the empty string (i.e. "").
;If an other value is needed, e.g. C<'null>, one can set an alternative value
;using the C<sqld-psql-null-value> function on an C<sqld> object.
;
;=verbatim scm,8
(define (sqld-psql-null-value sqld . v)
  (apply sqld (cons 'null-value v)))
;=verbatim
;
;=head2 Debugging info
;
;If you want to have some information on what's going on with the server,
;turn debugging on, e.g. using C<(sqld-psql-debug sqld #t)>.
;
;=verbatim scm,8
(define (sqld-psql-debug sqld . v)
  (apply sqld (cons 'debug v)))
;=verbatim
;
;=head2 Asynchronous connection
;
;If you want to connect asynchronously to the database, call this function
;with #t, otherwise with #f. sqld-psql-ffi defaults to synchronous connecting.
;Asynchronous connecting doesn't work on all platforms.
;
;=verbatim scm,8
(define (sqld-psql-async-connect sqld yes)
  (if yes
      (sqld 'async)
      (sqld 'sync)))
;=verbatim
;
;=cut

(provide sqld-psql-new
         sqld-psql-null-value
         sqld-psql-async-connect
         sqld-psql-debug))