;;; "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 "\\n")) (define (html:dt-strong-doc name doc) (if (and (string? doc) (not (equal? "" doc))) (html:printf "
%s (%s)\\n" (html:plain name) (html:plain doc)) (html:printf "
%s\\n" (html:plain name)))) (define (html:checkbox name doc pname) (html:printf "
\\n" (html:atval pname)) (if (and (string? doc) (not (equal? "" doc))) (html:printf "
%s (%s)\\n" (html:plain name) (html:plain doc)) (html:printf "
%s\\n" (html:plain name)))) (define (html:text name doc pname default) (cond (default (html:dt-strong-doc name doc) (html:printf "
\\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 "
\\n" (html:atval pname))))) (define (html:text-area name doc pname default-list) (html:dt-strong-doc name doc) (html:printf "
\\n")) (define (html:sstring 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\\n")) (define (html:buttons name doc pname arity default-list value-list) (set! value-list (sort! value-list html:s") (case arity ((single optional) (for-each (lambda (value) (html:printf "
  • %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 "
  • %s\\n" (html:atval pname) (html:atval value) (if (member value default-list) " CHECKED" "") (html:plain value))) value-list))) (html:printf "
  • ")) ;;@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 "
    \\n" (html:atval method) (html:atval action)) (html:printf "
    \\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 "
    \\n") (html:printf " \\n" (html:atval '*command*) (html:atval submit-label)) (html:printf "

    \\n")) ;;@body Outputs headers for an HTML page named @1. (define (html:start-page title) (html:printf "\\n") (html:comment) (html:printf "%s\\n" (html:plain title)) (html:printf "

    %s

    \\n" (html:plain title))) ;;@body Outputs HTML codes to end a page. (define (html:end-page) (html:printf "\\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 "

    %s:

    %s
    \\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* "SLIB 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 "
    \\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)))