;;; "htmlform.scm" Generate HTML 2.0 forms. -*-scheme-*-
; Copyright 1997, 1998, 2000 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(require 'sort)
(require 'printf)
(require 'parameters)
(require 'object->string)
(require 'string-search)
(require 'database-utilities)
(require 'common-list-functions)

;;;;@code{(require 'html-form)}

;;@body Returns a string with character substitutions appropriate to
;;send @1 as an @dfn{attribute-value}.
(define (html:atval txt)		; attribute-value
  (if (symbol? txt) (set! txt (symbol->string txt)))
  (if (number? txt)
      (number->string txt)
      (string-subst (if (string? txt) txt (object->string txt))
		    "&" "&amp;"
		    "\"" "&quot;"
		    "<" "&lt;"
		    ">" "&gt;")))

;;@body Returns a string with character substitutions appropriate to
;;send @1 as an @dfn{plain-text}.
(define (html:plain txt)		; plain-text `Data Characters'
  (if (symbol? txt) (set! txt (symbol->string txt)))
  (if (number? txt)
      (number->string txt)
      (string-subst (if (string? txt) txt (object->string txt))
		    "&" "&amp;"
		    "<" "&lt;"
		    ">" "&gt;")))

;;@args title backlink tags ...
;;@args title backlink
;;@args title
;;
;;Returns header string for an HTML page named @1.  If string
;;arguments @2 ... are supplied they are included verbatim within the
;;@t{<HEAD>} section.
(define (html:head title . args)
  (define backlink (if (null? args) #f (car args)))
  (if (not (null? args)) (set! args (cdr args)))
  (string-append
   (sprintf #f "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\\n")
   (sprintf #f "<HTML>\\n")
   (sprintf #f "%s"
	    (html:comment "HTML by SLIB"
			  "http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
   (sprintf #f "<HEAD>%s<TITLE>%s</TITLE></HEAD>\\n"
	    (apply string-append args) (html:plain title))
   (sprintf #f "<BODY><H1>%s</H1>\\n" (or backlink (html:plain title)))))

;;@body Returns HTML string to end a page.
(define (html:body . body)
  (apply string-append
	 (append body (list (sprintf #f "</BODY>\\n</HTML>\\n")))))

;;@body Returns the strings @1, @2 as @dfn{PRE}formmated plain text
;;(rendered in fixed-width font).  Newlines are inserted between @1,
;;@2.  HTML tags (@samp{<tag>}) within @2 will be visible verbatim.
(define (html:pre line1 . lines)
  (string-append
   (apply string-append
	  (sprintf #f "<PRE>\\n%s" (html:plain line1))
	  (map (lambda (line) (sprintf #f "\\n%s" (html:plain line))) lines))
   (sprintf #f "</PRE>\\n")))

;;@body Returns the strings @1 as HTML comments.
(define (html:comment line1 . lines)
  (string-append
   (apply string-append
	  (if (substring? "--" line1)
	      (slib:error 'html:comment "line contains --" line1)
	      (sprintf #f "<!--%s--" line1))
	  (map (lambda (line)
		 (if (substring? "--" line)
		     (slib:error 'html:comment "line contains --" line)
		     (sprintf #f "\\n  --%s--" line)))
	       lines))
   (sprintf #f ">\\n")))

;;@section HTML Forms

(define (html:dt-strong-doc name doc)
  (if (and (string? doc) (not (equal? "" doc)))
      (sprintf #f "<DT><STRONG>%s</STRONG> (%s)\\n"
		   (html:plain name) (html:plain doc))
      (sprintf #f "<DT><STRONG>%s</STRONG>\\n" (html:plain name))))

(define (html:checkbox name doc pname default)
  (string-append
   (sprintf #f "<DT><INPUT TYPE=CHECKBOX NAME=%#a %s>\\n"
	    (html:atval pname) (if default "CHECKED" ""))
   (if (and (string? doc) (not (equal? "" doc)))
       (sprintf #f "<DD><STRONG>%s</STRONG> (%s)\\n"
		(html:plain name) (html:plain doc))
       (sprintf #f "<DD><STRONG>%s</STRONG>\\n" (html:plain name)))))

(define (html:hidden name value)
  (sprintf #f "<DT><INPUT TYPE=HIDDEN NAME=%#a VALUE=%#a>\\n"
	   (html:atval name) (html:atval value)))

(define (html:text name doc pname default . size)
  (set! size (if (null? size) #f (car size)))
  (cond (default
	  (sprintf #f "%s<DD><INPUT NAME=%#a SIZE=%d VALUE=%#a>\\n"
		   (html:dt-strong-doc name doc)
		   (html:atval pname)
		   (or size
		       (max 20 (string-length
				(if (symbol? default)
				    (symbol->string default) default))))
		   (html:atval default)))
	(size
	 (sprintf #f "%s<DD><INPUT NAME=%#a SIZE=%d>\\n"
		  (html:dt-strong-doc name doc)
		  (html:atval pname)
		  size))
	(else
	 (sprintf #f "%s<DD><INPUT NAME=%#a>\\n"
		  (html:dt-strong-doc name doc)
		  (html:atval pname)))))

(define (html:text-area name doc pname default-list)
  (string-append
   (html:dt-strong-doc name doc)
   (sprintf #f "<DD><TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n"
	    (html:atval pname) (max 2 (length default-list))
	    (apply max 32 (map (lambda (d) (string-length
					    (if (symbol? d)
						(symbol->string d)
						d)))
			       default-list)))
   (apply
    string-append
    (map (lambda (line) (sprintf #f "%s\\n" (html:plain line))) default-list))
   (sprintf #f "</TEXTAREA>\\n")))

(define (html:s<? s1 s2)
  (if (and (number? s1) (number? s2))
      (< s1 s2)
      (string<? (if (symbol? s1) (symbol->string s1) s1)
		(if (symbol? s2) (symbol->string s2) s2))))

(define (html:select name doc pname arity default-list value-list)
  (set! value-list (sort! value-list html:s<?))
  (string-append
   (html:dt-strong-doc name doc)
   (sprintf #f "<DD><SELECT NAME=%#a SIZE=%d%s>\\n"
	    (html:atval pname)
	    (case arity
	      ((single optional) 1)
	      ((nary nary1) 5))
	    (case arity
	      ((nary nary1) " MULTIPLE")
	      (else "")))
   (apply
    string-append
    (map (lambda (value)
	   (sprintf #f "<OPTION VALUE=%#a%s>%s\\n"
		    (html:atval value)
		    (if (member value default-list)
			" SELECTED" "")
		    (html:plain value)))
	 (case arity
	   ((optional nary) (cons (string->symbol "") value-list))
	   (else value-list))))
   (sprintf #f "</SELECT>\\n")))

(define (html:buttons name doc pname arity default-list value-list)
  (set! value-list (sort! value-list html:s<?))
  (string-append
   (html:dt-strong-doc name doc)
   (sprintf #f "<DD><MENU>")
   (case arity
     ((single optional)
      (apply
       string-append
       (map (lambda (value)
	      (sprintf #f
		       "<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n"
		       (html:atval pname) (html:atval value)
		       (if (member value default-list) " CHECKED" "")
		       (html:plain value)))
	    value-list)))
     ((nary nary1)
      (apply
       string-append
       (map (lambda (value)
	      (sprintf #f
		       "<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n"
		       (html:atval pname) (html:atval value)
		       (if (member value default-list) " CHECKED" "")
		       (html:plain value)))
	    value-list))))
   (sprintf #f "</MENU>")))

;;@body The symbol @1 is either @code{get}, @code{head}, @code{post},
;;@code{put}, or @code{delete}.  The string or symbol @2 appears on
;;the button which submits the form.  If @4 is non-false, a
;;@dfn{reset} is generated.  The strings @5 form the body of the form.
;;@0 returns the HTML @dfn{form}.
(define (html:form method submit-label action reset? . body)
  (cond ((not (memq method '(get head post put delete)))
	 (slib:error 'html:form "method unknown:" method)))
  (string-append
   (apply string-append
	  (sprintf #f "<FORM METHOD=%#a ACTION=%#a>\\n"
		   (html:atval method) (html:atval action))
	  body)
   (sprintf #f "%s<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a>"
	    (if reset? "<BR>" "")
	    (html:atval '*command*) (html:atval submit-label))
   (sprintf #f "%s\\n" (if reset? " <INPUT TYPE=RESET>" ""))
   (sprintf #f "</FORM>\\n")))

(define (html:generate-form comname method action docu pnames docs aliases
			    arities types default-lists value-lists)
  (define aliast (map list pnames))
  (for-each (lambda (alias)
	      (if (> (string-length (car alias)) 1)
		  (let ((apr (assq (cadr alias) aliast)))
		    (set-cdr! apr (cons (car alias) (cdr apr))))))
	    aliases)
  (string-append
   (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
	    (html:plain comname) (html:plain docu))
   (apply html:form 'post comname action #t
	  (map
	   (lambda (pname doc aliat arity default-list value-list)
	     (define longname
	       (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat)))
	     (set! longname (if (null? longname) #f (car longname)))
	     (cond (longname
		    (case (length value-list)
		      ((0) (case arity
			     ((boolean)
			      (html:checkbox longname doc pname
					     (if (null? default-list)
						 #f (car default-list))))
			     ((single optional)
			      (html:text longname doc pname
					 (if (null? default-list)
					     #f (car default-list))))
			     (else
			      (html:text-area longname doc pname default-list))))
		      ((1);;(print 'value-list value-list)
		       (html:checkbox longname doc pname (car value-list)))
		      (else ((case arity
			       ((single optional) html:select)
			       (else html:buttons))
			     longname doc pname arity default-list value-list))))
		   (else "")))
	   pnames docs aliast arities default-lists value-lists))))

;;@body The symbol @2 names a command table in the @1 relational
;;database.
;;
;;@0 writes an HTML-2.0 @dfn{form} for command @3 to the
;;current-output-port.  The @samp{SUBMIT} button, which is labeled @3,
;;invokes the URI @5 with method @4 with a hidden attribute
;;@code{*command*} bound to the command symbol submitted.
;;
;;An action may invoke a CGI script
;;(@samp{http://www.my-site.edu/cgi-bin/search.cgi}) or HTTP daemon
;;(@samp{http://www.my-site.edu:8001}).
;;
;;This example demonstrates how to create a HTML-form for the @samp{build}
;;command.
;;
;;@example
;;(require (in-vicinity (implementation-vicinity) "build.scm"))
;;(call-with-output-file "buildscm.html"
;;  (lambda (port)
;;    (display
;;     (string-append
;;      (html:head 'commands)
;;      (html:body
;;       (command->html build '*commands* 'build 'post
;;                      (or "http://localhost:8081/buildscm"
;;                          "/cgi-bin/build.cgi"))))
;;     port)))
;;@end example
(define (command->html rdb command-table command method action)
  (define rdb-open (rdb 'open-table))
  (define (row-refer idx) (lambda (row) (list-ref row idx)))
  (let ((comtab (rdb-open command-table #f))
	(domain->type ((rdb-open '*domains-data* #f) 'get 'type-id))
	(get-domain-choices
	 (let ((for-tab-name
		((rdb-open '*domains-data* #f) 'get 'foreign-table)))
	   (lambda (domain-name)
	     (define tab-name (for-tab-name domain-name))
	     (if tab-name
		 (do ((dlst (((rdb-open tab-name #f) 'get* 1)) (cdr dlst))
		      (out '() (if (member (car dlst) (cdr dlst))
				   out (cons (car dlst) out))))
		     ((null? dlst) out))
		 '())))))
    (define row-ref
      (let ((names (comtab 'column-names)))
	(lambda (row name) (list-ref row (position name names)))))
    (let* ((command:row ((comtab 'row:retrieve) command))
	   (parameter-table (rdb-open (row-ref command:row 'parameters) #f))
	   (pcnames (parameter-table 'column-names))
	   (param-rows (sort! ((parameter-table 'row:retrieve*))
			      (lambda (r1 r2) (< (car r1) (car r2))))))
      (let ((domains (map (row-refer (position 'domain pcnames)) param-rows))
	    (parameter-names
	     (rdb-open (row-ref command:row 'parameter-names) #f)))
	(html:generate-form
	 command
	 method
	 action
	 (row-ref command:row 'documentation)
	 (map (row-refer (position 'name pcnames)) param-rows)
	 (map (row-refer (position 'documentation pcnames)) param-rows)
	 (map list ((parameter-names 'get* 'name))
	      (map (parameter-table 'get 'name)
		   ((parameter-names 'get* 'parameter-index))))
	 (map (row-refer (position 'arity pcnames)) param-rows)
	 (map domain->type domains)
	 (map cdr (fill-empty-parameters
		   (map slib:eval
			(map (row-refer (position 'defaulter pcnames))
			     param-rows))
		   (make-parameter-list
		    (map (row-refer (position 'name pcnames)) param-rows))))
	 (map get-domain-choices domains))))))
