aliens/tekuti
1
0
Fork 0
Code Activity

mod-lisp updates

Browse source 
* tekuti/mod-lisp.scm: update tekuti/mod-lisp to parse headers to
  symbols, and to deal in bytevectors only.
This commit is contained in:
Andy Wingo 2011-02-18 23:14:23 +01:00
parent bed9fff79d
commit f350e252fc
1 changed files with 40 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

123
tekuti/mod-lisp.scm
View file

@ -1,5 +1,5 @@
;; Tekuti ;; Tekuti
;; Copyright (C) 2008, 2010 Andy Wingo <wingo at pobox dot com> ;; Copyright (C) 2008, 2010, 2011 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or ;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as ;; modify it under the terms of the GNU General Public License as
@ -36,63 +36,30 @@
#:use-module (web server)) #:use-module (web server))
;;; FIXME: ignore SIGPIPE, otherwise apache dying will kill us
(define *mod-lisp-headers* (make-hash-table)) (define *mod-lisp-headers* (make-hash-table))
(define (define-mod-lisp-header! sym name parser) (define (define-mod-lisp-header! name parser)
(hash-set! *mod-lisp-headers* name (cons sym parser))) (hashq-set! *mod-lisp-headers* (string->symbol (string-downcase name))
(cons name parser)))
(define (mod-lisp-sym-and-parser name) (define-mod-lisp-header! "server-protocol" parse-http-version)
(hash-ref *mod-lisp-headers* name)) (define-mod-lisp-header! "method" parse-http-method)
(define-mod-lisp-header! "url" parse-request-uri)
(define-mod-lisp-header! "server-ip-addr" identity)
(define-mod-lisp-header! "server-ip-port" string->number)
(define-mod-lisp-header! "remote-ip-addr" identity)
(define-mod-lisp-header! "remote-ip-port" string->number)
(define-mod-lisp-header! "server-id" identity)
(define-mod-lisp-header! "server-ip-addr" identity)
(define-mod-lisp-header! "server-baseversion" identity)
(define-mod-lisp-header! "modlisp-version" identity)
(define-mod-lisp-header! "modlisp-major-version" string->number)
(define-mod-lisp-header! 'server-protocol (define (lookup-mod-lisp-header sym)
"server-protocol" (hashq-ref *mod-lisp-headers* sym))
parse-http-version)
(define-mod-lisp-header! 'method (define (parse-mod-lisp-header hpair val)
"method" ((cdr hpair) val))
parse-http-method)
(define-mod-lisp-header! 'url
"url"
parse-request-uri)
(define-mod-lisp-header! 'server-ip-addr
"server-ip-addr"
identity)
(define-mod-lisp-header! 'server-ip-port
"server-ip-port"
string->number)
(define-mod-lisp-header! 'remote-ip-addr
"remote-ip-addr"
identity)
(define-mod-lisp-header! 'remote-ip-port
"remote-ip-port"
string->number)
(define-mod-lisp-header! 'server-id
"server-id"
identity)
(define-mod-lisp-header! 'server-ip-addr
"server-ip-addr"
identity)
(define-mod-lisp-header! 'server-baseversion
"server-baseversion"
identity)
(define-mod-lisp-header! 'modlisp-version
"modlisp-version"
identity)
(define-mod-lisp-header! 'modlisp-major-version
"modlisp-major-version"
string->number)
(define (read-headers/mod-lisp socket) (define (read-headers/mod-lisp socket)
(define (read-line*) (define (read-line*)
@ -101,19 +68,16 @@
(error "unexpected eof") (error "unexpected eof")
line))) line)))
(let lp ((headers '()) (meta '())) (let lp ((headers '()) (meta '()))
(let ((k (read-line*))) (let ((k (string->symbol (string-downcase (read-line*)))))
(if (string=? k "end") (if (eq? k 'end)
(values (reverse! headers) (reverse! meta)) (values (reverse! headers) (reverse! meta))
(let ((sym-and-parser (mod-lisp-sym-and-parser k)) (let ((mod-lisp-header (lookup-mod-lisp-header k))
(v (read-line*))) (v (read-line*)))
(if sym-and-parser (if mod-lisp-header
(lp headers (lp headers
(acons (car sym-and-parser) (acons k (parse-mod-lisp-header mod-lisp-header v) meta))
((cdr sym-and-parser) v) (lp (acons k (parse-header k v) headers)
meta)) meta)))))))
(call-with-values (lambda () (parse-header k v))
(lambda (k v)
(lp (acons k v headers) meta)))))))))
(define (read-request/mod-lisp port) (define (read-request/mod-lisp port)
;; See the note in (web request) regarding chars, bytes, and strings ;; See the note in (web request) regarding chars, bytes, and strings
@ -122,30 +86,25 @@
(call-with-values (lambda () (read-headers/mod-lisp port)) (call-with-values (lambda () (read-headers/mod-lisp port))
(lambda (headers meta) (lambda (headers meta)
(build-request (build-request
(assq-ref meta 'url)
#:method (assq-ref meta 'method) #:method (assq-ref meta 'method)
#:uri (assq-ref meta 'url)
#:version (assq-ref meta 'server-protocol) #:version (assq-ref meta 'server-protocol)
#:headers headers #:headers headers
#:meta meta #:meta meta
#:port port)))) #:port port))))
;; Note, we only write HTTP headers here, not mod-lisp headers.
(define (write-header/mod-lisp name val port) (define (write-header/mod-lisp name val port)
(if (string? name) (display (header->string name) port)
;; assume that it's a header we don't know about... (newline port)
(begin ((header-writer name) val port)
(display name port) (newline port) (newline port))
(display val port) (newline port))
(let ((decl (lookup-header-decl name)))
(if (not decl)
(error "Unknown header" name)
(begin
(display (header-decl-name decl) port) (newline port)
((header-decl-writer decl) val port) (newline port))))))
(define (write-response-line/mod-lisp code phrase port) (define (write-response-line/mod-lisp code phrase port)
(write-header/mod-lisp "Status" (display "Status" port)
(string-append (number->string code) " " phrase) (newline port)
port)) (display (string-append (number->string code) " " phrase) port)
(newline port))
(define (write-headers/mod-lisp headers port) (define (write-headers/mod-lisp headers port)
(for-each (for-each
@ -248,7 +207,7 @@
(let ((req (read-request/mod-lisp port))) (let ((req (read-request/mod-lisp port)))
(values port (values port
req req
(read-request-body/latin-1 req)))) (read-request-body req))))
(lambda (k . args) (lambda (k . args)
(false-if-exception (close-port port))))))))))))) (false-if-exception (close-port port)))))))))))))
@ -257,12 +216,10 @@
(let ((response (write-response/mod-lisp response client))) (let ((response (write-response/mod-lisp response client)))
(cond (cond
((not body)) ; pass ((not body)) ; pass
((string? body)
(write-response-body/latin-1 response body))
((bytevector? body) ((bytevector? body)
(write-response-body/bytevector response body)) (write-response-body response body))
(else (else
(error "Expected a string or bytevector for body" body))) (error "Expected a bytevector for body" body)))
(close-port (response-port response)))) (close-port (response-port response))))
;; -> unspecified values ;; -> unspecified values