diff options
Diffstat (limited to 'htmlform.scm')
| -rw-r--r-- | htmlform.scm | 1128 |
1 files changed, 364 insertions, 764 deletions
diff --git a/htmlform.scm b/htmlform.scm index 02dc63a..935e006 100644 --- a/htmlform.scm +++ b/htmlform.scm @@ -1,9 +1,9 @@ -;;; "htmlform.scm" Generate HTML 2.0 forms; service CGI requests. -*-scheme-*- -; Copyright 1997, 1998 Aubrey Jaffer +;;; "htmlform.scm" Generate HTML 2.0 forms. -*-scheme-*- +; Copyright 1997, 1998, 2000, 2001 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. +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, 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. @@ -18,31 +18,20 @@ ;each case. (require 'sort) -(require 'scanf) (require 'printf) -(require 'line-i/o) (require 'parameters) -(require 'fluid-let) -(require 'dynamic-wind) -(require 'pretty-print) (require 'object->string) -(require 'string-case) -(require 'string-port) (require 'string-search) (require 'database-utilities) (require 'common-list-functions) ;;;;@code{(require 'html-form)} - -;;@body Procedure names starting with @samp{html:} send their output -;;to the port @0. @0 is initially the current output port. -(define *html:output-port* (current-output-port)) - -(define (html:printf . args) (apply fprintf *html:output-port* args)) +;;@ftindex html-form +(define html:blank (string->symbol "")) ;;@body Returns a string with character substitutions appropriate to ;;send @1 as an @dfn{attribute-value}. -(define (make-atval txt) ; attribute-value +(define (html:atval txt) ; attribute-value (if (symbol? txt) (set! txt (symbol->string txt))) (if (number? txt) (number->string txt) @@ -54,256 +43,164 @@ ;;@body Returns a string with character substitutions appropriate to ;;send @1 as an @dfn{plain-text}. -(define (make-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)) - "&" "&" - "<" "<" - ">" ">"))) +(define (html:plain txt) ; plain-text `Data Characters' + (cond ((eq? html:blank txt) " ") + (else + (if (symbol? txt) (set! txt (symbol->string txt))) + (if (number? txt) + (number->string txt) + (string-subst (if (string? txt) txt (object->string txt)) + "&" "&" + "<" "<" + ">" ">"))))) + +;;@body Returns a tag of meta-information suitable for passing as the +;;third argument to @code{html:head}. The tag produced is @samp{<META +;;NAME="@1" CONTENT="@2">}. The string or symbol @1 can be +;;@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description}, +;;@samp{date}, @samp{robots}, @dots{}. +(define (html:meta name content) + (sprintf #f "\n<META NAME=\"%s\" CONTENT=\"%s\">" name (html:atval content))) + +;;@body Returns a tag of HTTP information suitable for passing as the +;;third argument to @code{html:head}. The tag produced is @samp{<META +;;HTTP-EQUIV="@1" CONTENT="@2">}. The string or symbol @1 can be +;;@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type}, +;;@samp{Refresh}, @dots{}. +(define (html:http-equiv name content) + (sprintf #f "\n<META HTTP-EQUIV=\"%s\" CONTENT=\"%s\">" + name (html:atval content))) + +;;@args delay uri +;;@args delay +;; +;;Returns a tag suitable for passing as the third argument to +;;@code{html:head}. If @2 argument is supplied, then @1 seconds after +;;displaying the page with this tag, Netscape or IE browsers will fetch +;;and display @2. Otherwise, @1 seconds after displaying the page with +;;this tag, Netscape or IE browsers will fetch and redisplay this page. +(define (html:meta-refresh delay . uri) + (if (null? uri) + (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d\">" delay) + (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d;URL=%s\">" + delay (car uri)))) ;;@args title backlink tags ... ;;@args title backlink ;;@args title ;; -;;Outputs headers for an HTML page named @1. If string arguments @2 -;;... are supplied they are printed verbatim within the @t{<HEAD>} -;;section. -(define (html:start-page title . args) +;;Returns header string for an HTML page named @1. If @2 is a string, +;;it is used verbatim between the @samp{H1} tags; otherwise @1 is +;;used. If string arguments @3 ... are supplied, then 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))) - (html:printf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\\n") - (html:printf "<HTML>\\n") - (html:comment "HTML by SLIB" - "http://swissnet.ai.mit.edu/~jaffer/SLIB.html") - (html:printf "<HEAD>%s<TITLE>%s</TITLE></HEAD>\\n" - (apply string-append args) (make-plain title)) - (html:printf "<BODY><H1>%s</H1>\\n" - (or backlink (make-plain title)))) - -;;@body Outputs HTML codes to end a page. -(define (html:end-page) - (html:printf "</BODY>\\n") - (html:printf "</HTML>\\n")) - -;;@body Writes (using @code{html:printf}) 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. + (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>\\n <TITLE>%s</TITLE>\\n %s\\n </HEAD>\\n" + (html:plain title) (apply string-append args)) + (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) - (html:printf "<PRE>\\n%s" (make-plain line1)) - (for-each (lambda (line) (html:printf "\\n%s" (make-plain line))) lines) - (html:printf "</PRE>\\n")) - -;;@body Writes (using @code{html:printf}) the strings @1 as HTML -;;comments. + (sprintf #f "<PRE>\\n%s%s</PRE>" + (html:plain line1) + (string-append + (apply string-append + (map (lambda (line) (sprintf #f "\\n%s" (html:plain line))) + lines))))) + +;;@body Returns the strings @1 as HTML comments. (define (html:comment line1 . lines) - (html:printf "<!") - (if (substring? "--" line1) - (slib:error 'html:comment "line contains --" line1) - (html:printf "--%s--" line1)) - (for-each (lambda (line) - (if (substring? "--" line) - (slib:error 'html:comment "line contains --" line) - (html:printf "\\n --%s--" line))) - lines) - (html:printf ">\\n")) - -;;@section HTML Tables - -;;@body -(define (html:start-table caption) - (html:printf "<TABLE BORDER WIDTH=\"100%%\">\\n") - (html:printf "<CAPTION ALIGN=BOTTOM>%s</CAPTION>\\n" (make-plain caption))) - -;;@body -(define (html:end-table) - (html:printf "</TABLE>\\n")) - -;;@body Outputs a heading row for the currently-started table. -(define (html:heading columns) - (html:printf "<TR VALIGN=\"TOP\">\\n") - (for-each (lambda (datum) (html:printf "<TH>%s\\n" (or datum ""))) columns)) - -;;@body Outputs a heading row with column-names @1 linked to URLs @2. -(define (html:href-heading columns urls) - (html:heading - (map (lambda (column url) - (if url - (sprintf #f "<A HREF=\"%s\">%s</A>" url column) - column)) - columns urls))) - -;;@args k foreigns -;; -;;The positive integer @1 is the primary-key-limit (number of -;;primary-keys) of the table. @2 is a list of the filenames of -;;foreign-key field pages and #f for non foreign-key fields. -;; -;;@0 returns a procedure taking a row for its single argument. This -;;returned procedure prints the table row to @var{*html:output-port*}. -(define (make-row-converter pkl foreigns) - (lambda (data-row) - (define anchored? #f) - (define (present datum) - (cond ((or (string? datum) (symbol? datum)) - (html:printf "%s" (make-plain datum))) - (else - (html:printf - "<PRE>\\n%s</PRE>\\n" - (make-plain (call-with-output-string - (lambda (port) - (pretty-print datum port)))))))) - (html:printf "<TR VALIGN=\"TOP\">") - (for-each (lambda (datum foreign) - (html:printf "<TD>") - (cond ((not datum)) - ((null? datum)) - ((not anchored?) - (html:printf "<A NAME=\"") - (cond - ((zero? pkl) - (html:printf "%s" (make-atval datum))) - (else (html:printf - "%s" (make-atval (car data-row))) - (do ((idx 1 (+ 1 idx)) - (contents (cdr data-row) (cdr contents))) - ((>= idx pkl)) - (html:printf - " %s" (make-atval (car contents)))))) - (html:printf "\">") - (set! anchored? (not (zero? pkl))))) - (cond ((not datum)) ((null? datum)) - ((not foreign) (present datum)) - ((zero? pkl) - (html:printf "<A HREF=\"%s\">" foreign) - (present datum) - (html:printf "</A>")) - (else - (html:printf "<A HREF=\"%s#%s\">" - foreign (make-atval datum)) - (present datum) - (html:printf "</A>")))) - data-row foreigns) - (html:printf "\\n"))) - -;;@body -;;Returns the symbol @1 converted to a filename. -(define (table-name->filename table-name) - (and table-name (string-append - (string-subst (symbol->string table-name) "*" "" ":" "_") - ".html"))) - -(define (table-name->column-table-name db table-name) - ((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name) - table-name)) - -;;@args caption db table-name match-key1 @dots{} -;;Writes HTML for @2 table @3 to @var{*html:output-port*}. -;; -;;The optional @4 @dots{} arguments restrict actions to a subset of -;;the table. @xref{Table Operations, match-key}. -(define (table->html caption db table-name . args) - (let* ((table ((db 'open-table) table-name #f)) - (foreigns (table 'column-foreigns)) - (tags (map table-name->filename foreigns)) - (names (table 'column-names)) - (primlim (table 'primary-limit))) - (html:start-table caption) - (html:href-heading - names - (append (make-list primlim (table-name->filename - (table-name->column-table-name db table-name))) - (make-list (- (length names) primlim) #f))) - (html:heading (table 'column-domains)) - (html:href-heading foreigns tags) - (html:heading (table 'column-types)) - (apply (table 'for-each-row) (make-row-converter primlim tags) args) - (html:end-table))) - -;;@body -;;Writes a complete HTML page to @var{*html:output-port*}. The string -;;@3 names the page which refers to this one. -(define (table->page db table-name index-filename) - (dynamic-wind - (lambda () - (if index-filename - (html:start-page - table-name - (sprintf #f "<A HREF=\"%s#%s\">%s</A>" - index-filename - (make-atval table-name) - (make-plain table-name))) - (html:start-page table-name))) - (lambda () (table->html table-name db table-name)) - html:end-page)) - -;;@body -;;Writes HTML for the catalog table of @1 to @var{*html:output-port*}. -(define (catalog->html db caption) - (html:start-table caption) - (html:heading '(table columns)) - ((((db 'open-table) '*catalog-data* #f) 'for-each-row) - (lambda (row) - (cond ((and (eq? '*columns* (caddr row)) - (not (eq? '*columns* (car row))))) - (else ((make-row-converter - 0 (list (table-name->filename (car row)) - (table-name->filename (caddr row)))) - (list (car row) (caddr row)))))))) - -;;@body -;;Writes a complete HTML page for the catalog of @1 to -;;@var{*html:output-port*}. -(define (catalog->page db caption) - (dynamic-wind - (lambda () (html:start-page caption)) - (lambda () - (catalog->html db caption) - (html:end-table)) - html:end-page)) + (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"))) + +(define (html:strong-doc name doc) + (set! name (if name (html:plain name) "")) + (set! doc (if doc (html:plain doc) "")) + (if (equal? "" doc) + (if (equal? "" name) + "" + (sprintf #f "<STRONG>%s</STRONG>" (html:plain name))) + (sprintf #f "<STRONG>%s</STRONG> (%s)" + (html:plain name) (html:plain doc)))) ;;@section HTML Forms -(define (html:dt-strong-doc name doc) - (if (and (string? doc) (not (equal? "" doc))) - (html:printf "<DT><STRONG>%s</STRONG> (%s)\\n" - (make-plain name) (make-plain doc)) - (html:printf "<DT><STRONG>%s</STRONG>\\n" (make-plain name)))) - -(define (html:checkbox name doc pname) - (html:printf "<DT><INPUT TYPE=CHECKBOX NAME=%#a VALUE=T>\\n" - (make-atval pname)) - (if (and (string? doc) (not (equal? "" doc))) - (html:printf "<DD><STRONG>%s</STRONG> (%s)\\n" - (make-plain name) (make-plain doc)) - (html:printf "<DD><STRONG>%s</STRONG>\\n" (make-plain name)))) - -(define (html:text name doc pname default) +;;@body The symbol @1 is either @code{get}, @code{head}, @code{post}, +;;@code{put}, or @code{delete}. The strings @3 form the body of the +;;form. @0 returns the HTML @dfn{form}. +(define (html:form method action . 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 "</FORM>\\n"))) + +;;@body Returns HTML string which will cause @1=@2 in form. +(define (html:hidden name value) + (sprintf #f "<INPUT TYPE=HIDDEN NAME=%#a VALUE=%#a>" + (html:atval name) (html:atval value))) + +;;@body Returns HTML string for check box. +(define (html:checkbox pname default) + (sprintf #f "<INPUT TYPE=CHECKBOX NAME=%#a %s>" + (html:atval pname) + (if default "CHECKED" ""))) + +;;@body Returns HTML string for one-line text box. +(define (html:text pname default . size) + (set! size (if (null? size) #f (car size))) (cond (default - (html:dt-strong-doc name doc) - (html:printf "<DD><INPUT NAME=%#a SIZE=%d VALUE=%#a>\\n" - (make-atval pname) - (max 20 (string-length - (if (symbol? default) - (symbol->string default) default))) - (make-atval default))) - (else - (html:dt-strong-doc name doc) - (html:printf "<DD><INPUT NAME=%#a>\\n" (make-atval pname))))) - -(define (html:text-area name doc pname default-list) - (html:dt-strong-doc name doc) - (html:printf "<DD><TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n" - (make-atval pname) (max 2 (length default-list)) - (apply max 32 (map (lambda (d) (string-length - (if (symbol? d) - (symbol->string d) - d))) - default-list))) - (for-each (lambda (line) (html:printf "%s\\n" (make-plain line))) default-list) - (html:printf "</TEXTAREA>\\n")) + (sprintf #f "<INPUT NAME=%#a SIZE=%d VALUE=%#a>" + (html:atval pname) + (or size + (max 5 + (min 20 (string-length + (if (symbol? default) + (symbol->string default) default))))) + (html:atval default))) + (size (sprintf #f "<INPUT NAME=%#a SIZE=%d>" (html:atval pname) size)) + (else (sprintf #f "<INPUT NAME=%#a>" (html:atval pname))))) + +;;@body Returns HTML string for multi-line text box. +(define (html:text-area pname default-list) + (set! default-list (map (lambda (d) (sprintf #f "%a" d)) default-list)) + (string-append + (sprintf #f "<TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n" + (html:atval pname) (max 1 (length default-list)) + (min 32 (apply max 5 (map string-length default-list)))) + (let* ((str (apply string-append + (map (lambda (line) + (sprintf #f "%s\\n" (html:plain line))) + default-list))) + (len (+ -1 (string-length str)))) + (if (positive? len) (substring str 0 len) str)) + (sprintf #f "</TEXTAREA>\\n"))) (define (html:s<? s1 s2) (if (and (number? s1) (number? s2)) @@ -311,117 +208,174 @@ (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<?)) - (html:dt-strong-doc name doc) - (html:printf "<DD><SELECT NAME=%#a SIZE=%d%s>\\n" - (make-atval pname) - (case arity - ((single optional) 1) - ((nary nary1) 5)) - (case arity - ((nary nary1) " MULTIPLE") - (else ""))) - (for-each (lambda (value) - (html:printf "<OPTION VALUE=%#a%s>%s\\n" - (make-atval value) - (if (member value default-list) - " SELECTED" "") - (make-plain value))) - (case arity - ((optional nary) (cons (string->symbol "") value-list)) - (else value-list))) - (html:printf "</SELECT>\\n")) - -(define (html:buttons name doc pname arity default-list value-list) - (set! value-list (sort! value-list html:s<?)) - (html:dt-strong-doc name doc) - (html:printf "<DD><MENU>") - (case arity - ((single optional) - (for-each (lambda (value) - (html:printf - "<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n" - (make-atval pname) (make-atval value) - (if (member value default-list) " CHECKED" "") - (make-plain value))) - value-list)) - ((nary nary1) - (for-each (lambda (value) - (html:printf - "<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n" - (make-atval pname) (make-atval value) - (if (member value default-list) " CHECKED" "") - (make-plain value))) - value-list))) - (html:printf "</MENU>")) - -;;@body The symbol @1 is either @code{get}, @code{head}, @code{post}, -;;@code{put}, or @code{delete}. @0 prints the header for an HTML -;;@dfn{form}. -(define (html:start-form method action) - (cond ((not (memq method '(get head post put delete))) - (slib:error 'html:start-form "method unknown:" method))) - (html:printf "<FORM METHOD=%#a ACTION=%#a>\\n" - (make-atval method) (make-atval action)) - (html:printf "<DL>\\n")) - -;;@body @0 prints the footer for an HTML @dfn{form}. The string @2 -;;appears on the button which submits the form. -(define (html:end-form pname submit-label) - (html:printf "</DL>\\n") - (html:printf "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a> <INPUT TYPE=RESET>\\n" - (make-atval '*command*) (make-atval submit-label)) - (html:printf "</FORM><HR>\\n")) +(define (by-car proc) + (lambda (s1 s2) (proc (car s1) (car s2)))) + +;;@body Returns HTML string for pull-down menu selector. +(define (html:select pname arity default-list foreign-values) + (set! foreign-values (sort foreign-values (by-car html:s<?))) + (let ((value-list (map car foreign-values)) + (visibles (map cadr foreign-values))) + (string-append + (sprintf #f "<SELECT NAME=%#a SIZE=%d%s>" + (html:atval pname) + (case arity + ((single optional) 1) + ((nary nary1) 5)) + (case arity + ((nary nary1) " MULTIPLE") + (else ""))) + (apply string-append + (map (lambda (value visible) + (sprintf #f "<OPTION VALUE=%#a%s>%s" + (html:atval value) + (if (member value default-list) " SELECTED" "") + (html:plain visible))) + (case arity + ((optional nary) (cons html:blank value-list)) + (else value-list)) + (case arity + ((optional nary) (cons html:blank visibles)) + (else visibles)))) + (sprintf #f "</SELECT>")))) + +;;@body Returns HTML string for any-of selector. +(define (html:buttons pname arity default-list foreign-values) + (set! foreign-values (sort foreign-values (by-car html:s<?))) + (let ((value-list (map car foreign-values)) + (visibles (map cadr foreign-values))) + (string-append + (sprintf #f "<MENU>") + (case arity + ((single optional) + (apply + string-append + (map (lambda (value visible) + (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 visible))) + value-list + visibles))) + ((nary nary1) + (apply + string-append + (map (lambda (value visible) + (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 visible))) + value-list + visibles)))) + (sprintf #f "</MENU>")))) + +;;@args submit-label command +;;@args submit-label +;; +;;The string or symbol @1 appears on the button which submits the form. +;;If the optional second argument @2 is given, then @code{*command*=@2} +;;and @code{*button*=@1} are set in the query. Otherwise, +;;@code{*command*=@1} is set in the query. +(define (form:submit submit-label . command) + (if (null? command) + (sprintf #f "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a>" + (html:atval '*command*) + (html:atval submit-label)) + (sprintf #f "%s<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a>" + (html:hidden '*command* (car command)) + (html:atval '*button*) + (html:atval submit-label)))) + +;;@body The @2 appears on the button which submits the form. +(define (form:image submit-label image-src) + (sprintf #f "<INPUT TYPE=IMAGE NAME=%#a SRC=%#a>" + (html:atval submit-label) + (html:atval image-src))) + +;;@body Returns a string which generates a @dfn{reset} button. +(define (form:reset) "<INPUT TYPE=RESET>") + +(define (html:delimited-list . rows) + (apply string-append + "<DL>" + (append rows '("</DL>")))) + +;;@body Returns a string which generates an INPUT element for the field +;;named @1. The element appears in the created form with its +;;representation determined by its @2 and domain. For domains which +;;are foreign-keys: +;; +;;@table @code +;;@item single +;;select menu +;;@item optional +;;select menu +;;@item nary +;;check boxes +;;@item nary1 +;;check boxes +;;@end table +;; +;;If the foreign-key table has a field named @samp{visible-name}, then +;;the contents of that field are the names visible to the user for +;;those choices. Otherwise, the foreign-key itself is visible. +;; +;;For other types of domains: +;; +;;@table @code +;;@item single +;;text area +;;@item optional +;;text area +;;@item boolean +;;check box +;;@item nary +;;text area +;;@item nary1 +;;text area +;;@end table +(define (form:element pname arity default-list foreign-values) + (define dflt (if (null? default-list) #f + (sprintf #f "%a" (car default-list)))) + ;;(print 'form:element pname arity default-list foreign-values) + (case (length foreign-values) + ((0) (case arity + ((boolean) + (html:checkbox pname dflt)) + ((single optional) + (html:text pname (if (car default-list) dflt ""))) + (else (html:text-area pname default-list)))) + ((1) (html:checkbox pname dflt)) + (else ((case arity + ((single optional) html:select) + (else html:buttons)) + pname arity default-list foreign-values)))) -(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) - (dynamic-wind - (lambda () - (html:printf "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" - (make-plain comname) (make-plain docu)) - (html:start-form 'post action)) - (lambda () - (for-each - (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 'Y)) - ((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) (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)))))) - pnames docs aliast arities default-lists value-lists)) - (lambda () - (html:end-form comname comname)))) +;;@body +;; +;;Returns a HTML string for a form element embedded in a line of a +;;delimited list. Apply map @0 to the list returned by +;;@code{command->p-specs}. +(define (form:delimited pname doc aliat arity default-list foreign-values) + (define longname + (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat))) + (set! longname (if (null? longname) #f (car longname))) + (if longname + (string-append + "<DT>" (html:strong-doc longname doc) "<DD>" + (form:element pname arity default-list foreign-values)) + "")) -;;@body The symbol @2 names a command table in the @1 relational -;;database. +;;@body ;; -;;@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. +;;The symbol @2 names a command table in the @1 relational database. +;;The symbol @3 names a key in @2. ;; -;;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}). +;;@0 returns a list of lists of @var{pname}, @var{doc}, @var{aliat}, +;;@var{arity}, @var{default-list}, and @var{foreign-values}. The +;;returned list has one element for each parameter of command @3. ;; ;;This example demonstrates how to create a HTML-form for the @samp{build} ;;command. @@ -430,29 +384,34 @@ ;;(require (in-vicinity (implementation-vicinity) "build.scm")) ;;(call-with-output-file "buildscm.html" ;; (lambda (port) -;; (fluid-let ((*html:output-port* port)) -;; (html:start-page 'commands) -;; (command->html -;; build '*commands* 'build 'post -;; (or "/cgi-bin/build.cgi" -;; "http://localhost:8081/buildscm")) -;; html:end-page))) +;; (display +;; (string-append +;; (html:head 'commands) +;; (html:body +;; (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" +;; (html:plain 'build) +;; (html:plain ((comtab 'get 'documentation) 'build))) +;; (html:form +;; 'post +;; (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") +;; (apply html:delimited-list +;; (apply map form:delimited +;; (command->p-specs build '*commands* 'build))) +;; (form:submit 'build) +;; (form:reset)))) +;; port))) ;;@end example -(define (command->html rdb command-table command method action) +(define (command->p-specs rdb command-table command) (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))) + ;;(domain->type ((rdb-open '*domains-data* #f) 'get 'type-id)) + (get-foreign-values + (let ((ftn ((rdb-open '*domains-data* #f) 'get 'foreign-table))) (lambda (domain-name) - (define tab-name (for-tab-name domain-name)) + (define tab-name (ftn 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)) + (get-foreign-choices (rdb-open tab-name #f)) '()))))) (define row-ref (let ((names (comtab 'column-names))) @@ -463,387 +422,28 @@ (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)))))) - -(define (cgi:process-% str) - (define len (string-length str)) - (define (sub str) - (cond - ((strsrch:string-index str #\%) - => (lambda (idx) - (if (and (< (+ 2 idx) len) - (string->number (substring str (+ 1 idx) (+ 2 idx)) 16) - (string->number (substring str (+ 2 idx) (+ 3 idx)) 16)) - (string-append - (substring str 0 idx) - (string (integer->char - (string->number - (substring str (+ 1 idx) (+ 3 idx)) - 16))) - (sub (substring str (+ 3 idx) (string-length str))))))) - (else str))) - (sub str)) - -(define (form:split-lines txt) - (let ((idx (strsrch:string-index txt #\newline)) - (carriage-return (integer->char #xd))) - (if idx - (cons (substring txt 0 - (if (and (positive? idx) - (char=? carriage-return - (string-ref txt (+ -1 idx)))) - (+ -1 idx) - idx)) - (form:split-lines - (substring txt (+ 1 idx) (string-length txt)))) - (list txt)))) - -(define (form-urlencoded->query-alist txt) - (if (symbol? txt) (set! txt (symbol->string txt))) - (set! txt (string-subst txt " " "" "+" " ")) - (do ((lst '()) - (edx (strsrch:string-index txt #\=) - (strsrch:string-index txt #\=))) - ((not edx) lst) - (let* ((rxt (substring txt (+ 1 edx) (string-length txt))) - (adx (strsrch:string-index rxt #\&)) - (name (cgi:process-% (substring txt 0 edx)))) - (set! - lst (append - lst - (map - (lambda (value) (list (string->symbol name) - (if (equal? "" value) #f value))) - (form:split-lines - (cgi:process-% (substring rxt 0 (or adx (string-length rxt)))))))) - (set! txt (if adx (substring rxt (+ 1 adx) (string-length rxt)) ""))))) - -(define (query-alist->parameter-list alist optnames arities types) - (define (can-take-arg? opt) - (not (eq? (list-ref arities (position opt optnames)) 'boolean))) - (let ((parameter-list (make-parameter-list optnames))) - (for-each - (lambda (lst) - (let* ((value (cadr lst)) - (name (car lst))) - (cond ((not (can-take-arg? name)) - (adjoin-parameters! parameter-list (list name #t))) - (value - (adjoin-parameters! - parameter-list - (let ((type (list-ref types (position name optnames)))) - (case type - ((expression) (list name value)) - ((symbol) - (if (string? value) - (call-with-input-string - value - (lambda (port) - (do ((tok (scanf-read-list " %s" port) - (scanf-read-list " %s" port)) - (lst '() - (cons (string-ci->symbol (car tok)) - lst))) - ((or (null? tok) (eof-object? tok)) - (cons name lst))))) - (list name (coerce value type)))) - (else (list name (coerce value type)))))))))) - alist) - parameter-list)) - -;;@c node HTTP and CGI service, Printing Scheme, HTML Forms, Textual Conversion Packages -;;@section HTTP and CGI service - -;;@code{(require 'html-form)} - -;;;; Now that we have generated the HTML form, process the ensuing CGI request. - -;;@body Reads a @samp{"POST"} or @samp{"GET"} query from -;;@code{(current-input-port)} and executes the encoded command from @2 -;;in relational-database @1. -;; -;;This example puts up a plain-text page in response to a CGI query. -;; -;;@example -;;(display "Content-Type: text/plain") (newline) (newline) -;;(require 'html-form) -;;(load (in-vicinity (implementation-vicinity) "build.scm")) -;;(cgi:serve-command build '*commands*) -;;@end example -(define (cgi:serve-command rdb command-table) - (serve-urlencoded-command rdb command-table (cgi:read-query-string))) - -;;@body Reads attribute-value pairs from @3, converts them to -;;parameters and invokes the @1 command named by the parameter -;;@code{*command*}. -(define (serve-urlencoded-command rdb command-table urlencoded) - (let* ((alist (form-urlencoded->query-alist urlencoded)) - (comname #f) - (comtab ((rdb 'open-table) command-table #f)) - (names (comtab 'column-names)) - (row-ref (lambda (row name) (list-ref row (position name names)))) - (comgetrow (comtab 'row:retrieve))) - (set! alist (remove-if (lambda (elt) - (cond ((not (and (list? elt) (pair? elt) - (eq? '*command* (car elt)))) #f) - (comname - (slib:error - 'serve-urlencoded-command - 'more-than-one-command? comname - (string->symbol (cadr elt)))) - (else (set! comname - (string-ci->symbol (cadr elt))) - #t))) - alist)) - (let* ((command:row (comgetrow comname)) - (parameter-table ((rdb 'open-table) - (row-ref command:row 'parameters) #f)) - (comval ((slib:eval (row-ref command:row 'procedure)) rdb)) - (options ((parameter-table 'get* 'name))) - (positions ((parameter-table 'get* 'index))) - (arities ((parameter-table 'get* 'arity))) - (defaulters (map slib:eval ((parameter-table 'get* 'defaulter)))) - (domains ((parameter-table 'get* 'domain))) - (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id) - domains)) - (dirs (map (rdb 'domain-checker) domains))) - - (let* ((params (query-alist->parameter-list alist options arities types)) - (fparams (fill-empty-parameters defaulters params))) - (and (list? fparams) (check-parameters dirs fparams) - (comval fparams)))))) - -(define (serve-query-alist-command rdb command-table alist) - (let ((command #f)) - (set! alist (remove-if (lambda (elt) - (cond ((not (and (list? elt) (pair? elt) - (eq? '*command* (car elt)))) #f) - (command - (slib:error - 'serve-query-alist-command - 'more-than-one-command? command - (string->symbol (cadr elt)))) - (else (set! command - (string-ci->symbol (cadr elt))) - #t))) - alist)) - ((make-command-server rdb command-table) - command - (lambda (comname comval options positions - arities types defaulters dirs aliases) - (let* ((params (query-alist->parameter-list alist options arities types)) - (fparams (fill-empty-parameters defaulters params))) - (and (list? fparams) (check-parameters dirs fparams) - (apply comval - (parameter-list->arglist positions arities fparams)))))))) - -(define http:crlf (string (integer->char 13) #\newline)) -(define (http:read-header port) - (define alist '()) - (do ((line (read-line port) (read-line port))) - ((or (zero? (string-length line)) - (and (= 1 (string-length line)) - (char-whitespace? (string-ref line 0))) - (eof-object? line)) - (if (and (= 1 (string-length line)) - (char-whitespace? (string-ref line 0))) - (set! http:crlf (string (string-ref line 0) #\newline))) - (if (eof-object? line) line alist)) - (let ((len (string-length line)) - (idx (strsrch:string-index line #\:))) - (if (char-whitespace? (string-ref line (+ -1 len))) - (set! len (+ -1 len))) - (and idx (do ((idx2 (+ idx 1) (+ idx2 1))) - ((or (>= idx2 len) - (not (char-whitespace? (string-ref line idx2)))) - (set! alist - (cons - (cons (string-ci->symbol (substring line 0 idx)) - (substring line idx2 len)) - alist))))) - ;;Else -- ignore malformed line - ;;(else (slib:error 'http:read-header 'malformed-input line)) - ))) - -(define (http:read-query-string request-line header port) - (case (car request-line) - ((get head) - (let* ((request-uri (cadr request-line)) - (len (string-length request-uri))) - (and (> len 3) - (strsrch:string-index request-uri #\?) - (substring request-uri - (+ 1 (strsrch:string-index request-uri #\?)) - (if (eqv? #\/ (string-ref request-uri (+ -1 len))) - (+ -1 len) - len))))) - ((post put delete) - (let ((content-length (assq 'content-length header))) - (and content-length - (set! content-length (string->number (cdr content-length)))) - (and content-length - (let ((str (make-string content-length #\ ))) - (do ((idx 0 (+ idx 1))) - ((>= idx content-length) - (if (>= idx (string-length str)) str (substring str 0 idx))) - (let ((chr (read-char port))) - (if (char? chr) - (string-set! str idx chr) - (set! content-length idx)))))))) - (else #f))) - -(define (http:send-status-line status-code reason) - (html:printf "HTTP/1.1 %d %s%s" status-code reason http:crlf)) -(define (http:send-header alist) - (for-each (lambda (pair) - (html:printf "%s: %s%s" (car pair) (cdr pair) http:crlf)) - alist) - (html:printf http:crlf)) - -(define *http:byline* - "<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB </A>HTTP/1.1 server") - -(define (http:send-error-page code str port) - (fluid-let ((*html:output-port* port)) - (http:send-status-line code str) - (http:send-header '(("Content-Type" . "text/html"))) - (html:start-page (sprintf #f "%d %s" code str)) - (and *http:byline* (html:printf "<HR>\\n%s\\n" *http:byline*)) - (html:end-page))) - -;;@body reads the @dfn{query-string} from @1. If this is a valid -;;@samp{"POST"} or @samp{"GET"} query, then @0 calls @3 with two -;;arguments, the query-string and the header-alist. -;; -;;Otherwise, @0 replies (to @2) with appropriate HTML describing the -;;problem. -(define (http:serve-query input-port output-port serve-proc) - (let ((request-line (http:read-request-line input-port))) - (cond ((not request-line) - (http:send-error-page 400 "Bad Request" output-port)) - ((string? (car request-line)) - (http:send-error-page 501 "Not Implemented" output-port)) - ((not (case (car request-line) - ((get post) #t) - (else #f))) - (http:send-error-page 405 "Method Not Allowed" output-port)) - (else (let* ((header (http:read-header input-port)) - (query-string - (http:read-query-string - request-line header input-port))) - (cond ((not query-string) - (http:send-error-page 400 "Bad Request" output-port)) - (else (http:send-status-line 200 "OK") - (serve-proc query-string header)))))))) - -;;@ This example services HTTP queries from port 8081: -;; -;;@example -;;(define socket (make-stream-socket AF_INET 0)) -;;(socket:bind socket 8081) -;;(socket:listen socket 10) -;;(dynamic-wind -;; (lambda () #f) -;; (lambda () -;; (do ((port (socket:accept socket) -;; (socket:accept socket))) -;; (#f) -;; (dynamic-wind -;; (lambda () #f) -;; (lambda () -;; (fluid-let ((*html:output-port* port)) -;; (http:serve-query -;; port port -;; (lambda (query-string header) -;; (http:send-header -;; '(("Content-Type" . "text/plain"))) -;; (with-output-to-port port -;; (lambda () -;; (serve-urlencoded-command -;; build '*commands* query-string))))))) -;; (lambda () (close-port port))))) -;; (lambda () (close-port socket))) -;;@end example - -(define (http:read-start-line port) - (do ((line (read-line port) (read-line port))) - ((or (not (equal? "" line)) (eof-object? line)) line))) - -;;@body Reads the first non-blank line from @1 and, if successful, -;;returns a list of three itmes from the request-line: -;; -;;@enumerate 0 -;; -;;@item Method -;; -;;Either one of the symbols @code{options}, @code{get}, @code{head}, -;;@code{post}, @code{put}, @code{delete}, or @code{trace}; Or a string. -;; -;;@item Request-URI -;; -;;A string. At the minimum, it will be the string @samp{"/"}. -;; -;;@item HTTP-Version -;; -;;A string. For example, @samp{HTTP/1.0}. -;;@end enumerate -(define (http:read-request-line port) - (let ((lst (scanf-read-list "%s %s %s %s" (http:read-start-line port)))) - (and (list? lst) - (= 3 (length lst)) - (let ((method - (assoc - (car lst) - '(("OPTIONS" . options) ; Section 9.2 - ("GET" . get) ; Section 9.3 - ("HEAD" . head) ; Section 9.4 - ("POST" . post) ; Section 9.5 - ("PUT" . put) ; Section 9.6 - ("DELETE" . delete) ; Section 9.7 - ("TRACE" . trace) ; Section 9.8 - )))) - (cons (if (pair? method) (cdr method) (car lst)) (cdr lst)))))) - -;;@body Reads the @dfn{query-string} from @code{(current-input-port)}. -;;@0 reads a @samp{"POST"} or @samp{"GET"} queries, depending on the -;;value of @code{(getenv "REQUEST_METHOD")}. -(define (cgi:read-query-string) - (define request-method (getenv "REQUEST_METHOD")) - (cond ((and request-method (string-ci=? "GET" request-method)) - (getenv "QUERY_STRING")) - ((and request-method (string-ci=? "POST" request-method)) - (let ((content-length (getenv "CONTENT_LENGTH"))) - (and content-length - (set! content-length (string->number content-length))) - (and content-length - (let ((str (make-string content-length #\ ))) - (do ((idx 0 (+ idx 1))) - ((>= idx content-length) - (if (>= idx (string-length str)) - str - (substring str 0 idx))) - (let ((chr (read-char))) - (if (char? chr) - (string-set! str idx chr) - (set! content-length idx)))))))) - (else #f))) + (parameter-names (rdb-open (row-ref command:row 'parameter-names) #f)) + (pnames (map (row-refer (position 'name pcnames)) param-rows))) + (define foreign-values (map get-foreign-values domains)) + (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)))))) + (map list + ((parameter-names 'get* 'name)) + (map (parameter-table 'get 'name) + ((parameter-names 'get* 'parameter-index))))) + (list pnames + (map (row-refer (position 'documentation pcnames)) param-rows) + aliast + (map (row-refer (position 'arity pcnames)) param-rows) + ;;(map domain->type domains) + (map cdr ;(lambda (lst) (if (null? lst) lst (cdr lst))) + (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)))) + foreign-values))))) |