summaryrefslogtreecommitdiffstats
path: root/htmlform.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commitfa3f23105ddcf07c5900de47f19af43d1db1b597 (patch)
treeb2c6cce6b97698098f50cbc78c23fdc0f8d401ab /htmlform.scm
parentf24b9140d6f74804d5599ec225717d38ca443813 (diff)
downloadslib-fa3f23105ddcf07c5900de47f19af43d1db1b597.tar.gz
slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.zip
Import Upstream version 2c3upstream/2c3
Diffstat (limited to 'htmlform.scm')
-rw-r--r--htmlform.scm663
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
+ "&" "&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)))
+ (string-subst txt
+ "&" "&amp;"
+ "<" "&lt;"
+ ">" "&gt;"))
+
+;;@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)))