reformatting, lots of it
svn: r4929
This commit is contained in:
Eli Barzilay
parent
7746993512
commit
2a4c258bef
|
|
@ -1,15 +1,11 @@
|
||||||
|
|
||||||
(module cgi-unit mzscheme
|
(module cgi-unit mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss") "cgi-sig.ss" (lib "etc.ss"))
|
||||||
(lib "etc.ss"))
|
|
||||||
|
|
||||||
(require "cgi-sig.ss")
|
|
||||||
|
|
||||||
(provide net:cgi@)
|
(provide net:cgi@)
|
||||||
(define net:cgi@
|
(define net:cgi@
|
||||||
(unit/sig net:cgi^
|
(unit/sig net:cgi^
|
||||||
(import)
|
(import)
|
||||||
|
|
||||||
;; type bindings = list ((symbol . string))
|
;; type bindings = list ((symbol . string))
|
||||||
|
|
||||||
;; --------------------------------------------------------------------
|
;; --------------------------------------------------------------------
|
||||||
|
|
@ -30,8 +26,7 @@
|
||||||
|
|
||||||
;; --------------------------------------------------------------------
|
;; --------------------------------------------------------------------
|
||||||
|
|
||||||
;; query-chars->string :
|
;; query-chars->string : list (char) -> string
|
||||||
;; list (char) -> string
|
|
||||||
|
|
||||||
;; -- The input is the characters post-processed as per Web specs, which
|
;; -- The input is the characters post-processed as per Web specs, which
|
||||||
;; is as follows:
|
;; is as follows:
|
||||||
|
|
@ -39,57 +34,53 @@
|
||||||
;; where XX are hex digits, eg, %E7 for ~. The output is a regular
|
;; where XX are hex digits, eg, %E7 for ~. The output is a regular
|
||||||
;; Scheme string with all the characters converted back.
|
;; Scheme string with all the characters converted back.
|
||||||
|
|
||||||
(define query-chars->string
|
(define (query-chars->string chars)
|
||||||
(lambda (chars)
|
(list->string
|
||||||
(list->string
|
(let loop ([chars chars])
|
||||||
(let loop ((chars chars))
|
(if (null? chars) null
|
||||||
(if (null? chars) null
|
(let ([first (car chars)]
|
||||||
(let ((first (car chars))
|
[rest (cdr chars)])
|
||||||
(rest (cdr chars)))
|
(let-values ([(this rest)
|
||||||
(let-values (((this rest)
|
(cond
|
||||||
(cond
|
[(char=? first #\+)
|
||||||
((char=? first #\+)
|
(values #\space rest)]
|
||||||
(values #\space rest))
|
[(char=? first #\%)
|
||||||
((char=? first #\%)
|
(if (and (pair? rest)
|
||||||
(if (and (pair? rest)
|
(pair? (cdr rest)))
|
||||||
(pair? (cdr rest)))
|
(values
|
||||||
(values
|
(integer->char
|
||||||
(integer->char
|
(or (string->number
|
||||||
(or (string->number
|
(string
|
||||||
(string
|
(car rest) (cadr rest))
|
||||||
(car rest) (cadr rest))
|
16)
|
||||||
16)
|
(raise (make-invalid-%-suffix
|
||||||
(raise (make-invalid-%-suffix
|
(if (string->number
|
||||||
(if (string->number
|
(string (car rest))
|
||||||
(string (car rest))
|
16)
|
||||||
16)
|
(cadr rest)
|
||||||
(cadr rest)
|
(car rest))))))
|
||||||
(car rest))))))
|
(cddr rest))
|
||||||
(cddr rest))
|
(raise
|
||||||
(raise
|
(make-incomplete-%-suffix rest)))]
|
||||||
(make-incomplete-%-suffix rest))))
|
[else
|
||||||
(else
|
(values first rest)])])
|
||||||
(values first rest)))))
|
(cons this (loop rest))))))))
|
||||||
(cons this (loop rest)))))))))
|
|
||||||
|
|
||||||
;; string->html :
|
;; string->html : string -> string
|
||||||
;; string -> string
|
|
||||||
;; -- the input is raw text, the output is HTML appropriately quoted
|
;; -- the input is raw text, the output is HTML appropriately quoted
|
||||||
|
|
||||||
(define string->html
|
(define (string->html s)
|
||||||
(lambda (s)
|
(apply string-append (map (lambda (c)
|
||||||
(apply string-append
|
(case c
|
||||||
(map (lambda (c)
|
[(#\<) "<"]
|
||||||
(case c
|
[(#\>) ">"]
|
||||||
((#\<) "<")
|
[(#\&) "&"]
|
||||||
((#\>) ">")
|
[else (string c)]))
|
||||||
((#\&) "&")
|
(string->list s))))
|
||||||
(else (string c))))
|
|
||||||
(string->list s)))))
|
|
||||||
|
|
||||||
(define default-text-color "#000000")
|
(define default-text-color "#000000")
|
||||||
(define default-bg-color "#ffffff")
|
(define default-bg-color "#ffffff")
|
||||||
(define default-link-color "#cc2200")
|
(define default-link-color "#cc2200")
|
||||||
(define default-vlink-color "#882200")
|
(define default-vlink-color "#882200")
|
||||||
(define default-alink-color "#444444")
|
(define default-alink-color "#444444")
|
||||||
|
|
||||||
|
|
@ -97,230 +88,156 @@
|
||||||
;; html-string x list (html-string) x ... -> ()
|
;; html-string x list (html-string) x ... -> ()
|
||||||
|
|
||||||
(define generate-html-output
|
(define generate-html-output
|
||||||
(opt-lambda (title body-lines
|
(opt-lambda (title body-lines
|
||||||
(text-color default-text-color)
|
[text-color default-text-color]
|
||||||
(bg-color default-bg-color)
|
[bg-color default-bg-color]
|
||||||
(link-color default-link-color)
|
[link-color default-link-color]
|
||||||
(vlink-color default-vlink-color)
|
[vlink-color default-vlink-color]
|
||||||
(alink-color default-alink-color))
|
[alink-color default-alink-color])
|
||||||
(let ((sa string-append))
|
(let ([sa string-append])
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (l)
|
(lambda (l) (display l) (newline))
|
||||||
(display l) (newline))
|
`("Content-type: text/html"
|
||||||
`("Content-type: text/html"
|
""
|
||||||
""
|
"<html>"
|
||||||
"<html>"
|
"<!-- The form was processed, and this document was generated,"
|
||||||
"<!-- The form was processed, and this document was generated,"
|
" using the CGI utilities for MzScheme. For more information"
|
||||||
" using the CGI utilities for MzScheme. For more information"
|
" on MzScheme, see"
|
||||||
" on MzScheme, see"
|
" http://www.plt-scheme.org/software/mzscheme/"
|
||||||
" http://www.plt-scheme.org/software/mzscheme/"
|
" and for the CGI utilities, contact"
|
||||||
" and for the CGI utilities, contact"
|
" (sk@cs.brown.edu). -->"
|
||||||
" (sk@cs.brown.edu). -->"
|
"<head>"
|
||||||
|
,(sa "<title>" title "</title>")
|
||||||
"<head>"
|
"</head>"
|
||||||
,(sa "<title>" title "</title>")
|
""
|
||||||
"</head>"
|
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
|
||||||
""
|
,(sa " link=\"" link-color "\"")
|
||||||
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
|
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
|
||||||
,(sa " link=\"" link-color "\"")
|
""
|
||||||
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
|
,@body-lines
|
||||||
""
|
""
|
||||||
,@body-lines
|
"</body>"
|
||||||
""
|
"</html>")))))
|
||||||
"</body>"
|
|
||||||
"</html>")))))
|
|
||||||
|
|
||||||
;; output-http-headers : -> void
|
;; output-http-headers : -> void
|
||||||
(define (output-http-headers)
|
(define (output-http-headers)
|
||||||
(printf "Content-type: text/html~a~n~a~n" #\return #\return))
|
(printf "Content-type: text/html\r\n\r\n"))
|
||||||
|
|
||||||
;; read-until-char :
|
;; read-until-char : iport x char -> list (char) x bool
|
||||||
;; iport x char -> list (char) x bool
|
|
||||||
;; -- operates on the default input port; the second value indicates
|
;; -- operates on the default input port; the second value indicates
|
||||||
;; whether reading stopped because an EOF was hit (as opposed to the
|
;; whether reading stopped because an EOF was hit (as opposed to the
|
||||||
;; delimiter being seen); the delimiter is not part of the result
|
;; delimiter being seen); the delimiter is not part of the result
|
||||||
|
(define (read-until-char ip delimiter)
|
||||||
(define read-until-char
|
(let loop ([chars '()])
|
||||||
(lambda (ip delimiter)
|
(let ([c (read-char ip)])
|
||||||
(let loop ((chars '()))
|
(cond [(eof-object? c) (values (reverse chars) #t)]
|
||||||
(let ((c (read-char ip)))
|
[(char=? c delimiter) (values (reverse chars) #f)]
|
||||||
(cond
|
[else (loop (cons c chars))]))))
|
||||||
((eof-object? c)
|
|
||||||
(values (reverse chars) #t))
|
|
||||||
((char=? c delimiter)
|
|
||||||
(values (reverse chars) #f))
|
|
||||||
(else
|
|
||||||
(loop (cons c chars))))))))
|
|
||||||
|
|
||||||
;; read-name+value :
|
|
||||||
;; iport -> (symbol + bool) x (string + bool) x bool
|
|
||||||
|
|
||||||
|
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
|
||||||
;; -- If the first value is false, so is the second, and the third is
|
;; -- If the first value is false, so is the second, and the third is
|
||||||
;; true, indicating EOF was reached without any input seen. Otherwise,
|
;; true, indicating EOF was reached without any input seen. Otherwise,
|
||||||
;; the first and second values contain strings and the third is either
|
;; the first and second values contain strings and the third is either
|
||||||
;; true or false depending on whether the EOF has been reached. The
|
;; true or false depending on whether the EOF has been reached. The
|
||||||
;; strings are processed to remove the CGI spec "escape"s.
|
;; strings are processed to remove the CGI spec "escape"s.
|
||||||
|
|
||||||
;; This code is _slightly_ lax: it allows an input to end in `&'. It's
|
;; This code is _slightly_ lax: it allows an input to end in `&'. It's
|
||||||
;; not clear this is legal by the CGI spec, which suggests that the last
|
;; not clear this is legal by the CGI spec, which suggests that the last
|
||||||
;; value binding must end in an EOF. It doesn't look like this matters.
|
;; value binding must end in an EOF. It doesn't look like this matters.
|
||||||
;; It would also introduce needless modality and reduce flexibility.
|
;; It would also introduce needless modality and reduce flexibility.
|
||||||
|
(define (read-name+value ip)
|
||||||
|
(let-values ([(name eof?) (read-until-char ip #\=)])
|
||||||
|
(cond [(and eof? (null? name)) (values #f #f #t)]
|
||||||
|
[eof?
|
||||||
|
(generate-error-output
|
||||||
|
(list "Server generated malformed input for POST method:"
|
||||||
|
(string-append
|
||||||
|
"No binding for `" (list->string name) "' field.")))]
|
||||||
|
[else (let-values ([(value eof?) (read-until-char ip #\&)])
|
||||||
|
(values (string->symbol (query-chars->string name))
|
||||||
|
(query-chars->string value)
|
||||||
|
eof?))])))
|
||||||
|
|
||||||
(define read-name+value
|
;; get-bindings/post : () -> bindings
|
||||||
(lambda (ip)
|
(define (get-bindings/post)
|
||||||
(let-values
|
(let-values ([(name value eof?) (read-name+value (current-input-port))])
|
||||||
(((name eof?)
|
(cond [(and eof? (not name)) null]
|
||||||
(read-until-char ip #\=)))
|
[(and eof? name) (list (cons name value))]
|
||||||
(cond
|
[else (cons (cons name value) (get-bindings/post))])))
|
||||||
((and eof? (null? name))
|
|
||||||
(values #f #f #t))
|
|
||||||
(eof?
|
|
||||||
(generate-error-output
|
|
||||||
(list "Server generated malformed input for POST method:"
|
|
||||||
(string-append
|
|
||||||
"No binding for `" (list->string name) "' field."))))
|
|
||||||
(else
|
|
||||||
(let-values (((value eof?)
|
|
||||||
(read-until-char ip #\&)))
|
|
||||||
(values (string->symbol (query-chars->string name))
|
|
||||||
(query-chars->string value)
|
|
||||||
eof?)))))))
|
|
||||||
|
|
||||||
;; get-bindings/post :
|
|
||||||
;; () -> bindings
|
|
||||||
|
|
||||||
(define get-bindings/post
|
|
||||||
(lambda ()
|
|
||||||
(let-values (((name value eof?)
|
|
||||||
(read-name+value
|
|
||||||
(current-input-port))))
|
|
||||||
(cond
|
|
||||||
((and eof? (not name))
|
|
||||||
null)
|
|
||||||
((and eof? name)
|
|
||||||
(list (cons name value)))
|
|
||||||
(else
|
|
||||||
(cons (cons name value)
|
|
||||||
(get-bindings/post)))))))
|
|
||||||
|
|
||||||
;; get-bindings/get :
|
;; get-bindings/get : () -> bindings
|
||||||
;; () -> bindings
|
(define (get-bindings/get)
|
||||||
|
(let ([p (open-input-string (getenv "QUERY_STRING"))])
|
||||||
|
(let loop ()
|
||||||
|
(let-values ([(name value eof?) (read-name+value p)])
|
||||||
|
(cond [(and eof? (not name)) null]
|
||||||
|
[(and eof? name) (list (cons name value))]
|
||||||
|
[else (cons (cons name value) (loop))])))))
|
||||||
|
|
||||||
(define get-bindings/get
|
;; get-bindings : () -> bindings
|
||||||
(lambda ()
|
(define (get-bindings)
|
||||||
(let ((p (open-input-string
|
(if (string=? (get-cgi-method) "POST")
|
||||||
(getenv "QUERY_STRING"))))
|
(get-bindings/post)
|
||||||
(let loop ()
|
(get-bindings/get)))
|
||||||
(let-values (((name value eof?)
|
|
||||||
(read-name+value p)))
|
|
||||||
(cond
|
|
||||||
((and eof? (not name))
|
|
||||||
null)
|
|
||||||
((and eof? name)
|
|
||||||
(list (cons name value)))
|
|
||||||
(else
|
|
||||||
(cons (cons name value)
|
|
||||||
(loop)))))))))
|
|
||||||
|
|
||||||
;; get-bindings :
|
;; generate-error-output : list (html-string) -> <exit>
|
||||||
;; () -> bindings
|
(define (generate-error-output error-message-lines)
|
||||||
|
(generate-html-output "Internal Error" error-message-lines)
|
||||||
|
(exit))
|
||||||
|
|
||||||
(define get-bindings
|
;; bindings-as-html : bindings -> list (html-string)
|
||||||
(lambda ()
|
|
||||||
(if (string=? (get-cgi-method) "POST")
|
|
||||||
(get-bindings/post)
|
|
||||||
(get-bindings/get))))
|
|
||||||
|
|
||||||
;; generate-error-output :
|
|
||||||
;; list (html-string) -> <exit>
|
|
||||||
|
|
||||||
(define generate-error-output
|
|
||||||
(lambda (error-message-lines)
|
|
||||||
(generate-html-output "Internal Error"
|
|
||||||
error-message-lines)
|
|
||||||
(exit)))
|
|
||||||
|
|
||||||
;; bindings-as-html :
|
|
||||||
;; bindings -> list (html-string)
|
|
||||||
;; -- formats name-value bindings as HTML appropriate for displaying
|
;; -- formats name-value bindings as HTML appropriate for displaying
|
||||||
|
(define (bindings-as-html bindings)
|
||||||
|
`("<code>"
|
||||||
|
,@(map (lambda (bind)
|
||||||
|
(string-append (symbol->string (car bind))
|
||||||
|
" --> "
|
||||||
|
(cdr bind)
|
||||||
|
"<br>"))
|
||||||
|
bindings)
|
||||||
|
"</code>"))
|
||||||
|
|
||||||
(define bindings-as-html
|
;; extract-bindings : (string + symbol) x bindings -> list (string)
|
||||||
(lambda (bindings)
|
|
||||||
`("<code>"
|
|
||||||
,@(map
|
|
||||||
(lambda (bind)
|
|
||||||
(string-append
|
|
||||||
(symbol->string (car bind))
|
|
||||||
" --> "
|
|
||||||
(cdr bind)
|
|
||||||
"<br>"))
|
|
||||||
bindings)
|
|
||||||
"</code>")))
|
|
||||||
|
|
||||||
;; extract-bindings :
|
|
||||||
;; (string + symbol) x bindings -> list (string)
|
|
||||||
|
|
||||||
;; -- Extracts the bindings associated with a given name. The semantics
|
;; -- Extracts the bindings associated with a given name. The semantics
|
||||||
;; of forms states that a CHECKBOX may use the same NAME field multiple
|
;; of forms states that a CHECKBOX may use the same NAME field multiple
|
||||||
;; times. Hence, a list of strings is returned. Note that the result
|
;; times. Hence, a list of strings is returned. Note that the result
|
||||||
;; may be the empty list.
|
;; may be the empty list.
|
||||||
|
(define (extract-bindings field-name bindings)
|
||||||
|
(let ([field-name (if (symbol? field-name)
|
||||||
|
field-name (string->symbol field-name))])
|
||||||
|
(let loop ([found null] [bindings bindings])
|
||||||
|
(if (null? bindings)
|
||||||
|
found
|
||||||
|
(if (equal? field-name (caar bindings))
|
||||||
|
(loop (cons (cdar bindings) found) (cdr bindings))
|
||||||
|
(loop found (cdr bindings)))))))
|
||||||
|
|
||||||
(define extract-bindings
|
;; extract-binding/single : (string + symbol) x bindings -> string
|
||||||
(lambda (field-name bindings)
|
|
||||||
(let ((field-name (if (symbol? field-name) field-name
|
|
||||||
(string->symbol field-name))))
|
|
||||||
(let loop ((found null) (bindings bindings))
|
|
||||||
(if (null? bindings)
|
|
||||||
found
|
|
||||||
(if (equal? field-name (caar bindings))
|
|
||||||
(loop (cons (cdar bindings) found) (cdr bindings))
|
|
||||||
(loop found (cdr bindings))))))))
|
|
||||||
|
|
||||||
;; extract-binding/single :
|
|
||||||
;; (string + symbol) x bindings -> string
|
|
||||||
;; -- used in cases where only one binding is supposed to occur
|
;; -- used in cases where only one binding is supposed to occur
|
||||||
|
(define (extract-binding/single field-name bindings)
|
||||||
|
(let* ([field-name (if (symbol? field-name)
|
||||||
|
field-name (string->symbol field-name))]
|
||||||
|
[result (extract-bindings field-name bindings)])
|
||||||
|
(cond
|
||||||
|
[(null? result)
|
||||||
|
(generate-error-output
|
||||||
|
(cons (format "No binding for field `~a':<br>" field-name)
|
||||||
|
(bindings-as-html bindings)))]
|
||||||
|
[(null? (cdr result))
|
||||||
|
(car result)]
|
||||||
|
[else
|
||||||
|
(generate-error-output
|
||||||
|
(cons (format "Multiple bindings for field `~a' where one expected:<br>"
|
||||||
|
field-name)
|
||||||
|
(bindings-as-html bindings)))])))
|
||||||
|
|
||||||
(define extract-binding/single
|
;; get-cgi-method : () -> string
|
||||||
(lambda (field-name bindings)
|
|
||||||
(let ((field-name (if (symbol? field-name) field-name
|
|
||||||
(string->symbol field-name))))
|
|
||||||
(let ((result (extract-bindings field-name bindings)))
|
|
||||||
(cond
|
|
||||||
((null? result)
|
|
||||||
(generate-error-output
|
|
||||||
`(,(string-append "No binding for field `"
|
|
||||||
(if (symbol? field-name)
|
|
||||||
(symbol->string field-name)
|
|
||||||
field-name)
|
|
||||||
"' in <p>")
|
|
||||||
,@(bindings-as-html bindings))))
|
|
||||||
((null? (cdr result))
|
|
||||||
(car result))
|
|
||||||
(else
|
|
||||||
(generate-error-output
|
|
||||||
`(,(string-append "Multiple bindings for field `"
|
|
||||||
(if (symbol? field-name)
|
|
||||||
(symbol->string field-name)
|
|
||||||
field-name)
|
|
||||||
"' where only one was expected in <p>")
|
|
||||||
,@(bindings-as-html bindings)))))))))
|
|
||||||
|
|
||||||
;; get-cgi-method :
|
|
||||||
;; () -> string
|
|
||||||
;; -- string is either GET or POST (though future extension is possible)
|
;; -- string is either GET or POST (though future extension is possible)
|
||||||
|
(define (get-cgi-method)
|
||||||
|
(getenv "REQUEST_METHOD"))
|
||||||
|
|
||||||
(define get-cgi-method
|
;; generate-link-text : string x html-string -> html-string
|
||||||
(lambda ()
|
(define (generate-link-text url anchor-text)
|
||||||
(getenv "REQUEST_METHOD")))
|
(string-append "<a href=\"" url "\">" anchor-text "</a>"))
|
||||||
|
|
||||||
;; generate-link-text :
|
|
||||||
;; string x html-string -> html-string
|
|
||||||
|
|
||||||
(define generate-link-text
|
|
||||||
(lambda (url anchor-text)
|
|
||||||
(string-append "<a href=\"" url "\">" anchor-text "</a>")))
|
|
||||||
|
|
||||||
;; ====================================================================
|
|
||||||
|
|
||||||
)))
|
)))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user