#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
;; yc 10/1/2009 - export SimpleResult from spgsql... (is this necesssary?)
;; yc 11/4/2009 - export 3 drivers (spgsql, spgsql/effect, and spgsql/effect-set)
;; yc 11/5/2009 - add the ability to handle last-insert-id
;;                1 - extend handle to spgsql-handle to take t2s (table-to-sequence) attr
;;                2 - allow the passing in of #:t2s as a parameter.
;;                3 - when passing in #:t2s it'll make an extra query to check the last-inserted-id
;;             - default 'spgsql to 'spgsql/effect

(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"
         )

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct (spgsql-handle handle) (t2s))

(define (filter-t2s/attrs attrs)
  (define (helper rest acc t2s)
    (cond ((null? rest) (values t2s (reverse acc)))
          ((equal? (car rest) '#:t2s)
           (cond ((null? (cdr rest))
                  (error 'connect "invalid attribute ~a - no value" (car rest)))
                 ((not (procedure? (cadr rest))) 
                  (error 'connect "#:t2s must take a procedure of (-> string? string?)"))
                 (else
                  (helper (cddr rest) acc (cadr rest)))))
          (else 
           (helper (cdr rest) (cons (car rest) acc) t2s))))
  (helper attrs '() #f))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; adapters
(define (spgsql-connect driver . attrs)
  (let-values (((loader attrs)
                (filter-file-loader/attrs attrs)))
    (let-values (((t2s attrs)
                  (filter-t2s/attrs attrs)))
      (let ((handle (make-spgsql-handle driver
                                        (apply* dbd:connect attrs)
                                        (make-immutable-hash-registry)
                                        0
                                        t2s)))
        (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)

(define (spgsql-query/effect dbh stmt (args '())) 
  (define (helper rs) 
    (if (dbd:SimpleResult? rs) 
        (make-effect #f 
                     (if (spgsql-handle-t2s dbh) 
                         (if-it (insert-statement? dbh stmt) 
                                (cell/false dbh
                                            "select currval(?seq::regclass)"
                                            `((seq . ,((spgsql-handle-t2s dbh) it))))
                                #f)
                            #f)
                     #f 
                     #f 
                     (dbd:SimpleResult-command rs) 
                     #f)
        rs))
  (helper (spgsql-query dbh stmt args)))

(define (spgsql-query/effect-set dbh stmt (args '()))
  (result-set-or-effect->result-set (spgsql-query/effect dbh stmt args)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; table to sequence mapping.
(define (spgsql-t2s:table_t_table_id_seq table)
  (define (id-name table) 
    (regexp-replace #px"(_t)?$" table "_id_seq"))
  (format "~a_~a" table (id-name table)))

(define (insert-statement? handle stmt) 
  (define (helper stmt) 
    (if-it (regexp-match #px"(?i:insert\\s+(into\\s+)(\\w+))" stmt)
           (caddr it)
           #f))
  (helper (phq-query (prepared-query (registry-ref (handle-query handle) stmt)))))
;; (trace insert-statement?)

;; 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
      (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/pass-thru-effect
               (make-driver spgsql-connect
                            spgsql-disconnect
                            spgsql-query
                            spgsql-prepare
                            default-begin
                            default-commit
                            default-rollback))

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

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

(registry-set! drivers 'spgsql (registry-ref drivers 'spgsql/effect))

(provide (rename-out (dbd:SimpleResult SimpleResult)
                     (dbd:SimpleResult-command SimpleResult-command))
         )

(provide/contract 
 (spgsql-t2s:table_t_table_id_seq (-> string? string?))
 )