#lang scheme/base
(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 (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))
(define (spgsql-query dbh stmt (args '()))
(if (symbol? stmt)
(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)))))
(error 'query "unknown prepared statement ~a" stmt))
(let ((query (make-place-holder-query default-converter stmt)))
(convert-result (send (handle-conn dbh) query
(phq-merge-query query
(phq-map-values query args)))))))
(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))))))
(define (convert-result rs)
(if (dbd:SimpleResult? rs)
(void) (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))
(else cell)))
(define (cell->sql-cell cell)
(cond ((null? cell) dbd:sql-null)
((date? cell) (date->sql-timestamp cell))
((list? cell) (cell->pg-array cell))
((vector? cell) (cell->sql-cell (vector->list cell)))
(else 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-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))