;------------------------------------------------------------------------
;			Database access tools
;
; A major procedure: DB1:fold-left PROC INITIAL-SEED QUERY-OBJECT
; A QUERY-OBJECT (which in this implementation is a list of fragments
; that make a SQL statement, in the reverse order -- without the
; terminating semi-colon) is submitted to the database, using the
; default database connection.
;
; PROC is a procedure: SEED COL COL ...
; The procedure PROC takes 1+n arguments where n is the 
; number of columns in the the table returned by the query.
; The procedure PROC must return two values: CONTINUE? NEW-SEED
;
; The query is executed, and the PROC is applied to each returned row
; in order. The first invocation of PROC receives INITIAL-SEED as its
; first argument. Each following invocation of PROC receives as the
; first argument the NEW-SEED result of the previous invocation of
; PROC.  The CONTINUE? result of PROC is an early termination flag. If
; that flag is returned as #f, any further applications of PROC are
; skipped and DB1:fold-left finishes.  The function DB1:fold-left
; returns NEW-SEED produced by the last invocation of PROC. If the
; query yielded no rows, DB1:fold-left returns the INITIAL-SEED.
;
; Thus DB1:fold-left is identical to the left fold over a sequence,
; modulo the early termination.
;
; There are a few minor variants of the above procedure, optimized
; for common particular cases:
;
; A minor procedure: DB1:for-singleton PROC QUERY-OBJECT
; A QUERY-OBJECT is submitted to the database, using the current
; connection.  The query is expected to return a table of at most one
; row. PROC is a procedure that takes as many arguments as the number
; of columns in that table. If the query returns a non-empty table,
; PROC is applied to the singleton row. The result from PROC is
; returned. If the query yields an empty table, the DB:for-singleton
; function returns #f.
;
; A minor procedure: DB1:assoc-val QUERY-OBJECT
; A QUERY-OBJECT is submitted to the database, using the current
; database connection. The query is expected to return at most one
; data value (that is, a table of at most one row and exactly one
; column).  That value is returned. If the query returns no value, the
; procedure returns #f. Note _this_ particular function does not
; distinguish between a query yielding no value and a query that
; yields a FALSE value. You need to use a more general
; DB1:for-singleton above if this distinction is important.
;
; A minor procedure: DB:imperative-stmt STRING1...
; STRING1 (and the following strings, if any) are concatenated
; together to form a DDL or DML statement(s) (like INSERT, UPDATE)
; that are not expected to return any value. Several statements (each
; terminated with semi-colons) may be submitted this way, via a single
; invocation of DB:imperative-stmt.  The statements are submitted to
; the database server, and the procedure returns immediately after
; that. The server executes the statements concurrently, which may
; take quite a while. Again, the procedure does _not_ wait for the
; server to finish processing of the statement(s).
; 
;
; Why there is no DB1:fold-right?
; Because fold-right (often called just fold) is not tail recursive. If
; the query returns many rows, you may blow the stack. Furthermore, in
; 	(fold-left f z0 lst)
; function f is first invoked with the original seed z0 and the _first_
; element of lst. In
; 	(fold-right f z0 lst)
; the first invocation of f with the original seed is with the _last_
; element of lst.
;
; IMPORT
; The platform-specific prelude (myenv.scm, myenv-bigloo.scm, etc).
; OS/POSIX time conversion functions
; db-util.scm and input-parse.scm for DB1:* functions
;
; $Id: db-util1.scm,v 2.6 2005/01/28 22:51:57 oleg Exp oleg $


; Suggestions for future versions:
; In a value, add subquery, so I can write
; and: '(subquery ....)
;    COLUMNS ::= '* | (<col-arg> <col-arg> ...)
;                (FIRST: n <COLUMNS>)
;                (UNIQUE: <COLUMNS>)
;                (DISTINCT: <COLUMNS>)
; (count [ALL|DISTINCT|UNIQUE] val) collection of functions
; (substring a n m) => a[n,m] function
; <condition>
; (null? col) => col is null
;
; Useful utilities

