diff options
Diffstat (limited to 'htmlform.scm')
| -rw-r--r-- | htmlform.scm | 663 |
1 files changed, 663 insertions, 0 deletions
diff --git a/htmlform.scm b/htmlform.scm new file mode 100644 index 0000000..f8656e2 --- /dev/null +++ b/htmlform.scm @@ -0,0 +1,663 @@ +;;; "htmlform.scm" Generate HTML 2.0 forms and -*-scheme-*- +;;; service CGI requests from RDB command table. +; Copyright 1997, 1998 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 'scanf) +(require 'printf) +(require 'line-i/o) +(require 'parameters) +(require 'fluid-let) +(require 'dynamic-wind) +(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)) + +;;@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))) + (string-subst txt + "&" "&" + "\"" """ + "<" "<" + ">" ">")) + +;;@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))) + (string-subst txt + "&" "&" + "<" "<" + ">" ">")) + +;;@body Writes (using @code{html:printf}) the strings @1 as HTML +;;comments. +(define (html:comment . lines) + (html:printf "<!") + (for-each (lambda (line) + (if (substring? "--" line) + (slib:error 'html:comment "line contains --" line) + (html:printf "--%s--\\n" line))) + lines) + (html:printf ">\\n")) + +(define (html:dt-strong-doc name doc) + (if (and (string? doc) (not (equal? "" doc))) + (html:printf "<DT><STRONG>%s</STRONG> (%s)\\n" + (html:plain name) (html:plain doc)) + (html:printf "<DT><STRONG>%s</STRONG>\\n" (html:plain name)))) + +(define (html:checkbox name doc pname) + (html:printf "<DT><INPUT TYPE=CHECKBOX NAME=%#a VALUE=T>\\n" + (html:atval pname)) + (if (and (string? doc) (not (equal? "" doc))) + (html:printf "<DD><STRONG>%s</STRONG> (%s)\\n" + (html:plain name) (html:plain doc)) + (html:printf "<DD><STRONG>%s</STRONG>\\n" (html:plain name)))) + +(define (html:text name doc pname default) + (cond (default + (html:dt-strong-doc name doc) + (html:printf "<DD><INPUT NAME=%#a SIZE=%d VALUE=%#a>\\n" + (html:atval pname) + (max 20 (string-length + (if (symbol? default) + (symbol->string default) default))) + (html:atval default))) + (else + (html:dt-strong-doc name doc) + (html:printf "<DD><INPUT NAME=%#a>\\n" (html: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" + (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))) + (for-each (lambda (line) (html:printf "%s\\n" (html:plain line))) default-list) + (html:printf "</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<?)) + (html:dt-strong-doc name doc) + (html:printf "<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 ""))) + (for-each (lambda (value) + (html:printf "<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))) + (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" + (html:atval pname) (html:atval value) + (if (member value default-list) " CHECKED" "") + (html:plain value))) + value-list)) + ((nary nary1) + (for-each (lambda (value) + (html:printf + "<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))) + (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" + (html:atval method) (html: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" + (html:atval '*command*) (html:atval submit-label)) + (html:printf "</FORM><HR>\\n")) + +;;@body Outputs headers for an HTML page named @1. +(define (html:start-page title) + (html:printf "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\\n") + (html:comment) + (html:printf "<HEAD><TITLE>%s</TITLE></HEAD>\\n" (html:plain title)) + (html:printf "<BODY><H1>%s</H1>\\n" (html:plain title))) + +;;@body Outputs HTML codes to end a page. +(define (html:end-page) + (html:printf "</BODY>\\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) + (dynamic-wind + (lambda () + (html:printf "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" + (html:plain comname) (html: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 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) +;; (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))) +;;@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)))))) + +(define (cgi:process-% str) + (define len (string-length str)) + (define (sub str) + (cond + ((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 (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 (string-index txt #\=) + (string-index txt #\=))) + ((not edx) lst) + (let* ((rxt (substring txt (+ 1 edx) (string-length txt))) + (adx (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 (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) + (string-index request-uri #\?) + (substring request-uri + (+ 1 (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))) |