summaryrefslogtreecommitdiffstats
path: root/http-cgi.scm
diff options
context:
space:
mode:
authorJames LewisMoss <dres@debian.org>2001-07-27 23:45:29 -0400
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commitf559c149c83da84d0b1c285f0298c84aec564af9 (patch)
treef1c91bcb9bb5e6dad87b643127c3f878d80d89ee /http-cgi.scm
parentc394920caedf3dac1981bb6b10eeb47fd6e4bb21 (diff)
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-f559c149c83da84d0b1c285f0298c84aec564af9.tar.gz
slib-f559c149c83da84d0b1c285f0298c84aec564af9.zip
Import Debian changes 2d2-1debian/2d2-1
slib (2d2-1) unstable; urgency=low * New upstream version * Revert back to free. Is now so. slib (2d1-1) unstable; urgency=low * New upstream version. * Move to non-free. FSF pointed out license doesn't allow modified versions to be distributed. * Get a complete list of copyrights that apply to the source into copyright file. * Remove setup for guile 1.3. * Remove postrm. Just calling install-info (lintian) Move install-info call to prerm since doc-base doesn't do install-info. slib (2c9-3) unstable; urgency=low * Change info location to section "The Algorithmic Language Scheme" to match up with where guile puts it's files. * Postinst is running slibconfig now. (Closes: #75891) slib (2c9-2) unstable; urgency=low * Stop installing slibconfig (for guile). * In postinst if /usr/sbin/slibconnfig exists call it (Close: #75843 #75891). slib (2c9-1) unstable; urgency=low * New upstream (Closes: #74760) * replace string-index with strsrch:string-index in http-cgi.scm. * Add doc-base support (Closes: #31163)
Diffstat (limited to 'http-cgi.scm')
-rw-r--r--http-cgi.scm440
1 files changed, 440 insertions, 0 deletions
diff --git a/http-cgi.scm b/http-cgi.scm
new file mode 100644
index 0000000..a313758
--- /dev/null
+++ b/http-cgi.scm
@@ -0,0 +1,440 @@
+;;; "http-cgi.scm" service HTTP or CGI requests. -*-scheme-*-
+; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, 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 'uri)
+(require 'scanf)
+(require 'printf)
+(require 'coerce)
+(require 'line-i/o)
+(require 'html-form)
+(require 'parameters)
+(require 'string-case)
+
+;;@code{(require 'http)} or @code{(require 'cgi)}
+;;@ftindex http
+;;@ftindex cgi
+
+(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 (strsrch: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)
+ (strsrch:string-index request-uri #\?)
+ (substring request-uri
+ (+ 1 (strsrch: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:status-line status-code reason)
+ (sprintf #f "HTTP/1.1 %d %s%s" status-code reason http:crlf))
+
+;;@body Returns a string containing lines for each element of @1; the
+;;@code{car} of which is followed by @samp{: }, then the @code{cdr}.
+(define (http:header alist)
+ (string-append
+ (apply string-append
+ (map (lambda (pair)
+ (sprintf #f "%s: %s%s" (car pair) (cdr pair) http:crlf))
+ alist))
+ http:crlf))
+
+;;@body Returns the concatenation of strings @2 with the
+;;@code{(http:header @1)} and the @samp{Content-Length} prepended.
+(define (http:content alist . body)
+ (define hunk (apply string-append body))
+ (string-append (http:header
+ (cons (cons "Content-Length"
+ (number->string (string-length hunk)))
+ alist))
+ hunk))
+
+;;@body String appearing at the bottom of error pages.
+(define *http:byline* #f)
+
+;;@body @1 and @2 should be an integer and string as specified in
+;;@cite{RFC 2068}. The returned page (string) will show the @1 and @2
+;;and any additional @3 @dots{}; with @var{*http:byline*} or SLIB's
+;;default at the bottom.
+(define (http:error-page status-code reason-phrase . html-strings)
+ (define byline
+ (or
+ *http:byline*
+ (sprintf
+ #f
+ "<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB</A> %s server"
+ (if (getenv "SERVER_PROTOCOL") "CGI/1.1" "HTTP/1.1"))))
+ (string-append (http:status-line status-code reason-phrase)
+ (http:content
+ '(("Content-Type" . "text/html"))
+ (html:head (sprintf #f "%d %s" status-code reason-phrase))
+ (apply html:body
+ (append html-strings
+ (list (sprintf #f "<HR>\\n%s\\n" byline)))))))
+
+;;@body The string or symbol @1 is the page title. @2 is a non-negative
+;;integer. The @4 @dots{} are typically used to explain to the user why
+;;this page is being forwarded.
+;;
+;;@0 returns an HTML string for a page which automatically forwards to
+;;@3 after @2 seconds. The returned page (string) contains any @4
+;;@dots{} followed by a manual link to @3, in case the browser does not
+;;forward automatically.
+(define (http:forwarding-page title delay uri . html-strings)
+ (string-append
+ (html:head title #f (html:meta-refresh delay uri))
+ (apply html:body
+ (append html-strings
+ (list (sprintf #f "\\n\\n<HR>\\nReturn to %s.\\n"
+ (html:link uri title)))))))
+
+;;@body reads the @dfn{URI} and @dfn{query-string} from @2. If the
+;;query is a valid @samp{"POST"} or @samp{"GET"} query, then @0 calls
+;;@1 with three arguments, the @var{request-line}, @var{query-string},
+;;and @var{header-alist}. Otherwise, @0 calls @1 with the
+;;@var{request-line}, #f, and @var{header-alist}.
+;;
+;;If @1 returns a string, it is sent to @3. If @1 returns a list,
+;;then an error page with number 525 and strings from the list. If @1
+;;returns #f, then a @samp{Bad Request} (400) page is sent to @3.
+;;
+;;Otherwise, @0 replies (to @3) with appropriate HTML describing the
+;;problem.
+(define (http:serve-query serve-proc input-port output-port)
+ (let* ((request-line (http:read-request-line input-port))
+ (header (and request-line (http:read-header input-port)))
+ (query-string (and header (http:read-query-string
+ request-line header input-port))))
+ (display (http:service serve-proc request-line query-string header)
+ output-port)))
+
+(define (http:service serve-proc request-line query-string header)
+ (cond ((not request-line) (http:error-page 400 "Bad Request."))
+ ((string? (car request-line))
+ (http:error-page 501 "Not Implemented" (html:plain request-line)))
+ ((not (memq (car request-line) '(get post)))
+ (http:error-page 405 "Method Not Allowed" (html:plain request-line)))
+ ((serve-proc request-line query-string header) =>
+ (lambda (reply)
+ (cond ((string? reply)
+ (string-append (http:status-line 200 "OK")
+ reply))
+ ((and (pair? reply) (list? reply))
+ (if (number? (car reply))
+ (apply http:error-page reply)
+ (apply http:error-page 525 reply)))
+ (else (http:error-page 500 "Internal Server Error")))))
+ ((not query-string)
+ (http:error-page 400 "Bad Request" (html:plain request-line)))
+ (else
+ (http:error-page 500 "Internal Server Error" (html:plain header)))))
+
+;;@
+;;
+;;This example services HTTP queries from @var{port-number}:
+;;@example
+;;
+;;(define socket (make-stream-socket AF_INET 0))
+;;(and (socket:bind socket port-number) ; AF_INET INADDR_ANY
+;; (socket:listen socket 10) ; Queue up to 10 requests.
+;; (dynamic-wind
+;; (lambda () #f)
+;; (lambda ()
+;; (do ((port (socket:accept socket) (socket:accept socket)))
+;; (#f)
+;; (let ((iport (duplicate-port port "r"))
+;; (oport (duplicate-port port "w")))
+;; (http:serve-query build:serve iport oport)
+;; (close-port iport)
+;; (close-port oport))
+;; (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
+;; Request lines are a list of three itmes:
+;;
+;; @enumerate 0
+;;
+;; @item Method
+;;
+;; A symbol (@code{options}, @code{get}, @code{head}, @code{post},
+;; @code{put}, @code{delete}, @code{trace} @dots{}).
+;;
+;; @item Request-URI
+;;
+;; A string. For direct HTTP, 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))
+ (cons (string-ci->symbol (car lst)) (cdr lst)))))
+(define (cgi:request-line)
+ (define method (getenv "REQUEST_METHOD"))
+ (and method
+ (list (string-ci->symbol method)
+ (getenv "SCRIPT_NAME")
+ (getenv "SERVER_PROTOCOL"))))
+
+(define (cgi:query-header)
+ (define assqs '())
+ (cond ((and (getenv "SERVER_NAME") (getenv "SERVER_PORT"))
+ (set! assqs (cons (cons 'host (string-append (getenv "SERVER_NAME")
+ ":"
+ (getenv "SERVER_PORT")))
+ assqs))))
+ (for-each
+ (lambda (envar)
+ (define valstr (getenv envar))
+ (if valstr (set! assqs
+ (cons (cons (string-ci->symbol
+ (string-subst envar "HTTP_" "" "_" "-"))
+ valstr)
+ assqs))))
+ '(
+ ;;"AUTH_TYPE"
+ "CONTENT_LENGTH"
+ "CONTENT_TYPE"
+ "DOCUMENT_ROOT"
+ "GATEWAY_INTERFACE"
+ "HTTP_ACCEPT"
+ "HTTP_ACCEPT_CHARSET"
+ "HTTP_ACCEPT_ENCODING"
+ "HTTP_ACCEPT_LANGUAGE"
+ "HTTP_CONNECTION"
+ "HTTP_HOST"
+ ;;"HTTP_PRAGMA"
+ "HTTP_REFERER"
+ "HTTP_USER_AGENT"
+ "PATH_INFO"
+ "PATH_TRANSLATED"
+ "QUERY_STRING"
+ "REMOTE_ADDR"
+ "REMOTE_HOST"
+ ;;"REMOTE_IDENT"
+ ;;"REMOTE_USER"
+ "REQUEST_URI"
+ "SCRIPT_FILENAME"
+ "SCRIPT_NAME"
+ ;;"SERVER_SIGNATURE"
+ ;;"SERVER_SOFTWARE"
+ ))
+ assqs)
+
+;; @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)))
+
+;;@body reads the @dfn{URI} and @dfn{query-string} from
+;;@code{(current-input-port)}. If the query is a valid @samp{"POST"}
+;;or @samp{"GET"} query, then @0 calls @1 with three arguments, the
+;;@var{request-line}, @var{query-string}, and @var{header-alist}.
+;;Otherwise, @0 calls @1 with the @var{request-line}, #f, and
+;;@var{header-alist}.
+;;
+;;If @1 returns a string, it is sent to @code{(current-input-port)}.
+;;If @1 returns a list, then an error page with number 525 and strings
+;;from the list. If @1 returns #f, then a @samp{Bad Request} (400)
+;;page is sent to @code{(current-input-port)}.
+;;
+;;Otherwise, @0 replies (to @code{(current-input-port)}) with
+;;appropriate HTML describing the problem.
+(define (cgi:serve-query serve-proc)
+ (let* ((script-name (getenv "SCRIPT_NAME"))
+ (request-line (cgi:request-line))
+ (header (and request-line (cgi:query-header)))
+ (query-string (and header (cgi:read-query-string)))
+ (reply (http:service serve-proc request-line query-string header)))
+ (display (if (and script-name
+ (not (eqv? 0 (substring? "nph-" script-name))))
+ ;; Eat http status line.
+ (substring reply (+ 2 (substring? http:crlf reply))
+ (string-length reply))
+ reply))))
+
+(define (coerce->list str type)
+ (case type
+ ((expression)
+ (slib:warn 'coerce->list 'unsafe 'read)
+ (do ((tok (read port) (read port))
+ (lst '() (cons tok lst)))
+ ((or (null? tok) (eof-object? tok)) lst)))
+ ((symbol)
+ (call-with-input-string str
+ (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)) lst)))))
+ (else
+ (call-with-input-string str
+ (lambda (port)
+ (do ((tok (scanf-read-list " %s" port)
+ (scanf-read-list " %s" port))
+ (lst '() (cons (coerce (car tok) type) lst)))
+ ((or (null? tok) (eof-object? tok)) lst)))))))
+
+(define (query-alist->parameter-list alist optnames arities types)
+ (let ((parameter-list (make-parameter-list optnames)))
+ (for-each
+ (lambda (lst)
+ (let* ((value (cadr lst))
+ (name (car lst))
+ (opt-pos (position name optnames)))
+ (cond ((not opt-pos)
+ (slib:warn 'query-alist->parameter-list
+ 'unknown 'parameter name))
+ ((eq? (list-ref arities opt-pos) 'boolean)
+ (adjoin-parameters! parameter-list (list name #t)))
+ ((and (equal? value "")
+ (not (memq (list-ref types opt-pos) '(expression string))))
+ (adjoin-parameters! parameter-list (list name #f)))
+ (value
+ (adjoin-parameters!
+ parameter-list
+ (cons name
+ (case (list-ref arities opt-pos)
+ ((nary nary1)
+ (coerce->list value (list-ref types opt-pos)))
+ (else
+ (list (coerce value (list-ref types opt-pos)))))))))))
+ alist)
+ parameter-list))
+
+;;@args rdb command-table
+;;@args rdb command-table #t
+;;
+;;Returns a procedure of one argument. When that procedure is called
+;;with a @var{query-alist} (as returned by @code{uri:decode-query}, the
+;;value of the @samp{*command*} association will be the command invoked
+;;in @2. If @samp{*command*} is not in the @var{query-alist} then the
+;;value of @samp{*suggest*} is tried. If neither name is in the
+;;@var{query-alist}, then the literal value @samp{*default*} is tried in
+;;@2.
+;;
+;;If optional third argument is non-false, then the command is called
+;;with just the parameter-list; otherwise, command is called with the
+;;arguments described in its table.
+(define (make-query-alist-command-server rdb command-table . just-params?)
+ (define comsrvcal (make-command-server rdb command-table))
+ (set! just-params? (if (null? just-params?) #f (car just-params?)))
+ (lambda (query-alist)
+ (define comnam #f)
+ (define find-command?
+ (lambda (cname)
+ (define tryp (parameter-list-ref query-alist cname))
+ (cond ((not tryp) #f)
+ (comnam
+ (set! query-alist (remove-parameter cname query-alist)))
+ (else
+ (set! query-alist (remove-parameter cname query-alist))
+ (set! comnam (string-ci->symbol (car tryp)))))))
+ (find-command? '*command*)
+ (find-command? '*suggest*)
+ (find-command? '*button*)
+ (cond ((not comnam) (set! comnam '*default*)))
+ (cond
+ (comnam
+ (comsrvcal comnam
+ (lambda (comname comval options positions
+ arities types defaulters dirs aliases)
+ (let* ((params (query-alist->parameter-list
+ query-alist options arities types))
+ (fparams (fill-empty-parameters defaulters params)))
+ (and (list? fparams)
+ (check-parameters dirs fparams)
+ (if just-params?
+ (comval fparams)
+ (let ((arglist (parameter-list->arglist
+ positions arities fparams)))
+ (and arglist
+ (apply comval arglist))))))))))))