90 lines
3.3 KiB
Scheme
90 lines
3.3 KiB
Scheme
;; Copyright 2002, 2003 Andreas Bernauer
|
|
|
|
;; Bindings of POST requests can be read only once, since they are
|
|
;; read from an input port. So we have to cache them, for the case of
|
|
;; a later GET-BINDINGS call on the same POST request. The requests
|
|
;; are referenced by a weak pointer. Thread-safe as all threads use
|
|
;; the same lock.
|
|
(define *POST-bindings-cache* '())
|
|
(define *cache-lock* (make-lock))
|
|
|
|
(define (get-bindings surflet-request)
|
|
(let ((request-method (surflet-request-method surflet-request)))
|
|
(cond
|
|
((string=? request-method "GET")
|
|
(form-query-list (http-url-search
|
|
(surflet-request-url surflet-request))))
|
|
((string=? request-method "POST")
|
|
(or (cached-bindings surflet-request)
|
|
(let* ((content-length (get-content-length
|
|
(surflet-request-headers surflet-request)))
|
|
(input-port (surflet-request-input-port surflet-request))
|
|
(form-data (read-string content-length input-port)))
|
|
(let ((form-bindings (form-query-list form-data)))
|
|
(obtain-lock *cache-lock*)
|
|
(set! *POST-bindings-cache* (cons (cons (make-weak-pointer surflet-request)
|
|
form-bindings)
|
|
*POST-bindings-cache*))
|
|
(release-lock *cache-lock*)
|
|
form-bindings))))
|
|
(else
|
|
(error "unsupported request type")))))
|
|
|
|
;; Looking up, if we have cached this request. While going through the
|
|
;; list, we remove entries to request objects, that are no longer
|
|
;; valid. Expecting a call for an uncached request every now and then,
|
|
;; it is guaranteed, that the list is cleaned up every now and
|
|
;; then. The cache is a list of pairs
|
|
;;; (surflet-request . computed-binding)
|
|
(define (cached-bindings surflet-request)
|
|
(obtain-lock *cache-lock*)
|
|
(let ((result
|
|
(let loop ((cache *POST-bindings-cache*))
|
|
(if (null? cache)
|
|
#f ; no such request cached
|
|
(let* ((head (car cache))
|
|
(s-req (weak-pointer-ref (car head))))
|
|
(if s-req
|
|
(if (eq? s-req surflet-request)
|
|
(cdar cache) ; request is cached
|
|
(loop (cdr cache))) ; request isn't cached
|
|
(begin
|
|
;; request object is gone ==> remove it from list
|
|
(set! cache (cdr cache))
|
|
(loop cache))))))))
|
|
(release-lock *cache-lock*)
|
|
result))
|
|
|
|
|
|
;; Will be needed when we handle POST requests.
|
|
(define (get-content-length headers)
|
|
(cond ((get-header headers 'content-length) =>
|
|
;; adopted from httpd/cgi-server.scm
|
|
(lambda (content-length) ; Skip initial whitespace (& other non-digits).
|
|
(let ((first-digit (string-index content-length char-set:digit))
|
|
(content-length-len (string-length content-length)))
|
|
(if first-digit
|
|
(string->number (substring content-length first-digit
|
|
content-length-len))
|
|
;; (status-code bad-request) req
|
|
(error "Illegal `Content-length:' header.")))))
|
|
(else
|
|
(error "No Content-length specified for POST data."))))
|
|
|
|
(define (extract-bindings key bindings)
|
|
(let ((key (if (symbol? key) (symbol->string key) key)))
|
|
(map cdr
|
|
(filter (lambda (binding)
|
|
(equal? (car binding) key))
|
|
bindings))))
|
|
|
|
(define (extract-single-binding key bindings)
|
|
(let ((key-bindings (extract-bindings key bindings)))
|
|
(if (= 1 (length key-bindings))
|
|
(car key-bindings)
|
|
(error "extract-one-binding: more than one or zero bindings found"
|
|
(length key-bindings)
|
|
key bindings))))
|
|
|
|
|