;; (C) 2001 Jörg F. Wittenberger see http://www.askemos.org

;;** XSQL

;; For the time being we only support the xsql-query element.  The
;; original Qracle specification allows the outermost element to
;; specify a connection attribute, which is obviously intented to be
;; reused through the page evaluation.  NYI We better do some smart
;; connection pooling under the hood.

(define *xsql-connections-definitions* #f)

(define *xsql-connections-trusts* #f)

(define max-connection 10)

(define free-connections-mutex (make-mutex 'xsql-db-connections))

(define free-connections '())

(define connection-count
  (make-semaphore 'xsql-connection-count max-connection))

(define (find-connection-spec name)
  (or (table-lookup *xsql-connections-definitions* name)
      (error "XSQL connection '~a' not defined." name)))

(define (init-xsql doc)
  (set! *xsql-connections-definitions* (make-string-table))
  (set! *xsql-connections-trusts* (make-oid-table))
  (let loop ((def ((sxpath '(connection)) doc)))
    (if (not (node-list-empty? def))
        (let ((row (node-list-first def)))
          (table-insert!
           *xsql-connections-definitions*
           (data ((sxpath '(name)) row))
           (list (if (node-list-empty? ((sxpath '(trusts)) row)) #t #f)
                 (data ((sxpath '(driver)) row))
                 (data ((sxpath '(database)) row))
                 (data ((sxpath '(host)) row))
                 (data ((sxpath '(user)) row))
                 (data ((sxpath '(password)) row))))
          (node-list-map
           (lambda (node) (table-insert! *xsql-connections-trusts*
                                         (string->symbol (data node)) #t))
           ((sxpath '(trusts li)) row))
          (loop (node-list-rest def))))))

(define (allocate-connection name)
  (with-mutex
   free-connections-mutex
   (let ((free (assoc name free-connections)))
     (if free
         (begin (set! free-connections
                      (filter (lambda (value) (not (eq? value free)))
                              free-connections))
                free)
         (and
          (not (null? free-connections))
          (let ((con (car free-connections)))
            (set! free-connections (cdr free-connections))
            con))))))

(define (dispose-connection c)
  (with-mutex
   free-connections-mutex
   (set! free-connections (cons c free-connections))))

;; Find the named connection using oid as the identity of the agent
;; and pass it to 'proc', which runs the query.  Wrap 'proc' into an
;; exception handler and properly clean up.

;; Implementation detail: we could rather had the inner 'proc', which
;; processes the results of 'sql-with-tupels' catch all errors and
;; always leave a clean connection behind.  But sql-with-tupels could
;; also raise an exception (though rarely), hence we would have to
;; have two exception handlers installed for each query.  We avoid
;; that at the expense to close the connection is case of error.

;; While postgresql definiately needs to close the connection, I'm not
;; sure whether mysql might actually continue.  We ran comfortable
;; without problems from 2001-2003.

(define (with-connection name oid proc)
  (with-semaphore
   connection-count
   (let* ((conn-spec (find-connection-spec name))
          (conn (allocate-connection name)))
     (if (not (or (car conn-spec)
                  (table-lookup *xsql-connections-trusts* oid)))
         (error "no permissions for data base connection \"~a\"" name))
     (if (and conn (not (string=? name (car conn))))
         (begin (sql-close (cdr conn)) (set! conn #f)))
     (if (not conn)
         (set! conn (cons name (apply sql-connect (cdr conn-spec)))))
     (with-exception-handler
      (lambda (c) (sql-close (cdr conn)) (error c))
      (lambda () (let ((result (proc (cdr conn))))
                   (dispose-connection conn)
                   result))))))

;; My 1st impression from the specification is, that those people did
;; not think for a long time before they wrote it.  Anyway even though
;; I start to hate it, standard is better than better.  XSQL is not
;; standard, but we'll have a better thing later.

(define-macro (oracle-defaulted expr default)
  `(let ((v ,expr))
     (if v
         (and (not (string=? v "")) (string->symbol v))
         ,default)))

(define-transformer xsql-query
  (let* (;; No, we are not to follow the Oracle default here.
         (max-rows (let ((v (attribute-string 'max-rows nl)))
                     (or (and v (string->number v)) 25)))
         (skip-rows (let ((v (attribute-string 'skip-rows nl)))
                      (or (and v (string->number v)) 0)))
         (id-attribute-column
          (let ((att (attribute-string 'id-attribute-column nl)))
            (and att (string->symbol att))))
         (id-attribute (oracle-defaulted
                        (attribute-string 'id-attribute nl)
                        'num))
         (mk-att (if id-attribute
                     (lambda (v) (list (make-xml-attribute id-attribute #f v)))
                     (lambda (v) (empty-node-list))))
         (row-element (oracle-defaulted (attribute-string 'row-element nl)
                                        'row))
         (mk-row (if row-element
                     (lambda (att r)
                       (make-xml-element row-element #f att r))
                     (lambda (att r) r)))
         (rowset-element (oracle-defaulted
                          (attribute-string 'rowset-element nl) 'rowset))
         (mk-set (if rowset-element
                     (lambda (r) (make-xml-element
                                  rowset-element #f (empty-node-list) r))
                     identity))
         ;; TODO fix the mxsql-driver to actually return the value
         (result-node-list (empty-node-list)))
    (with-connection
     (or (attribute-string 'connection nl)
         (error "XSQL missing required attribute 'connection'"))
     (place 'get 'id)
     (lambda (connection)
       (sql-with-tupels
        connection
        (data (xml-walk-down sosofos: (children nl)))
        (lambda (result rows cols)
          (let* ((identifiers (map (lambda (i) (cons (string->symbol
                                                      (sql-field result i))
                                                     i))
                                   (range cols)))
                 (result-rows
                  (if id-attribute-column
                      (filter (lambda (r)
                                (not (eq? id-attribute-column (car r))))
                              identifiers)
                      identifiers))
                 (result-id 
                  (and id-attribute-column
                       (let ((r (filter (lambda (r)
                                          (eq? id-attribute-column (car r)))
                                        identifiers)))
                         (and (pair? r)  (car r))))))
            (let loop ((row (min rows (+ max-rows skip-rows)))
                       (res (empty-node-list)))
              (if (eqv? row skip-rows)
                  (set! result-node-list (mk-set res))
                  (loop
                   (sub1 row)
                   (%node-list-cons
                    (mk-row
                     (mk-att (or (and result-id
                                      (sql-value result (sub1 row)
                                                   (cdr result-id)))
                                 (number->string row)))
                     (map
                      (lambda (c)
                        (make-xml-element
                         (car c) #f (empty-node-list)
                         (make-xml-literal
                          (sql-value result (sub1 row) (cdr c)))))
                      result-rows))
                    res)))))))))
    result-node-list))