From f350e252fcb7cd29292805619a10d450d2a9ebb1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Feb 2011 23:14:23 +0100 Subject: mod-lisp updates * tekuti/mod-lisp.scm: update tekuti/mod-lisp to parse headers to symbols, and to deal in bytevectors only. --- tekuti/mod-lisp.scm | 129 ++++++++++++++++++---------------------------------- 1 file changed, 43 insertions(+), 86 deletions(-) diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index 59002b7..951068f 100644 --- a/tekuti/mod-lisp.scm +++ b/tekuti/mod-lisp.scm @@ -1,5 +1,5 @@ ;; Tekuti -;; Copyright (C) 2008, 2010 Andy Wingo +;; Copyright (C) 2008, 2010, 2011 Andy Wingo ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -36,63 +36,30 @@ #:use-module (web server)) -;;; FIXME: ignore SIGPIPE, otherwise apache dying will kill us - (define *mod-lisp-headers* (make-hash-table)) -(define (define-mod-lisp-header! sym name parser) - (hash-set! *mod-lisp-headers* name (cons sym parser))) - -(define (mod-lisp-sym-and-parser name) - (hash-ref *mod-lisp-headers* name)) - -(define-mod-lisp-header! 'server-protocol - "server-protocol" - parse-http-version) - -(define-mod-lisp-header! 'method - "method" - 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 (define-mod-lisp-header! name parser) + (hashq-set! *mod-lisp-headers* (string->symbol (string-downcase name)) + (cons name parser))) + +(define-mod-lisp-header! "server-protocol" parse-http-version) +(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 (lookup-mod-lisp-header sym) + (hashq-ref *mod-lisp-headers* sym)) + +(define (parse-mod-lisp-header hpair val) + ((cdr hpair) val)) (define (read-headers/mod-lisp socket) (define (read-line*) @@ -101,19 +68,16 @@ (error "unexpected eof") line))) (let lp ((headers '()) (meta '())) - (let ((k (read-line*))) - (if (string=? k "end") + (let ((k (string->symbol (string-downcase (read-line*))))) + (if (eq? k 'end) (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*))) - (if sym-and-parser + (if mod-lisp-header (lp headers - (acons (car sym-and-parser) - ((cdr sym-and-parser) v) - meta)) - (call-with-values (lambda () (parse-header k v)) - (lambda (k v) - (lp (acons k v headers) meta))))))))) + (acons k (parse-mod-lisp-header mod-lisp-header v) meta)) + (lp (acons k (parse-header k v) headers) + meta))))))) (define (read-request/mod-lisp port) ;; See the note in (web request) regarding chars, bytes, and strings @@ -122,30 +86,25 @@ (call-with-values (lambda () (read-headers/mod-lisp port)) (lambda (headers meta) (build-request + (assq-ref meta 'url) #:method (assq-ref meta 'method) - #:uri (assq-ref meta 'url) #:version (assq-ref meta 'server-protocol) #:headers headers #:meta meta #:port port)))) +;; Note, we only write HTTP headers here, not mod-lisp headers. (define (write-header/mod-lisp name val port) - (if (string? name) - ;; assume that it's a header we don't know about... - (begin - (display name 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)))))) + (display (header->string name) port) + (newline port) + ((header-writer name) val port) + (newline port)) (define (write-response-line/mod-lisp code phrase port) - (write-header/mod-lisp "Status" - (string-append (number->string code) " " phrase) - port)) + (display "Status" port) + (newline port) + (display (string-append (number->string code) " " phrase) port) + (newline port)) (define (write-headers/mod-lisp headers port) (for-each @@ -248,7 +207,7 @@ (let ((req (read-request/mod-lisp port))) (values port req - (read-request-body/latin-1 req)))) + (read-request-body req)))) (lambda (k . args) (false-if-exception (close-port port))))))))))))) @@ -257,12 +216,10 @@ (let ((response (write-response/mod-lisp response client))) (cond ((not body)) ; pass - ((string? body) - (write-response-body/latin-1 response body)) ((bytevector? body) - (write-response-body/bytevector response body)) + (write-response-body response body)) (else - (error "Expected a string or bytevector for body" body))) + (error "Expected a bytevector for body" body))) (close-port (response-port response)))) ;; -> unspecified values -- cgit v1.2.3-54-g00ecf