;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql
;;;
;; Copyright (C) 2007-2018 Matt Welland
;; Copyright (C) 2016 Peter Bex
;; Redistribution and use in source and binary forms, with or without
;; modification, is permitted.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGE.
;; ONLY A LOWEST COMMON DEMOMINATOR IS SUPPORTED!
;; d = db handle
;; t = statement handle
;; s = statement
;; l = proc
;; p = params
;;
;; sqlite3 postgres dbi
;; prepare: (prepare d s) n/a prepare (sqlite3, pg)
;; for-each (for-each-row l d s . p) (query-for-each l s d) for-each-row
;; for-each (for-each-row l t . p) n/a NOT YET
;; exec (exec d s . p) (query-tuples s d)
;; exec (exec t . p) n/a
;; set to 'pg or 'sqlite3
;; (define dbi:type 'sqlite3) ;; or 'pg
;; (dbi:open 'sqlite3 (list (cons 'dbname fullname)))
;;======================================================================
;; D B I
;;======================================================================
(module dbi
(open db-dbtype db-conn for-each-row get-one get-one-row get-rows
exec close escape-string mk-db now database? with-transaction fold-row
prepare map-row convert prepare-exec get-res
;; TODO: These don't really belong here. Also, the naming is not
;; consistent with the usual Scheme conventions.
pgdatetime-get-year pgdatetime-get-month pgdatetime-get-day
pgdatetime-get-hour pgdatetime-get-minute pgdatetime-get-second
pgdatetime-get-microsecond
pgdatetime-set-year! pgdatetime-set-month! pgdatetime-set-day!
pgdatetime-set-hour! pgdatetime-set-minute! pgdatetime-set-second!
pgdatetime-set-microsecond!
lazy-bool)
(import (chicken base) (chicken process) (chicken file) (chicken time) (chicken string) (chicken format) (chicken time posix) scheme srfi-1 srfi-13)
(import (chicken condition) autoload sql-null)
(define-record-type db
(make-db dbtype dbconn)
db?
(dbtype db-dbtype db-dbtype-set!)
(dbconn db-conn db-conn-set!))
(define (missing-egg type eggname)
(lambda _
(error (printf
"Cannot access ~A databases. Please install the ~S egg and try again." type eggname))))
;; (define (sqlite3:statement? h) #f) ;; dummy - hope it gets clobbered if sqlite3 gets loaded
;; TODO: Make a convenience macro for this?
(define sqlite3-missing (missing-egg 'sqlite3 "sqlite3"))
(autoload sqlite3
(open-database sqlite3:open-database sqlite3-missing)
(for-each-row sqlite3:for-each-row sqlite3-missing)
(execute sqlite3:execute sqlite3-missing)
(with-transaction sqlite3:with-transaction sqlite3-missing)
(finalize! sqlite3:finalize! sqlite3-missing)
(make-busy-timeout sqlite3:make-busy-timeout sqlite3-missing)
(set-busy-handler! sqlite3:set-busy-handler! sqlite3-missing)
(database? sqlite3:database? sqlite3-missing)
(prepare sqlite3:prepare sqlite3-missing)
(fold-row sqlite3:fold-row sqlite3-missing)
(map-row sqlite3:map-row sqlite3-missing)
(statement? sqlite3:statement? sqlite3-missing))
(define sql-de-lite-missing (missing-egg 'sql-de-lite "sql-de-lite"))
(autoload sql-de-lite
(open-database sql:open-database sql-de-lite-missing)
(close-database sql:close-database sql-de-lite-missing)
(for-each-row sql:for-each-row sql-de-lite-missing)
(fold-rows sql:fold-rows sql-de-lite-missing)
(exec sql:exec sql-de-lite-missing)
(fetch-value sql:fetch-value sql-de-lite-missing)
(with-transaction sql:with-transaction sql-de-lite-missing)
(finalize! sql:finalize! sql-de-lite-missing)
(make-busy-timeout sql:make-busy-timeout sql-de-lite-missing)
(set-busy-handler! sql:set-busy-handler! sql-de-lite-missing)
(query sql:query sql-de-lite-missing)
(sql sql:sql sql-de-lite-missing))
(define pg-missing (missing-egg 'pg "postgresql"))
(autoload postgresql
(connect pg:connect pg-missing)
(row-for-each pg:row-for-each pg-missing)
(with-transaction pg:with-transaction pg-missing)
(query pg:query pg-missing)
;;(escape-string pg:escape-string pg-missing)
(disconnect pg:disconnect pg-missing)
(connection? pg:connection? pg-missing)
(row-fold pg:row-fold pg-missing)
(row-map pg:row-map pg-missing)
(affected-rows pg:affected-rows pg-missing)
(result? pg:result? pg-missing))
(define mysql-missing (missing-egg 'mysql "mysql-client"))
(autoload mysql-client
(make-mysql-connection mysql:make-connection mysql-missing)
(mysql-null? mysql:mysql-null? mysql-missing))
(define (open dbtype dbinit)
(make-db
dbtype
(case dbtype
((sqlite3) (sqlite3:open-database (alist-ref 'dbname dbinit)))
((sql-de-lite) (sql:open-database (alist-ref 'dbname dbinit)))
((pg) (pg:connect dbinit))
((mysql) (mysql:make-connection (alist-ref 'host dbinit)
(alist-ref 'user dbinit)
(alist-ref 'password dbinit)
(alist-ref 'dbname dbinit)
port: (alist-ref 'port dbinit)))
(else (error "Unsupported dbtype " dbtype)))))
(define (convert dbh)
(cond
((database? dbh) dbh)
((sqlite3:database? dbh) (make-db 'sqlite3 dbh))
((pg:connection? dbh) (make-db 'pg dbh))
((not mysql:mysql-null?) (make-db 'mysql dbh))
(else (error "Unsupported database handle " dbh))))
(define (for-each-row proc dbh stmt . params)
(let ((dbtype (db-dbtype dbh))
(conn (db-conn dbh)))
(case dbtype
((sqlite3) (sqlite3:for-each-row
(lambda (first . remaining)
(let ((tuple (list->vector (cons first remaining))))
(proc tuple)))
conn
(apply sqlparam stmt params)))
((sql-de-lite)(apply sql:query (sql:for-each-row
(lambda (row)
(proc (list->vector row))))
(sql:sql conn stmt)
params))
((pg) (pg:row-for-each
(lambda (tuple)
(proc (list->vector tuple)))
(pg:query conn (apply sqlparam stmt params))))
((mysql) (let* ((replaced-sql (apply sqlparam stmt params))
(fetcher (conn replaced-sql)))
(fetcher (lambda (tuple)
(proc (list->vector tuple))))))
(else (error "Unsupported dbtype " dbtype)))))
;; common idiom is to seek a single value, #f if no match
;; NOTE: wish to return first found. Do the set only if not set
(define (get-one dbh stmt . params)
(let ((dbtype (db-dbtype dbh))
(conn (db-conn dbh)))
(case dbtype
((sql-de-lite)
(apply sql:query sql:fetch-value (sql:sql conn stmt) params))
(else
(let ((res #f))
(apply for-each-row
(lambda (row)
(if (not res)
(set! res (vector-ref row 0))))
dbh
stmt
params)
res)))))
;; common idiom is to seek a single value, #f if no match
;; NOTE: wish to return first found. Do the set only if not set
(define (get-one-row dbh stmt . params)
(let ((res #f))
(apply for-each-row
(lambda (row)
(if (not res)
(set! res row)))
dbh
stmt
params)
res))
;; common idiom is to seek a list of rows, '() if no match
(define (get-rows dbh stmt . params)
(let ((res '()))
(apply for-each-row
(lambda (row)
(set! res (cons row res)))
dbh
stmt
params)
(reverse res)))
(define (exec dbh stmt . params)
(let ((dbtype (db-dbtype dbh))
(conn (db-conn dbh))
(junk #f))
(case dbtype
((sqlite3) (apply sqlite3:execute conn stmt params))
((sql-de-lite)(apply sql:exec (sql:sql conn stmt) params))
((pg) (pg:query conn (apply sqlparam stmt params)))
((mysql) (conn (apply sqlparam stmt params)))
(else (error "Unsupported dbtype " dbtype)))))
(define (with-transaction dbh proc)
(let ((dbtype (db-dbtype dbh))
(conn (db-conn dbh)))
(case dbtype
((sql-de-lite)(sql:with-transaction conn proc))
((sqlite3) (sqlite3:with-transaction
conn
(lambda () (proc))))
((pg) (pg:with-transaction
conn (lambda () (proc))))
((mysql)
(conn "START TRANSACTION")
(conn proc)
(conn "COMMIT"))
(else (error "Unsupported dbtype " dbtype)))))
(define (prepare dbh stmt)
(let ((dbtype (db-dbtype dbh))
(conn (db-conn dbh)))
(case dbtype
((sql-de-lite) dbh) ;; nop?
((sqlite3) (sqlite3:prepare conn stmt))
((pg) (exec dbh stmt) (cons (cons dbh (cadr (string-split stmt))) '()))
((mysql) (print "WIP"))
(else (error "Unsupported dbtype" dbtype)))))
(define (fold-row proc init dbh stmt . params) ;; expecting (proc init/prev res)
(let ((dbtype (db-dbtype dbh))
(conn (db-conn dbh)))
(case dbtype
((sql-de-lite) (apply sql:query (sql:fold-rows proc init)
(sql:sql conn stmt) params))
((sqlite3) (let ((newproc (lambda (prev . rem)
(proc rem prev))))
(apply sqlite3:fold-row newproc init conn stmt params))) ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS)
((pg) (pg:row-fold proc init (exec dbh stmt params)))
((mysql) (fold proc '() (get-rows dbh stmt)))
(else (error "Unsupported dbtype" dbtype)))))
(define (map-row proc init dbh stmt . params)
(let ((dbtype (db-dbtype dbh))
(conn (db-conn dbh)))
(case dbtype
((sqlite3) (apply sqlite3:map-row proc conn stmt params))
((pg) (pg:row-map proc (exec dbh stmt params)))
((mysql) (map proc (get-rows dbh stmt)))
(else (error "Unsupported dbtype" dbtype)))))
(define (prepare-exec stmth . params)
(if (sqlite3:statement? stmth)
(apply sqlite3:execute stmth params))
(if (pair? stmth)
(let* ((dbh (car (car stmth)))
(dbtype (db-dbtype dbh))
(conn (db-conn dbh))
(stmth-name (string->symbol (cdr (car stmth)))))
(apply pg:query conn stmth-name params))))
(define (get-res handle option)
(if (pg:result? handle)
(case option
((affected-rows) (pg:affected-rows handle)))))
(define (close dbh)
(cond
((database? dbh)
(let ((dbtype (db-dbtype dbh))
(conn (db-conn dbh)))
(case dbtype
((sql-de-lite) (sql:close-database conn))
((sqlite3) (sqlite3:finalize! conn))
((pg) (pg:disconnect conn))
((mysql) (void)) ; The mysql-client egg doesn't support closing...
(else (error "Unsupported dbtype " dbtype)))))
((pair? dbh)
(let ((stmt (conc "DEALLOCATE " (cdr (car dbh)) ";")))
(exec (car (car dbh)) stmt)))
((sqlite3:statement? dbh) ;; do this last so that *IF* it is a proper dbh it will be closed above and the sqlite3:statement? will not be called
(sqlite3:finalize! dbh))
))
;;======================================================================
;; D B M I S C
;;======================================================================
(define (escape-string str)
(let ((parts (split-string str "'")))
(string-intersperse parts "''")))
;; (pg:escape-string val)))
;; convert values to appropriate strings
;;
(define (sqlparam-val->string val)
(cond
((list? val)(string-intersperse (map conc val) ",")) ;; (a b c) => a,b,c
((string? val)(string-append "'" (escape-string val) "'"))
((sql-null? val) "NULL")
((number? val)(number->string val))
((symbol? val)(sqlparam-val->string (symbol->string val)))
((boolean? val)
(if val "TRUE" "FALSE")) ;; should this be "TRUE" or 1?
;; should this be "FALSE" or 0 or NULL?
((vector? val) ;; 'tis a date NB// 5/29/2011 - this is badly borked BUGGY!
(sqlparam-val->string (time->string (seconds->local-time (current-seconds)))))
(else
(error "sqlparam: unknown type for value: " val)
"")))
;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20)
;; NB// 1. values only!!
;; 2. terminating semicolon required (used as part of logic)
;;
;; a=? 1 (number) => a=1
;; a=? 1 (string) => a='1'
;; a=? #f => a=FALSE
;; a=? a (symbol) => a=a
;;
(define (sqlparam query . args)
(let* ((query-parts (string-split query "?"))
(num-parts (length query-parts))
(num-args (length args)))
(if (not (= (+ num-args 1) num-parts))
(error "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query)
(if (= num-args 0) query
(let loop ((section (car query-parts))
(tail (cdr query-parts))
(result "")
(arg (car args))
(argtail (cdr args)))
(let* ((valstr (sqlparam-val->string arg))
(newresult (string-append result section valstr)))
(if (null? argtail) ;; we are done
(string-append newresult (car tail))
(loop
(car tail)
(cdr tail)
newresult
(car argtail)
(cdr argtail)))))))))
;; a poorly written but non-broken split-string
;;
(define (split-string strng delim)
(if (eq? (string-length strng) 0) (list strng)
(let loop ((head (make-string 1 (car (string->list strng))))
(tail (cdr (string->list strng)))
(dest '())
(temp ""))
(cond ((equal? head delim)
(set! dest (append dest (list temp)))
(set! temp ""))
((null? head)
(set! dest (append dest (list temp))))
(else (set! temp (string-append temp head)))) ;; end if
(cond ((null? tail)
(set! dest (append dest (list temp))) dest)
(else (loop (make-string 1 (car tail)) (cdr tail) dest temp))))))
(define (database? dbh)
(if (db? dbh)
(let ((dbtype (db-dbtype dbh))
(conn (db-conn dbh)))
(case dbtype
((sqlite3) (if (sqlite3:database? conn) #t #f))
((sql-de-lite) #t) ;; don't know how to test for database
((pg) (if (pg:connection? conn) #t #f))
((mysql) #t)
(else (error "Unsupported dbtype " dbtype)))) #f))
;;======================================================================
;; Convienence routines
;;======================================================================
;; make a db from a list of statements or open it if it already exists
(define (mk-db path file stmts)
(let* ((fname (conc path "/" file))
(dbexists (file-exists? fname))
(dbh (if dbexists (open 'sqlite3 (list (cons 'dbname fname))) #f)))
(if (not dbexists)
(begin
(system (conc "mkdir -p " path)) ;; create the path
(set! dbh (open 'sqlite3 (list (cons 'dbname fname))))
(for-each
(lambda (sqry)
(exec dbh sqry))
stmts)))
(sqlite3:set-busy-handler!
(db-conn dbh) (sqlite3:make-busy-timeout 1000000))
dbh))
(define (now dbh)
(let ((dbtype (db-dbtype dbh)))
(case dbtype
((sqlite3) "datetime('now')")
;; Standard SQL
(else "now()"))))
(define (make-pgdatetime)(make-vector 7))
(define (pgdatetime-get-year vec) (vector-ref vec 0))
(define (pgdatetime-get-month vec) (vector-ref vec 1))
(define (pgdatetime-get-day vec) (vector-ref vec 2))
(define (pgdatetime-get-hour vec) (vector-ref vec 3))
(define (pgdatetime-get-minute vec) (vector-ref vec 4))
(define (pgdatetime-get-second vec) (vector-ref vec 5))
(define (pgdatetime-get-microsecond vec) (vector-ref vec 6))
(define (pgdatetime-set-year! vec val)(vector-set! vec 0 val))
(define (pgdatetime-set-month! vec val)(vector-set! vec 1 val))
(define (pgdatetime-set-day! vec val)(vector-set! vec 2 val))
(define (pgdatetime-set-hour! vec val)(vector-set! vec 3 val))
(define (pgdatetime-set-minute! vec val)(vector-set! vec 4 val))
(define (pgdatetime-set-second! vec val)(vector-set! vec 5 val))
(define (pgdatetime-set-microsecond! vec val)(vector-set! vec 6 val))
;; takes postgres date or timestamp
(define (pg-date->string pgdate)
(conc (pgdatetime-get-month pgdate) "/"
(pgdatetime-get-day pgdate) "/"
(pgdatetime-get-year pgdate)))
;; takes postgres date or timestamp
(define (pg-datetime->string pgdate)
(conc (pgdatetime-get-month pgdate) "/"
(pgdatetime-get-day pgdate) "/"
(pgdatetime-get-year pgdate) " "
(pgdatetime-get-hour pgdate) ":"
(pgdatetime-get-minute pgdate)`))
;; map to 0 or 1 from a range of values
;; #f => 0
;; #t => 1
;; "0" => 0
;; "1" => 1
;; FALSE => 0
;; TRUE => 1
;; anything else => 1
(define (lazy-bool val)
(case val
((#f) 0)
((#t) 1)
((0) 0)
((1) 1)
(else
(cond
((string? val)
(let ((nval (string->number val)))
(if nval
(lazy-bool nval)
(cond
((string=? val "FALSE") 0)
((string=? val "TRUE") 1)
(else 1)))))
((symbol? val)
(lazy-bool (symbol->string val)))
(else 1)))))
)