#!/usr/local/bin/siod -v0,-m3 -*-mode:lisp-*-

;; name:    sybsql.html
;; purpose: example use of Chunks of HTML, nested repeating objects.
;; author:  george j. carrette
;; $Id: sybsql.scm,v 1.5 1997/12/02 12:26:08 gjc Exp $

(define (main)
  (let ((before-realtime (realtime))
	(before-runtime (runtime)))
    (require'cgi.scm)
    (let ((form (car (load "sybsql.html-bin" t)))
	  (table (cons-array 10)))
      (hset table 'SCRIPT_NAME (getenv "SCRIPT_NAME"))
      (hset table 'errflag 0)
      (hset table 'msgsflag 0)
      (hset table 'statusflag 0)
      (hset table 'rowflag 0)
      (cond ((equal? "GET" (getenv "REQUEST_METHOD"))
	     (main-get table))
	    ((equal? "POST" (getenv "REQUEST_METHOD"))
	     (main-post table
			(validate-content-alist 
			 (read-content-alist))))
	    ('else
	     (error "REQUEST_METHOD not handled"
		    (getenv "REQUEST_METHOD"))))
      (hset table 'realtime (- (realtime) before-realtime))
      (hset table 'runtime (- (car (runtime)) (car before-runtime)))
      (writes nil
	      "Content-type: text/html\n\n")
      (swrite nil table form))))

(define (locate-sybase-stuff)
  (let ((fdir (car (subset (lambda (x)
			     (and x
				  (not (access-problem?
					(string-append x "/interfaces")
					"r"))))
			   (list (and (getenv "SYBASE")
				      (> (length (getenv "SYBASE"))
					 0)
				      (getenv "SYBASE"))
				 (and (symbol-bound? 'getpwnam)
				      (cdr (assq 'dir (getpwnam 'sybase))))
				 "/sybase"
				 "/home/sybase"
				 "/export/home/sybase"))))

	(i nil))
    (cond ((not fdir)
	   '("" ""))
	  ('else
	   (let ((f (fopen (string-append fdir "/interfaces") "r"))
		 (line nil))
	     (while (and (not i) (set! line (gets f)))
	       (set! line (string-trim line))
	       (cond ((substring-equal? "#" line 0 1))
		     ((= (length line) 0))
		     ('else
		      (set! i (substring line 0
					 (or
					  (string-search " " line)
					  (string-search "\t" line))))
		      (set! i (string-trim i)))))
	     (fclose f)
	     (list fdir (or i "")))))))

(define (main-get env)
  (let ((s (locate-sybase-stuff)))
    (hset env 'SYBASE (car s))
    (hset env 'DSQUERY (cadr s))
    (hset env 'username "")
    (hset env 'password "")
    (hset env 'database "")
    (hset env 'appname "sybsql.cgi")
    (hset env 'sql "")))

(define (main-post env alist)
  (putenv (string-append "SYBASE="
			 (cadr (assq 'SYBASE alist))))
  (putenv (string-append "DSQUERY="
			 (cadr (assq 'DSQUERY alist))))
  (require'sql_sybase.scm)
  (mapcar (lambda (x)
	    (hset env
		  x
		  (html-encode (or (cadr (assq x alist)) ""))))
	  '(SYBASE DSQUERY username password
		   appname database sql))
  (cond ((sybase-fcn env
		     sybase-open
		     'username (or (cadr (assq 'username alist)) "")
		     'password (or (cadr (assq 'password alist)) "")
		     'appname (or (cadr (assq 'appname alist)) ""))
	 (if (and (cadr (assq 'database alist))
		  (> (length (cadr (assq 'database alist))) 0))
	     (sybase-fcn env
			 sybase-execute
			 (string-append
			  "use " 
			  (cadr (assq 'database alist)))
			 CS_LANG_CMD))
	 (cond ((or (not (cadr (assq 'sql alist)))
		    (not (> (length (cadr (assq 'sql alist))) 0))))
	       ('else
		(mapcar (lambda (x)
			  (setup-result env x))
			(sybase-fcn env
				    sybase-execute
				    (cadr (assq 'sql alist))
				    CS_LANG_CMD))))
	 (sybase-close))))

(define (sybase-fcn env f . args)
  (set! *sybase-messages* nil)
  (let ((result (*catch 'errobj (list 'ok (apply f args)))))
    (cond (*sybase-messages*
	   (hset env 'msgsflag 1)
	   (hset env 'nmsgs (+ (or (href env 'nmsgs) 0)
			       (length *sybase-messages*)))
	   (hset env 'msgtype
		 (append (href env 'msgtype)
			 (mapcar car
				 *sybase-messages*)))
	   (hset env 'msgcode
		 (append (href env 'msgcode)
			 (mapcar (lambda (x)
				   (cdr (assq 'msgnumber x)))
				 *sybase-messages*)))
	   (hset env 'msgtext
		 (append (href env 'msgtext)
			 (mapcar (lambda (x)
				   (html-encode
				    (or (cdr (assq 
					      (if (eq? (car x) 'client)
						  'msgstring
						'text)
					      x))
					"")))
				 *sybase-messages*)))))
    (cond ((and (pair? result) (eq? (car result) 'ok))
	   (cadr result))
	  ('else
	   (hset env 'errflag 1)
	   (hset env 'errmsg (car result))
	   nil))))

(define (setup-result env x)
  (cond ((not (pair? x)))
	((eq? (car x) 'CS_STATUS_RESULT)
	 (hset env 'statusflag 1)
	 (hset env 'nstatus (+ 1 (or (href env 'nstatus) 0)))
	 (hset env 'status (append (href env 'status)
				   (list (aref (nth 2 x) 0)))))
	((eq? (car x) 'CS_ROW_RESULT)
	 (hset env 'rowflag (+ 1 (or (href env 'rowflag) 0)))
	 (hset env 'ncols
	       (nconc (href env 'ncols)
		      (list (length (nth 1 x)))))
	 (hset env 'cols
	       (nconc (href env 'cols)
		      (array->html-list (nth 1 x))))
	 (hset env 'nrows
	       (nconc (href env 'nrows)
		      (list (length (cddr x)))))
	 (hset env 'element
	       (nconc (href env 'element)
		      (list-array->html-list (cddr x))))
	 nil)))

(define (array->html-list x)
  (let ((j 0)
	(result nil))
    (while (< j (length x))
      (set! result (cons (html-encode (aref x j)) result))
      (set! j (+ 1 j)))
    (nreverse result)))

(define (list-array->html-list x)
  (let ((l x)
	(j 0)
	(result nil))
    (while l
      (set! j 0)
      (while (< j (length (car l)))
	(set! result (cons (html-encode (aref (car l) j)) result))
	(set! j (+ 1 j)))
      (set! l (cdr l)))
    (nreverse result)))

(define (url-encode-alist x)
  (unbreakupstr (mapcar (lambda (x)
			  (unbreakupstr
			   (mapcar url-encode x)
			   "="))
			x)
		"&"))

(define (validate-content-alist alist)
  ;; This is a special case of a much more general idea.
  ;; If password starts with an "@" then it is
  ;; of the form @filename:signature.
  (let ((password (cadr (assq 'password alist)))
	(k nil))
    (cond ((or (not password)
	       (not (substring-equal? "@" password 0 1)))
	   alist)
	  ((not (set! k (string-search ":" password)))
	   (error "invalid signature format" password))
	  ('else
	   (let ((signature (substring password (+ 1 k)))
		 (filename (substring password 1 k))
		 (data (url-encode-alist
			(subset (lambda (x)
				  (not (eq? (car x)
					    'password)))
				alist))))
	     (error "validate"
		    (list signature filename data)))))))