;;; File: ;;; webutils.scm ;;; Author: ;;; Samuel A. Rebelsky, rebelsky@grinnell.edu ;;; Version: ;;; 1.6.2 of 25 November 2003 ;;; Location: ;;; Web: http://www.cs.grinnell.edu/~rebelsky/Scheme/webutils.scm ;;; MathLAN: /home/rebelsky/Web/Scheme/webutils.scm ;;; Summary: ;;; A collection of utilities for programming for the Web, ;;; written, in part, to deal with some deficiencies in ;;; DrScheme (so far as I can tell). ;;; Contents: ;;; CGI Procedures: ;;; (get-cgi-variable name default) ;;; Get the value of a CGI variable, using default ;;; if the variable is undefined. ;;; (get-cgi-variable-as-list name) ;;; Get the values associated with a particular CGI variable, ;;; returning them as a list. ;;; (get-nonempty-cgi-variable name default) ;;; Get the value of a CGI variable, using default ;;; if the variable is undefined or empty. ;;; (simulate-cgi settings) ;;; Set up a fake CGI environment for testing ;;; HTML Constants: ;;; html401 ;;; A constant that gives the ugly string that appears at the ;;; top of HTML pages ;;; validate ;;; A "Validate This Page" string to put at the bottom of ;;; your pages. ;;; HTML Procedures: ;;; (body contents) ;;; Build the body of a page. ;;; (form cgi submit contents) ;;; Build an HTML form that links to a particular CGI ;;; script, provides a button with particular text, ;;; and has specified contents. ;;; (head title) ;;; Build the head of a page. ;;; (heading level text) ;;; Generate a heading. ;;; (hidden name value) ;;; Build a hidden field for use within a form. ;;; (make-page head body) ;;; Build a full HTML page. ;;; (markup tag text) ;;; Mark up some text. ;;; (paragraph contents) ;;; Build one paragraph. ;;; (textfield name default) ;;; Build a text field for use within a form. ;;; (textarea name default) ;;; Build a text area for use within a form. ;;; Other Utilities ;;; (lockfile filename) ;;; Lock a file to prevent simultaneous access. ;;; (unlockfile filename) ;;; Unlock the file. ;;; Local Utilities ;;; None of your business. ;;; Examples ;;; Coming Soon. ;;; History: ;;; At end. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Required Libraries (require (lib "cgi.ss" "net")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CGI Procedures ;;; Procedure: ;;; get-cgi-variable ;;; Parameters: ;;; variable-name, a symbol that names a CGI parameter ;;; default, a string ;;; Purpose: ;;; Extracts the CGI parameter with the given name. If no ;;; such parameter exists, uses default. ;;; Produces: ;;; value, a string ;;; Preconditions: ;;; The cgi.ss and net libraries must be loaded. ;;; Postconditions: ;;; If this procedure was invoked from within a CGI environment ;;; and the request included a specification for a value named ;;; variable-name, value is that value. ;;; Otherwise, value is default. ;;; Note: ;;; If there are multiple values associated with a CGI variable ;;; (as is allowed within the specification), this returns only ;;; one of them. To get all of them, use ;;; (get-cgi-variable-as-list name) (define get-cgi-variable (lambda (var default) ; (get-cgi-method) returns the CGI method if running as a ; CGI program. It returns false otherwise. (if (not (get-cgi-method)) ; Not running within CGI. Use the default. default ; Okay, running within CGI. Get the results as a list. (let ((values (extract-bindings var (get-bindings)))) ; Are there any values? (if (null? values) ; If not, use the default default ; Otherwise, use the first value (car values)))))) ;;; Procedure: ;;; get-cgi-variable-as-list ;;; Parameters: ;;; variable-name, a symbol that names a CGI parameter ;;; Purpose: ;;; Extracts all values bound to the CGI parameter with the given name. ;;; If no such parameter exists, returns the empty list. ;;; Produces: ;;; values, a list of strings ;;; Preconditions: ;;; The cgi.ss and net libraries must be loaded. ;;; Postconditions: ;;; If this procedure was invoked from within a CGI environment ;;; and the request included one or more specifications for a ;;; variable-name, values contains all such values. ;;; Otherwise, values is the empty list. (define get-cgi-variable-as-list (lambda (var) ; (get-cgi-method) returns the CGI method if running as a ; CGI program. It returns false otherwise. (if (not (get-cgi-method)) ; Not running within CGI. Use null null ; Okay, running within CGI. Get the results as a list. (extract-bindings var (get-bindings))))) ;;; Procedure: ;;; get-nonempty-cgi-variable ;;; Parameters: ;;; variable-name, a symbol that names a CGI parameter ;;; default, a string ;;; Purpose: ;;; Extracts the CGI parameter with the given name. If no ;;; such parameter exists or if it's set to the empty string, ;;; uses default instead. ;;; Produces: ;;; value, a string ;;; Preconditions: ;;; The cgi.ss and net libraries must be loaded. ;;; Postconditions: ;;; If this procedure was invoked from within a CGI environment ;;; and the request included a specification for a nonempty ;;; value named variable-name, value is that value. ;;; Otherwise, value is default. ;;; Note: ;;; If there are multiple values associated with a CGI variable ;;; (as is allowed within the specification), this may not ;;; behave correctly. (E.g., if the first one is empty.) (define get-nonempty-cgi-variable (lambda (variable-name default) (let ((potential-value (get-cgi-variable variable-name default))) (if (equal? potential-value "") default potential-value)))) ;;; Procedure: ;;; simulate-cgi ;;; Parameters: ;;; settings, a list of lists ;;; Purpose: ;;; Sets up a fake CGI environment so that the DrScheme cgi ;;; library works correctly, even when not run from the Web. ;;; Produces: ;;; A list of bindings in the form returned by get-bindings. ;;; Preconditions: ;;; Each element of settings must be a list of two strings. ;;; Element 0 is the CGI variable. Element 1 is its value. ;;; Postconditions: ;;; get-bindings (from the DrScheme cgi.ss library) will ;;; behave correctly. ;;; Each pair will be set as a CGI binding. ;;; Practica: ;;; (simulate-cgi (list (list "user" "samr")) ;;; (extract-binding/single "user" (get-bindings)) => "samr" (define simulate-cgi (lambda (lst) (putenv "REQUEST_METHOD" "GET") (putenv "QUERY_STRING" (list->query lst)) (get-bindings))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; HTML Constants ;;; Value: ;;; html401 ;;; Type: ;;; String ;;; Purpose: ;;; The wonderful string that goes at the top of valid HTML ;;; 4.01 pages. (define html401 (string-append "")) ;;; Value: ;;; validate ;;; Type: ;;; String ;;; Purpose: ;;; A link to the Validator. (define validate (string-append "

