;;; 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 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 scheme srfi-1 srfi-13)
(use posix extras data-structures 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))))

;; 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 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 sqlite3-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)))
     ((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))))

(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
               (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) (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
      ((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
      ((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)
  (let ((dbtype (db-dbtype dbh))
  (conn   (db-conn dbh)))
    (case dbtype
      ((sqlite3) (apply sqlite3:fold-row proc init conn stmt params))
      ((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 ((sqlite3:statement? dbh)
    (sqlite3:finalize! dbh))
  ((pair? dbh)
    (let ((stmt (conc "DEALLOCATE " (cdr (car dbh)) ";")))
      (exec (car (car dbh)) stmt)))
  ((database? 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) "'"))
   ((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))
        ((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)))))
)