;;; "http-cgi.scm" service HTTP or CGI requests. -*-scheme-*-
; Copyright 1997, 1998, 2000, 2001, 2003 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 warranty 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)
(require 'string-port)
(require 'string-search)
(require 'database-commands)
(require 'common-list-functions) ; position
;;@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
"SLIB %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 "
\\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
\\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)
(call-with-input-string str
(lambda (port)
(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)
(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
(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 (and query-alist (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))))))))))))