;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql ;;; ;; Copyright (C) 2007-2016 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. ;; put (use sqlite3) or (use postgresql) in requirements.scm ;; (if (file-exists? "requirements.scm") ;; (include "requirements.scm")) ;; ONLY A LOWEST COMMON DEMOMINATOR IS SUPPORTED! ;; d = db handle ;; t = statement handle ;; s = statement ;; l = proc ;; p = params ;; ;; sqlite3 postgres dbi ;; prepare: (sqlite3:prepare d s) n/a NOT YET ;; for-each (sqlite3:for-each-row l d s . p) (pg:query-for-each l s d) dbi:for-each-row ;; for-each (sqlite3:for-each-row l t . p) n/a NOT YET ;; exec (sqlite3:exec d s . p) (pg:query-tuples s d) ;; exec (sqlite3: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 ;; 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 scheme) (use posix extras data-structures autoload) (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)))) ;; 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) (finalize! sqlite3:finalize! sqlite3-missing) (make-busy-timeout sqlite3:make-busy-timeout sqlite3-missing) (set-busy-handler! sqlite3:set-busy-handler! sqlite3-missing)) (define pg-missing (missing-egg 'pg "postgresql")) (autoload postgresql (connect pg:connect pg-missing) (row-for-each pg:row-for-each pg-missing) (query pg:query pg-missing) #;(escape-string pg:escape-string pg-missing) (disconnect pg:disconnect pg-missing)) (define mysql-missing (missing-egg 'mysql "mysql-client")) (autoload mysql-client (make-mysql-connection mysql:make-connection mysql-missing)) (define (open dbtype dbinit) (make-db dbtype (case dbtype ((sqlite3) (sqlite3: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))) (else (error "Unsupported dbtype " dbtype))))) (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))) ((pg) (pg:row-for-each ;; proc (query conn (apply sqlparam stmt params)))))) (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 ((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)) ;; (pg:row-for-each (lambda (tuple) (set! junk tuple) ) ((pg) (pg:query conn (apply sqlparam stmt params))) ((mysql) (conn (apply sqlparam stmt params))) (else (error "Unsupported dbtype " dbtype))))) (define (close dbh) (let ((dbtype (db-dbtype dbh)) (conn (db-conn dbh))) (case dbtype ((sqlite3) (sqlite3:finalize! conn)) ((pg) (pg:disconnect conn)) ((mysql) (void)) ; The mysql-client egg doesn't support closing... (else (error "Unsupported dbtype " dbtype))))) ;;====================================================================== ;; 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) "'")) ((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)))))) ;;====================================================================== ;; 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))))) )