spgsql.ss
#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DBD-SPGSQL.plt
;;
;; DBI wrapper over schematics/spgsql.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; released under LGPL.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; spgsql.ss - wrapper over schematics/spgsql
;; yc 9/8/2009 - first version
;; yc 9/30/2009 - now creates implicit stored procedure and no longer uses SQL escape

(require (prefix-in dbd: (planet schematics/spgsql/spgsql))
         (prefix-in dbd: (planet schematics/spgsql/private/connection))
         (prefix-in dbd: (planet schematics/spgsql/private/sql-data))
         scheme/class
         scheme/match
         (planet bzlib/base)
         (planet bzlib/dbi)
         srfi/19
         "array.ss"
         )

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; adapters
(define (spgsql-connect driver . attrs)
  (let-values (((loader attrs)
                (filter-file-loader/attrs attrs)))
    (let ((handle (make-handle driver
                               (apply* dbd:connect attrs)
                               (make-immutable-hash-registry)
                               0)))
      (load-files! handle (if (list? loader) loader
                              (list loader)))
      handle)))

(define (spgsql-disconnect dbh)
  (send (handle-conn dbh) disconnect))

;; so to correctly handle the conversion here we'll have to map the values into their corresponding text conversion...
(define (spgsql-query dbh stmt (args '()))
  (if-it (registry-ref (handle-query dbh) stmt)
         (convert-result
          (send (handle-conn dbh) query
                (send (handle-conn dbh) bind-prepared-statement
                      (prepared-inner it)
                      (map cell->sql-cell (phq-map-values (prepared-query it) args)))))
         (begin
           (spgsql-prepare dbh stmt stmt)
           (spgsql-query dbh stmt args))))

;; (trace spgsql-query)

;; okay - time to deal with prepared statements.
;; the prepared statements takes 2 steps.
;; 1 - creates a prepared
;; 2 - take the prepared and then create a bind-param...
;; (the bind param part would occur @ query time...)
(define (spgsql-prepare dbh key stmt)
  (let ((query (make-place-holder-query default-converter stmt)))
    (registry-set! (handle-query dbh)
                   key
                   (make-prepared query
                                  (send (handle-conn dbh) prepare (phq-converted query))))))
;; (trace spgsql-prepare)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; converting the results...
(define (convert-result rs)
  (if (dbd:SimpleResult? rs)
      ;; rs;;
      (void) ;; means no result... ???
      (cons (FieldInfos->columns (dbd:Recordset-info rs))
            (data->records (dbd:Recordset-data rs)))))

(define (FieldInfos->columns fis)
  (map dbd:FieldInfo-name fis))

(define (data->records data)
  (map (lambda (rec)
         (map sql-cell->cell (vector->list rec)))
       data))

(define (sql-cell->cell cell)
  (cond ((dbd:sql-null? cell) '())
        ((dbd:sql-timestamp? cell) (sql-timestamp->date cell))
        ((dbd:sql-date? cell) (sql-date->date cell))
        ;; ((dbd:sql-time? cell) (sql-time->time cell))
        ;; array? ;; we can't directly handle array here because
        ;; we don't know whether or not we are returning an array
        ;; or a generic string, and that requires handling from an
        ;; external function!
        (else cell)))

(define (cell->sql-cell cell)
  (cond ((null? cell) dbd:sql-null)
        ((date? cell) (date->sql-timestamp cell))
        ;; ((time? cell) (time->sql-time cell))
        ;; the reverse of array, though, we do know that we are
        ;; passing in an array, and the only sensible way to handle
        ;; an array is to convert it into a array syntax.
        ;; this doesn't guarantee to capture user error, however!!.
        ((list? cell) (cell->pg-array cell))
        ((vector? cell) (cell->sql-cell (vector->list cell)))
        (else cell)))
;; (trace cell->sql-cell)

(define (cell->pg-array x)
  (define (helper rest acc)
    (cond ((null? rest) (string-append "{" (string-join acc ",") "}"))
          ((string? (car rest))
           (helper (cdr rest) (cons (format "~s" (car rest)) acc)))
          ((bytes? (car rest)) (helper (cons (bytes->string/utf-8 (car rest)) (cdr rest))
                                       acc))
          ((number? (car rest)) (helper (cdr rest) (cons (number->string (car rest)) acc)))
          (else (error 'cell->pg-array "unsupported type ~a" (car rest)))))
  (helper x '()))

#|
(define (sql-time->time t)
  (match t
         ((struct dbd:sql-time (hour minute second nanosecond tz))
          (make-time hour minute second nanosecond tz))))

(define (time->sql-time t)
  (match t
         ((struct time (hour minute second nano tz))
          (dbd:make-sql-time hour minute second nano tz))))
;;|#

(define (sql-date->date date)
  (match date
         ((struct dbd:sql-date (year month day))
          (make-date 0 0 0 0 day month day 0))))

(define (sql-timestamp->date ts)
  (match ts
         ((struct dbd:sql-timestamp (year month day hour minute second nanosecond tz))
          (make-date nanosecond second minute hour day month year tz))))

(define (date->sql-timestamp d)
  (dbd:make-sql-timestamp (date-year d)
                          (date-month d)
                          (date-day d)
                          (date-hour d)
                          (date-minute d)
                          (date-second d)
                          (date-nanosecond d)
                          (date-zone-offset d)))

(registry-set! drivers 'spgsql
               (make-driver spgsql-connect
                            spgsql-disconnect
                            spgsql-query
                            spgsql-prepare
                            default-begin
                            default-commit
                            default-rollback))