" "" "Validate this page" "" "." "

")) ;;; Value: ;;; valid ;;; Type: ;;; String ;;; Purpose: ;;; An image that indicates that the page is valid. (define valid "

\"Valid

") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; HTML Procedures ;;; Procedure: ;;; body ;;; Parameters: ;;; contents, the intended contents of a page ;;; Purpose: ;;; Generates some nice happy HTML that represents the body of ;;; a page with a particular contents. ;;; Produces: ;;; body-html, a string for HTML that represents the body. ;;; Preconditions: ;;; contents is a string ;;; contents represents valid, though partial, HTML ;;; Postconditions: ;;; body-html is some nice HTML which you can join with a ;;; head and some html tags to make a full page. ;;; body-html may contain carriage returns (newlines). (define body (lambda (contents) (markup "body" (string-append (string #\newline) contents (string #\newline) validate (string #\newline))))) ;;; Procedure: ;;; form ;;; Parameters: ;;; cgi-script, a string that gives the URL (relative or absolute) ;;; of a CGI program ;;; submit-text, the text of the submit button ;;; contents, the contents of the form ;;; Purpose: ;;; Creates HTML for a form (including the submit button!) ;;; Produces: ;;; form-code, a string ;;; Preconditions: ;;; cgi-script, submit-text, and contents must all be strings ;;; cgi-script must name a valid URL ;;; contents must be valid HTML ;;; Postconditions: ;;; form-code provides valid HTML for a form. ;;; When that form is used, the submit button leads to cgi. (define form (lambda (cgi-script submit contents) (string-append "
" (string #\newline) contents (string #\newline) "

