1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00

add request-meta

* module/web/request.scm (<request>): Add `meta' field and accessor, for
  metadata like the server IP, the client IP, CGI environment variables,
  etc.
  (build-request): Add meta kwarg.
  (read-request): Add meta optional arg.
  (write-request): Adapt.
This commit is contained in:
Andy Wingo 2010-11-12 12:12:34 +01:00
parent 13b7e2a6e6
commit d4b6200a0a

View file

@ -31,6 +31,7 @@
request-uri request-uri
request-version request-version
request-headers request-headers
request-meta
request-port request-port
read-request read-request
@ -121,12 +122,13 @@
;;; ;;;
(define-record-type <request> (define-record-type <request>
(make-request method uri version headers port) (make-request method uri version headers meta port)
request? request?
(method request-method) (method request-method)
(uri request-uri) (uri request-uri)
(version request-version) (version request-version)
(headers request-headers) (headers request-headers)
(meta request-meta)
(port request-port)) (port request-port))
(define (bad-request message . args) (define (bad-request message . args)
@ -152,7 +154,8 @@
(bad-request "Headers not a list: ~a" headers)))) (bad-request "Headers not a list: ~a" headers))))
(define* (build-request #:key (method 'GET) uri (version '(1 . 1)) (define* (build-request #:key (method 'GET) uri (version '(1 . 1))
(headers '()) port (validate-headers? #t)) (headers '()) port (meta '())
(validate-headers? #t))
(cond (cond
((not (and (pair? version) ((not (and (pair? version)
(non-negative-integer? (car version)) (non-negative-integer? (car version))
@ -162,17 +165,20 @@
(bad-request "Bad uri: ~a" uri)) (bad-request "Bad uri: ~a" uri))
((and (not port) (memq method '(POST PUT))) ((and (not port) (memq method '(POST PUT)))
(bad-request "Missing port for message ~a" method)) (bad-request "Missing port for message ~a" method))
((not (list? meta))
(bad-request "Bad metadata alist" meta))
(else (else
(if validate-headers? (if validate-headers?
(validate-headers headers)))) (validate-headers headers))))
(make-request method uri version headers port)) (make-request method uri version headers meta port))
(define (read-request port) (define* (read-request port #:optional (meta '()))
(set-port-encoding! port "ISO-8859-1") (set-port-encoding! port "ISO-8859-1")
(call-with-values (lambda () (read-request-line port)) (call-with-values (lambda () (read-request-line port))
(lambda (method uri version) (lambda (method uri version)
(make-request method uri version (read-headers port) port)))) (make-request method uri version (read-headers port) meta port))))
;; FIXME: really return a new request?
(define (write-request r port) (define (write-request r port)
(write-request-line (request-method r) (request-uri r) (write-request-line (request-method r) (request-uri r)
(request-version r) port) (request-version r) port)
@ -181,7 +187,7 @@
(if (eq? port (request-port r)) (if (eq? port (request-port r))
r r
(make-request (request-method r) (request-uri r) (request-version r) (make-request (request-method r) (request-uri r) (request-version r)
(request-headers r) port))) (request-headers r) (request-meta r) port)))
;; Probably not what you want to use "in production". Relies on one byte ;; Probably not what you want to use "in production". Relies on one byte
;; per char because we are in latin-1 encoding. ;; per char because we are in latin-1 encoding.