; Left fold with delimiters
;  fold-left-delim proc delim1 delim-next accum [] = accum
;  fold-left-delim proc delim1 delim-next accum (x:xs) = 
;    fold-left (\seed x -> proc x (delim-next:seed)) (proc x (delim1:accum)) xs
(define (fold-left-delim proc delim1 delim-next accum lst)
  (let loop ((lst lst) (delim delim1) (accum accum))
    (if (null? lst) accum
	(loop (cdr lst) delim-next
	      (proc (car lst) (cons delim accum))))))

; append lst in reverse order to the accum
(define (append-rev lst accum)
  (if (null? lst) accum (append-rev (cdr lst) (cons (car lst) accum))))

; Test if lst is the list of exactly two elements
(define (list-of-two? lst)
  (and (pair? lst) (pair? (cdr lst)) (null? (cddr lst))))




;------------------------------------------------------------------------
; Make a list of ATOMs (STRINGs or CHARs or NUMBERs) that together make
; a SELECT statement (without any terminator!)
;
; procedure: DB:make-query COLUMNS . ARGS
;
; where
;    COLUMNS ::= '* | (<col-arg> <col-arg> ...)
;    <col-arg> ::= <val> | (AS <val> <name>)
;    <name> ::= <symbol>
;
; and ARGS is a list of the following keyword parameters;
; The keyword parameter 'from:' must come first (therefore, it doesn't have
; to be a keyword parameter, but making it so improves readability).
; If a particular Scheme systems lacks DSSSL-style keywords, one needs to
;	(define from: 'from:)
; No changes to the code below is necessary.
;
;    from: <table> | (<table-spec> <table-spec> ...)
;    <table> ::= <name>
;    <table-spec> ::= <table> | (ALIAS <table-spec> <table>) | (TABLE <val>)
;
; The last alternative in <table-spec> is for table expressions
; (present in Informix)
;
;    and: #f                 ; ignored
;    and: ()                 ; ignored
;    and: <val>		     ; must be a boolean value, semantically
;
;    query-modifiers: #f | () | <atom> | (<atom> ...)
;
; query-modifiers:, if present, must appear after all and: parameters.
; <val> is defined below (see DB:add-val).
;
; Return: the list of strings or other atoms.

(define (DB:make-query columns . args)

  ; Process one col-arg and add the corresponding SQL fragments
  ; to accum, in reverse order
  (define (process-col-arg col-arg accum)
    (cond
     ((not (pair? col-arg))   ; an atom
      (DB:add-val col-arg accum))
     ((eq? 'AS (car col-arg))   ; (AS <val> <name>)
      (assert (list-of-two? (cdr col-arg)) (symbol? (caddr col-arg)))
      (cons* (caddr col-arg) " AS " (DB:add-val (cadr col-arg) accum)))
     (else
      (DB:add-val col-arg accum))))

  ; Process column-specs and add the corresponding SQL fragments
  ; to accum, in reverse order
  (define (process-column-specs col-specs accum)
    (cond
     ((eq? '* col-specs) (cons " *" accum))
     ((not (pair? col-specs))
      (error "col-spec must be a non-empty list: " col-specs))
     (else
      (fold-left-delim process-col-arg #\space #\, accum col-specs))))

  ; Process one table-spec and add the corresponding SQL fragments
  ; to accum, in reverse order
  ;    <table-spec> ::= <table> | (ALIAS <table> <table>) | (TABLE <val>)
  (define (process-table-spec table-spec accum)
    (cond
     ((symbol? table-spec) (cons table-spec accum))
     ((not (pair? table-spec))
      (error "Bad table-spec: " table-spec))
     ((and
	(eq? 'ALIAS (car table-spec))
	(pair? (cdr table-spec))
	(pair? (cddr table-spec))
	(symbol? (caddr table-spec))
	(null? (cdddr table-spec)))
      (cons* (caddr table-spec) #\space 
	(process-table-spec (cadr table-spec) accum)))
     ((and
	(eq? 'TABLE (car table-spec))	; A table expression
	(list-of-two? table-spec))
       (DB:add-val `(apply TABLE ,(cadr table-spec)) accum))
     (else
       (error "Bad table-spec: " table-spec))))

  ; Process table-spec and add the corresponding SQL fragments
  ; to accum, in reverse order
  (define (process-table-specs table-specs accum)
    (cond
     ((pair? table-specs)
      (fold-left-delim process-table-spec #\space #\, accum table-specs))
     (else (process-table-spec table-specs (cons #\space accum)))))
 
  ; Main body
  (let*-values
      (((accum) '("SELECT"))
       ((accum) (process-column-specs columns accum))

       ((dummy) (assert (pair? args) (eq? (car args) from:)
		      (pair? (cdr args))))
       ((accum) (process-table-specs (cadr args) (cons " FROM" accum)))
       ((args) (cddr args))

       ; handle and: groups
       ((args accum)
	(let loop ((args args) (delim " WHERE ") (accum accum))
	  (if (or (null? args) (not (eq? and: (car args))))
	      (values args accum)
	      (let ((and-condition
		     (begin (assert (pair? (cdr args)))
			    (cadr args))))
		(if (or (not and-condition) (null? and-condition))
		    (loop (cddr args) delim accum) ; skip #f and '() conditions
		    (loop (cddr args)
			  " AND "
			  (DB:add-val and-condition (cons delim accum))))))))

       ; handle the query-modifier:
       ((args accum)
	(cond
	 ((null? args) (values args accum))
	 (else
	  (assert (list-of-two? args) (eq? (car args) query-modifier:))
	  (let ((query-modifier (cadr args)))
	    (values (cddr args)
	       (cond
		((not query-modifier) accum)
		((null? query-modifier) accum)
		((pair? query-modifier)
		 (append-rev query-modifier (cons #\space accum)))
		(else (cons query-modifier (cons #\space accum)))))))))
       )
      (assert (null? args))  ; make sure all args are consumed
    accum)
 )

; Process a term <val> and add the corresponding fragments to
; the list of SQL fragments in reverse order
;
; procedure: DB:add-val TERM ACCUM
;
; where TERM must follow the production for <val> (see below)
; and ACCUM is the list of SQL fragments accumulated so far.
;
; The result is the list of SQL fragments with the new fragments
; prepended.
;
;    <val> ::= <atom> | <application> | (list <val> <val> ...)
;                     | (enquote <atom> ...)
;                     | (quote <atom>) 
;                     | (twobars <atom> ...) 
;		      | <condition>
;    <condition> ::= (<relop> <val> <val>) |
;                    (between <val1> <val2> <val3>) |
;                    (in-bbox <lat-val> <lon-val> <bbox-val>) |
;                    (not <condition>) |
;                    (or <condition> <condition> ...) 
;                    (and <condition> <condition> ...)
;                    <application> ; application of a boolean fn
;                    (exists <subquery>)
;    <application> ::= (apply <name> <val> ...)
;    <relop> ::= = | <> | < | > | <= |>= | in | like 
;
; In the form (quote <atom>), the <atom> in question is typically
; inserted by a quasiquote. The idiom is then
; (DB:make-query ... and: `(= col1 ',var)
; The value of var will be inserted by the Scheme system,
; We pass this value to DB:<- for quotation and screening out
; dangerous symbols.
; In contrast, (enquote <atom> ...) simply concatentates the atoms
; and puts the quite around them. The enquote form does not do any
; quotation nor examination of its arguments
; twobars is a concatenation op, ||
; (between <val1> <val2> <val3>) is true if <val2> is between <val1>
; and <val3>
; (in-bbox <lat-val> <lon-val> <bbox-val>) is an ad hoc but rather
; useful relational operation: see DB:in-bbox-condition.
;
; Note that the SQL grammar (at least in the Informix manual) permits
; function applications as `conditions', connectible with `AND' or `OR'.
;
; <subquery> is the list of items that has the same format as the
; argument list to DB:make-query.


(define (DB:add-val term accum)

  ; Process an application and add the corresponding SQL fragments
  ; to accum, in reverse order
  ;    <application> ::= (apply <name> <val> ...)
  (define (process-application app accum)
    (assert (pair? app) (symbol? (car app)))
    (if (pair? (cdr app))
      (process-val (cons 'list (cdr app)) (cons (car app) accum))
      (cons* "()" (car app) accum)	; apply function of zero arity
      ))

  ; Process a condition and add the corresponding SQL fragments
  ; to accum, in reverse order.
  (define (process-condition condition accum)
    (assert (pair? condition))
    (case (car condition)
      ((= > < >= <= in like <>)		; <relop>
       (assert (list-of-two? (cdr condition)))
       (process-val (caddr condition)   ; keep in mind the reverse order!
		    (cons* #\space (car condition) #\space
			   (process-val (cadr condition) accum))))
      ((between)		        ; val1 val2 val3
       (let*-values (((val1 val2 val3) (apply values (cdr condition))))
	 (process-val val3 
	   (cons " AND "
	     (process-val val1 (cons " BETWEEN " (process-val val2 accum)))))))
      ((in-bbox)
	(DB:in-bbox-condition condition accum))
      ((not)				; (NOT condition)
       (assert (list-of-two? condition))
       (process-condition (cadr condition) (cons "NOT " accum)))
      ((or)
       (assert (pair? (cdr condition))) ;at least one disjunction must be there
       (cons "))"
	 (fold-left-delim
	  process-condition "(" ") OR (" (cons #\( accum) (cdr condition))
	 ))
      ((and)
       (assert (pair? (cdr condition))) ;at least one conjunction must be there
       (cons "))"
	 (fold-left-delim
	  process-condition "(" ") AND (" (cons #\( accum) (cdr condition))
	 ))
      ((exists)
	(let ((subquery (apply DB:make-query (cdr condition))))
	  (cons ")" (append subquery (cons "EXISTS (" accum)))))
      ((apply) (process-application (cdr condition) accum))
      (else
       (error "Bad 'val': " condition))))

  (define (process-val val accum)
    (if (not (pair? val)) (cons val accum)
      (case (car val)
	((apply) (process-application (cdr val) accum))
	((list)
	  (assert (pair? (cdr val)))    ; at least one elem is expected
	  (cons #\)
	    (fold-left-delim process-val #\( #\, accum (cdr val))))
	((enquote)
	  (cons #\' (append-rev (cdr val) (cons #\' accum))))
	((quote)
	  (assert (list-of-two? val))
	  (process-val (DB:<- (cadr val)) accum))
	((twobars)
	  (fold-left-delim cons "" " || " accum (cdr val)))
	(else
	  (process-condition val accum)))))

  (process-val term accum))



; procedure: DB:in-bbox-condition IN-BBOX-CONDITION ACCUM -> ACCUM
; 
; processes the in-bbox condition and adds the corresponding
; fragments to the accum, in reverse order. 
; 
; <in-bbox-condition> ::= (in-bbox <lat-val> <lon-val> <bbox-val>)
; <bbox-val> ::= vector N-LAT W-LON S-LAT E-LON
;
; The in-bbox condition checks if a point <lat-val> <lon-val> lies
; within the geodetic bounding box <bbox-val>.
; This is a very useful condition in Metcast.
;
; The parameters N-LAT W-LON S-LAT E-LON are values, eventually signed
; floating-point numbers, in degrees. The plus sign of the numbers
; corresponds to the Northern and Eastern hemispheres resp. It's
; assumed that N-LAT >= S-LAT. The left-lon (W-LON) may however be
; greater than the right-lon (E-LON).  For example, a range of
; longitudes [-170,170] specifies the entire world but Indonesia. On
; the other hand, the range [170,-170] includes Indonesia only. By the
; same token, [-10,10] pertains to a 21-degree longitude stip along
; the Greenwich meridian. But [10,-10] specifies the whole globe _but_
; the strip above.
;
; The in-bbox condition is equivalent to the following:
;       lat BETWEEN s-lat AND n-lat AND lon-criterion
; where the lon-criterion is
;	lon BETWEEN w-lon AND e-lon, if e-lon >= w-lon
;	NOT (lon BETWEEN e-lon AND w-lon) if e-lon < w-lon
; For example, if leftlon (w-lon) = 10, rightlon (e-lon) = 20:
; lon = 15 belongs, while lon = 0 doesn't;
; if leftlon (w-lon) = 20 and rightlon = 10, then lon = 15
; does not belong, while lon = 0, lon = -170, lon = 100, etc. all do.

(define (DB:in-bbox-condition in-bbox-term accum)
  (let*-values
    (((in-bbox-word lat lon bbox) (apply values in-bbox-term))
     ((_)            (assert (vector? bbox)))
     ((top-lat)      (vector-ref bbox 0))
     ((left-lon)     (vector-ref bbox 1))
     ((bottom-lat)   (vector-ref bbox 2))
     ((right-lon)    (vector-ref bbox 3))
    )
    (if (and (number? top-lat) (number? bottom-lat)
	     (number? left-lon) (number? right-lon))
	; Specialization for the case of the known BBOX
      (let*
	((accum
	   (cons* top-lat " AND " bottom-lat
	     " BETWEEN " (DB:add-val lat accum)))
	 (lon (if (symbol? lon) lon (DB:add-val lon '())))
	 (accum
	   (if (<= left-lon right-lon)
	     (cons*
	       right-lon '<= lon " AND " left-lon '>=  lon " AND " accum)
	     (cons*
	       ")" left-lon '< lon " AND " right-lon '> lon 
	       " AND NOT (" accum))))
	accum)
      ; General case. BBOX is statically unknown
      (DB:add-val
	`(and (between ,bottom-lat ,lat ,top-lat)
	   (or (and (>= ,right-lon ,left-lon)
		    (>= ,lon ,left-lon) (<= ,lon ,right-lon))
	       (and (< ,right-lon ,left-lon)
		 (not (and (> ,lon ,right-lon) (< ,lon ,left-lon))))))
	accum))
    ))


; Convert the SQL fragment object (e.g., a query object) to a string.
;
; procedure: DB:sqlfragment->string FRAGMENT-OBJECT
;
; The output is a string. It does not contain any terminator!

(define (DB:sqlfragment->string fragments)
  (with-output-to-string
    (lambda () (for-each display (reverse fragments)))))


; Conversion functions

; Convert a tstamp in EPOCH seconds to a quoted DB timestamp
(define (DB:<-datetime tstamp)
  (OS:cftime "'%Y-%m-%d %H:%M:%S'" tstamp))

; Convert a tstamp in EPOCH seconds to a quoted DB timestamp
; (to-minutes precision)
(define (DB:<-datetime-to-minutes tstamp)
  (OS:cftime "'%Y-%m-%d %H:%M'" tstamp))

; Convert a tstamp in EPOCH seconds to a quoted DB time point
; Time points are defined in a spatial datablade
(define (DB:<-datetime-pt tstamp)
  (OS:cftime "'(%Y-%m-%d %H:%M:%S)'" tstamp))

; Convert a value to a database format
; Return either a number or a list: (enquote fragment ...)
;
; If the value is a string, complain about bad characters  (like #\newline,
; #\return and control characters).  The result of this function may
; then safely be used inside a SQL statement; a user has no way then
; to sneak in his own SQL code (by supplying, for example, a
; value like "'; DELETE * from table where not name ='"

(define (DB:<- val)
  ; Return the position of a character in str that needs quoting.
  ; A character that needs quoting is either an apostrophe or a backslash.
  ; If we come across a bad character, we raise an error.
  ; start-pos is the position in str we start scanning from
  (define (find-bad-char str start-pos)
    (let loop ((i start-pos))
      (and (< i (string-length str))
	   (let ((c (string-ref str i)))
	     (cond
	      ((char-alphabetic? c) (loop (++ i)))
	      ((char-numeric? c)    (loop (++ i)))
	      ((char=? c #\')       i)
	      ((char=? c #\\ )      i)
	      ((and (char>=? c #\space) (char<=? c #\~)) (loop (++ i)))
	      (else 
	       (error "Invalid character in a str: " (char->integer c))))))
      ))

  (cond
   ((number? val) val)		; self-evaluating
   ((string? val)
    (let ((needs-quoting-pos (find-bad-char val 0)))
      (if (not needs-quoting-pos) (list 'enquote val)
	  (cons* 'enquote
		 (substring val 0 needs-quoting-pos)
		 (let loop ((pos needs-quoting-pos))
		   (if (not pos) '()
		       (let ((new-quoting-pos (find-bad-char val (++ pos))))
			 (cons
			  (case (string-ref val pos)
			    ((#\') "''")
			    ((#\\ ) "\\\\")
			    (else (assert #f val pos))) ; can't happen
			  (cons
			   (substring val (++ pos)
				      (or new-quoting-pos (string-length val)))
			   (loop new-quoting-pos))))))))))
   ((symbol? val) (DB:<- (symbol->string val)))
   ((char? val) (DB:<- (string val)))
   (else (error "DB:<- : wrong val: " val))
   )
)


;------------------------------------------------------------------------
;			Executing queries


; Execute the query and left-fold over the sequence of resulting
; rows. This procedure is based on DB:for-each of db-util.scm
; In fact, it requires db-util.scm for DB:output-port and similar
; database environment.

(define (DB1:fold-left proc seed query-object)

  ; Process the result of the SQL query from DB:PIPE-FROM-SQL.
  (OS:within-timeout 
   DB:TIMEOUT
   (lambda ()
     ; Execute SQL statement by sending it to the database server.
     (display "unload to "      DB:output-port)
     (display DB:PIPE-FROM-SQL  DB:output-port)
     (display " delimiter '|' " DB:output-port)
     (for-each (lambda (stmt) (display stmt DB:output-port)) 
	       (reverse query-object))
     (display #\; DB:output-port)   ; terminate the statement
     
     (flush-output DB:output-port)

     (call-with-input-file DB:PIPE-FROM-SQL 
       (lambda (port)
	 (let loop ((curr-row (list seed)))
	   (cond
	    ((eof-object? (peek-char port))
	     (car curr-row))    ; that is, seed
	    (else
	     (let ((token (next-token '() '(#\|) "" port)))
	       (assert (eq? #\| (read-char port)))
	       (cond 
		((char=? (peek-char port) #\newline)
		 (read-char port)		; consume the newline
		 (let*-values
		  (((continue? seed)
		    (apply proc (reverse (cons token curr-row)))))
		  (cond
		   (continue? (loop (list seed)))
		   (else
		    (skip-until '(*eof*) port)
		    seed))))
		(else (loop (cons token curr-row))))))
	    )))))))

; A variant of the previous function, when we expect
; at most one row in the result
(define (DB1:for-singleton proc query-object)
  (apply DB:for-singleton (cons proc (reverse (cons #\; query-object)))))

; A variant of the previous function, in a case when we expect at
; most one row in the result
(define (DB1:assoc-val query-object)
  (apply DB:assoc-val (reverse (cons #\; query-object))))

;------------------------------------------------------------------------
;		               Parsing
; Parsing functions for certain Database datatypes.
; At present, we parse external representation of SET{} datatypes, 
; provided by Informix.

; Parse a set-of-numbers
; Given a string such as "SET{}" or "SET{850.0000000000,1000.000000000}"
; return the list of the corresponding values, in the same order.
; The input string is an external representation for values of
; Informix datatype SETOF(number).
;
; More formally, the input string has the format
; "SET{}"  (empty set)
; "SET{number[,number]*}"
; Each number is a floating-point number (which could be read by a procedure
; 'read')

(define (DB1:parse-set-of-numbers setstr)
  (call-with-input-string setstr
    (lambda (port)
      (let ((header (read-string 4 port)))
	(assert (string=? header "SET{"))
	(let loop ((accum '()))
	  (if (eqv? #\} (peek-char port)) (reverse accum)
	    (let ((val (read port)))
	      (assert (not (eof-object? val)) (number? val))
	      (if (eqv? #\, (skip-while '(#\space #\tab) port))
		  (read-char port))
	      (loop (cons val accum)))))))))


; Parse the set-of-dates
; Given a string such as "SET{}" or 
; "SET{'2002-05-20 12:00:00','2002-05-20 18:00:00'}"
; return the list of the epoch timestamps, in the same order.
; The input string is an external representation for values of
; Informix datatype SETOF(date).
;
; More formally, the input string has the format
; "SET{}"  (empty set)
; "SET{date[,date]*}"
; where date is 'YYYY-MM-DD HH:MM:SS'

(define (DB1:parse-set-of-dates setstr)
  (call-with-input-string setstr
    (lambda (port)
      (let ((header (read-string 4 port)))
	(assert (string=? header "SET{"))
	(let loop ((accum '()))
	  (if (eqv? #\} (peek-char port)) (reverse accum)
	    (let* ((_ (assert-curr-char '(#\') "beginning of date" port))
		   (date-str 
		    (next-token '() '(#\') "reading date string" port))
		   (val (OS:string->time "%Y-%m-%d %H:%M:%S" date-str)))
	      (assert (positive? val))
	      (if (eqv? #\, (peek-next-char port)) (read-char port))
	      (loop (cons val accum)))))))))