" (string #\newline) "
" (string #\newline)))) ;;; Procedure: ;;; form-default ;;; Parameters: ;;; cgi-script, the URL (relative or absolute) of a CGI program. ;;; contents, the contents of the form. ;;; Purpose: ;;; Creates HTML for a form. The HTML does not include a submit ;;; button (unless contents includes one). ;;; Produces: ;;; form-code, a string. ;;; Preconditions: ;;; cgi, submit, and contents must all be strings ;;; cgi must be a valid URL ;;; contents must be valid HTML ;;; Postconditions: ;;; form-code provides valid HTML for a form ;;; When that form is used, the submit button leads to cgi-script. (define form-default (lambda (cgi contents) (string-append "
" (string #\newline) contents (string #\newline) "
" (string #\newline)))) ;;; Procedure: ;;; head ;;; Parameters: ;;; title, a string that gives the title of the page ;;; Purpose: ;;; Generates some nice happy HTML that represents the head of ;;; a page with a particular title. ;;; Produces: ;;; head-html, string for HTML that represents the head. ;;; Preconditions: ;;; The title is a string with no internal HTML. ;;; Postconditions: ;;; head-html procudes some nice HTML which a normal browser displays ;;; as the titlebar of a window. (define head (lambda (title . extra) (markup "head" (string-append (string #\newline) "" (string #\newline) (markup "title" title) (if (not (null? extra)) (car extra) ""))))) ;;; Procedure: ;;; heading ;;; Parameters: ;;; level, a heading level (1-6) ;;; text, some text to mark up ;;; Purpose: ;;; Generates some nice happy HTML that represents the heading of ;;; a section of text. ;;; Produces: ;;; heading-html, a string for HTML that represents the heading. ;;; Preconditions: ;;; Level is an exact integer between 1 and 6, inclusive. ;;; text is a string. ;;; text is valid HTML. ;;; Postconditions: ;;; heading-html is valid HTML which a normal browser displays ;;; as a heading. (define heading (lambda (level text) (markup (string-append "h" (number->string level)) text))) ;;; Procedure: ;;; hidden ;;; Parameters: ;;; nm, the name of a CGI variable. ;;; val, the desired value of a CGI variable. ;;; Purpose: ;;; Builds a hidden field to pass on a CGI variable. ;;; Produces: ;;; fieldcode, a string. ;;; Preconditions: ;;; nm and val must be strings. ;;; Neither nm nor val should contain quotation marks. ;;; Postconditions: ;;; Returns valid HTML for a hidden field that associates ;;; val with nm (that binds val to nm). ;;; fieldcode ends with a newline (define hidden (lambda (nm val) (string-append "" (string #\newline)))) ;;; Procedure: ;;; make-page ;;; Parameters: ;;; head, the head of a page ;;; body, the body of a page ;;; Purpose: ;;; Shoves the head and the body together to make a page. Even ;;; adds the wonderful HTML specification code. ;;; Produces: ;;; HTML for a full page. Wow! ;;; Preconditions: ;;; head was created by the head procedure ;;; body was created by the body procedure ;;; Postconditions: ;;; You get some nice HTML which a normal browser displays ;;; appropriately. (define make-page (lambda (head body) (string-append html401 (string #\newline) "" (string #\newline) head (string #\newline) body (string #\newline) "" (string #\newline)))) ;;; Procedure: ;;; markup ;;; Parameters: ;;; tag, the role that some text plays ;;; text, some text to mark up ;;; Purpose: ;;; Generates some nice happy HTML for me. ;;; Produces: ;;; html-code, a string for HTML that represents the marked text. ;;; Preconditions: ;;; Both parameters are strings. ;;; The text is valid HTML. ;;; The tag contains only alphanumeric characters and ;;; corresponds to a valid HTML tag. ;;; Postconditions: ;;; html-code is valid html. (define markup (lambda (tag text) (string-append "<" tag ">" text ""))) ;;; Procedure: ;;; paragraph ;;; Parameters: ;;; contents, the contents of the paragraph ;;; Purpose: ;;; Generates some HTML that represents on paragraph. ;;; Also to annoy the world with introductory comments that are ;;; significantly longer than the procedure needs. ;;; Produces: ;;; paragraph-html, a string for HTML that represents the paragraph. ;;; Preconditions: ;;; contents is valid HTML with no block-level elements. ;;; Postconditions: ;;; paragraph-html provides valid HTML for a paragraph. (define paragraph (lambda (contents) (markup "p" contents))) ;;; Procedure: ;;; textarea ;;; Parameters: ;;; nm, the name of a CGI variable. ;;; def, the default value of that CGI variable. ;;; Purpose: ;;; Builds a text area which can be used to enter a CGI variable. ;;; Produces: ;;; code, a string. ;;; Preconditions: ;;; nm and def must be strings. ;;; Neither nm nor def should contain quotation marks. ;;; Postconditions: ;;; code is valid HTML for a text field with default value def. ;;; code ends with a newline. (define textarea (lambda (nm def) (string-append "" (string #\newline)))) ;;; Procedure: ;;; textfield ;;; Parameters: ;;; nm, the name of a CGI variable. ;;; def, the default value of that CGI variable. ;;; Purpose: ;;; Builds a text field which can be used to enter a CGI variable. ;;; Produces: ;;; fieldcode, a string. ;;; Preconditions: ;;; nm and def must be strings. ;;; Neither nm nor def should contain quotation marks. ;;; Postconditions: ;;; fieldcode is valid HTML for a text field with default value def. ;;; fieldcode ends with a newline. (define textfield (lambda (nm def) (string-append "" (string #\newline)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Other Utilities ;;; Procedure: ;;; lockfile ;;; Parameters: ;;; filename, a string ;;; Purpose: ;;; Locks a file so that only one program can access ;;; it (provided all of them use lockfile). ;;; Produces: ;;; Absolutely nothing. ;;; Preconditions: ;;; Must be run on a Linux system which provides lockfile. ;;; All procedures that access the given file must use ;;; lockfile. ;;; Postconditions: ;;; The program using lockfile can read from or write to ;;; the file. ;;; No other program can read from or write to the file. ;;; Note: ;;; Your program will "freeze" while waiting for the file ;;; to unlock (define lockfile (lambda (filename) (if #f (system (string-append "lockfile " filename ".lock"))))) ;;; Procedure: ;;; unlockfile ;;; Parameters: ;;; filename, a string ;;; Purpose: ;;; Unlocks a file so that other programs can now access ;;; that file. ;;; Produces: ;;; Absolutely nothing. ;;; Preconditions: ;;; Must be run on a Linux system which provides lockfile. ;;; All procedures that access the given file must use ;;; lockfile. ;;; Postconditions: ;;; The file is available to other programs for reading ;;; or writing. (define unlockfile (lambda (filename) (if #f (system (string-append "rm -f " filename ".lock"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Local Helpers ;;; I recommend that you avoid using these procedures. ;;; However, you may find some of them useful, so I've ;;; documented them fully. ;;; Procedure: ;;; list->query ;;; Parameters: ;;; settings, a list of lists of strings. ;;; Purpose: ;;; To build a query string of the form generated by most ;;; Web browsers. ;;; Produces: ;;; A string of the form name1=val1&name2=val2&... ;;; Preconditions: ;;; Each list in setting is of the form (name val). ;;; Each element of each list is a string. ;;; Postconditions: ;;; The result string is a valid Web query. ;;; Examples: ;;; (list->query (list (list "user" "samr"))) ;;; => "user=samr" ;;; (list->query (list (list "user" "samr") ;;; (list "status" "prof"))) ;;; => "user=samr&status=prof" (define list->query (lambda (settings) (cond ((null? settings) "") ((null? (cdr settings)) (string-append (caar settings) "=" (query-encode (cadar settings)))) (else (string-append (caar settings) "=" (query-encode (cadar settings)) "&" (list->query (cdr settings))))))) ;;; Procedure: ;;; query-encode ;;; Parameters: ;;; stuff, a string. ;;; Purpose: ;;; Encodes a string for a Web query. Gets rid of non-alphanumeric. ;;; Produces: ;;; encoded, a string. ;;; Preconditions: ;;; stuff must be a string. ;;; Postconditions: ;;; The result contains only valid query characters. (define query-encode (lambda (str) (apply string-append (map query-encode-char (string->list str))))) ;;; Procedure: ;;; query-encode-char ;;; Parameters: ;;; char, a character. ;;; Purpose: ;;; Encodes a character for a Web query. Turns non-alphanumeric ;;; characters into their ;;; Produces: ;;; encoded, a string. ;;; Preconditions: ;;; char must be a character. ;;; Postconditions: ;;; The result represents the character in Web query format. (define query-encode-char (lambda (char) (cond ((char-alphabetic? char) (string char)) ((char-numeric? char) (string char)) ((char=? char #\space) "+") (else (string-append "%" (number->string (char->integer char) 16)))))) ;;; Procedure: ;;; query-decode ;;; Parameters: ;;; query, part of a query string ;;; Purpose: ;;; To decode all of the ugly %2f stuff that appears in query strings. ;;; Produces: ;;; A string without all that ugly stuff. ;;; Preconditions: ;;; query is a string. ;;; The query string is in valid "web query" format (which is ;;; probably poorly-documented and violates SGML standards). ;;; Postconditions: ;;; Returns a new string without encoding. (define query-decode (lambda (str) (letrec ((querychars-decode (lambda (lst) (cond ; No characters? Done ((null? lst) null) ; The plus sign encodes a space ((char=? (car lst) #\+) (cons #\space (querychars-decode (cdr lst)))) ; A percent sign and two digits is the hexidecimal ; representation of an ASCII value. ((char=? (car lst) #\%) (cons (integer->char (string->number (string (cadr lst) (caddr lst)) 16)) (querychars-decode (cdddr lst)))) ; Anything else should be taken verbatim. (else (cons (car lst) (querychars-decode (cdr lst)))))))) (apply string (querychars-decode (string->list str)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; History ;;; Sunday, 11 February 2001 ;;; Wrote first version. Copied HTML stuff from an earlier ;;; file and then updated. ;;; Monday, 12 February 2001 [Version 1.0] ;;; Released. ;;; Thursday, 15 February 2001 [Version 1.01] ;;; Fixed a bug in head. ;;; Wednesday, 21 February 2001 [Version 1.2] ;;; Added form, textfield, and hidden. (Which I'd written ;;; earlier but neglected to put in this library.) ;;; Tuesday, 24 April 2001 [Version 1.2b] ;;; Added lockfile and unlockfile. ;;; Wednesday, 25 April 2001 [Version 1.3] ;;; Released updated version. ;;; Made lockfile and unlockfile non-working because ;;; our Web server doesn't support them. Bleh. ;;; Friday, 7 February 2003 [Version 1.4] ;;; Merged with separately updated version. ;;; Reorganized procedures for clarity. ;;; Wednesday, 20 February 2003 [Version 1.5] ;;; Added get-nonempty-cgi-variable ;;; Added get-cgi-variable-as-list ;;; Added validate string (and updated body to use it). ;;; Added to-do list. ;;; Monday, 3 March 2003 [Version 1.6] ;;; Added valid. ;;; Thursday, 6 March 2003 [Version 1.6.1] ;;; Corrected some typos (Thanks DN). ;;; Tuesday, 25 November 2003 [Version 1.6.2] ;;; Renamed from webutils.ss to webutils.scm. (It should still ;;; be available under the old name.) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; To Do ;;; o Rewrite the get-cgi-variable variants to share more code.