[Guile-commits] 05/23: http: allow custom read-line / continuation-line? functions

[Andy Wingo]

wingo pushed a commit to branch wip-ethreads
in repository guile.

commit 05c6d352a6a5864fc02079421128103d37dff52b
Author: Andy Wingo <address@hidden>
Date:   Sun Mar 18 10:41:03 2012 +0100

    http: allow custom read-line / continuation-line? functions
    
    * module/web/http.scm (read-line): Rename from read-line*.  Just use
      string-trim-right instead of our loop; the previous behavior was
      always falling through to the "substring" case because of \r.
      (continuation-line?): New predicate.
      (read-continuation-line): Take read-line and continuation-line? as
      arguments.
      (read-header, read-headers, read-request-line, read-response-line):
      Take optional read-line and (for the first two) continuation-line?
      predicates, so that client code can override these if desired.
---
 module/web/http.scm |   66 ++++++++++++++++++++++++--------------------------
 1 files changed, 32 insertions(+), 34 deletions(-)

diff --git a/module/web/http.scm b/module/web/http.scm
index 8a07f6d..8958805 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -143,43 +143,38 @@ The default writer is ‘display’."
         (header-decl-writer decl)
         display)))
 
-(define (read-line* port)
+(define (read-line port)
   (let* ((pair (%read-line port))
          (line (car pair))
          (delim (cdr pair)))
     (if (and (string? line) (char? delim))
-        (let ((orig-len (string-length line)))
-          (let lp ((len orig-len))
-            (if (and (> len 0)
-                     (char-whitespace? (string-ref line (1- len))))
-                (lp (1- len))
-                (if (= len orig-len)
-                    line
-                    (substring line 0 len)))))
+        (string-trim-right line)
         (bad-header '%read line))))
 
-(define (read-continuation-line port val)
-  (if (or (eqv? (peek-char port) #\space)
-          (eqv? (peek-char port) #\tab))
+(define (continuation-line? port)
+  (case (peek-char port)
+    ((#\space #\tab) #t)
+    (else #f)))
+
+(define (read-continuation-line port val read-line continuation-line?)
+  (if (continuation-line? port)
       (read-continuation-line port
-                              (string-append val
-                                             (begin
-                                               (read-line* port))))
+                              (string-append val (read-line port))
+                              read-line continuation-line?)
       val))
 
-(define *eof* (call-with-input-string "" read))
-
-(define (read-header port)
-  "Read one HTTP header from PORT. Return two values: the header
+(define* (read-header port #:optional
+                      (read-line read-line)
+                      (continuation-line? continuation-line?))
+  "Reads one HTTP header from @var{port}. Returns two values: the header
 name and the parsed Scheme value. May raise an exception if the header
 was known but the value was invalid.
 
 Returns the end-of-file object for both values if the end of the message
 body was reached (i.e., a blank line)."
-  (let ((line (read-line* port)))
-    (if (or (string-null? line)
-            (string=? line "\r"))
-        (values *eof* *eof*)
+  (let ((line (read-line port)))
+    (if (string-null? line)
+        (values the-eof-object the-eof-object)
         (let* ((delim (or (string-index line #\:)
                           (bad-header '%read line)))
                (sym (string->header (substring line 0 delim))))
@@ -189,7 +184,8 @@ body was reached (i.e., a blank line)."
             sym
             (read-continuation-line
              port
-             (string-trim-both line char-set:whitespace (1+ delim)))))))))
+             (string-trim-both line char-set:whitespace (1+ delim))
+             read-line continuation-line?)))))))
 
 (define (parse-header sym val)
   "Parse VAL, a string, with the parser registered for the header
@@ -211,11 +207,13 @@ from ‘header-writer’."
   ((header-writer sym) val port)
   (display "\r\n" port))
 
-(define (read-headers port)
-  "Read the headers of an HTTP message from PORT, returning them
-as an ordered alist."
+(define* (read-headers port #:optional (read-line read-line)
+                       (continuation-line? continuation-line?))
+  "Read an HTTP message from @var{port}, returning the headers as an
+ordered alist."
   (let lp ((headers '()))
-    (call-with-values (lambda () (read-header port))
+    (call-with-values
+        (lambda () (read-header port read-line continuation-line?))
       (lambda (k v)
         (if (eof-object? k)
             (reverse! headers)
@@ -1082,10 +1080,10 @@ not have to have a scheme or host name.  The result is 
a URI object."
     (or (string->uri (substring str start end))
         (bad-request "Invalid URI: ~a" (substring str start end))))))
 
-(define (read-request-line port)
-  "Read the first line of an HTTP request from PORT, returning
+(define* (read-request-line port #:optional (read-line read-line))
+  "Read the first line of an HTTP request from @var{port}, returning
 three values: the method, the URI, and the version."
-  (let* ((line (read-line* port))
+  (let* ((line (read-line port))
          (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
          (d1 (string-rindex line char-set:whitespace)))
     (if (and d0 d1 (< d0 d1))
@@ -1153,11 +1151,11 @@ three values: the method, the URI, and the version."
   (write-http-version version port)
   (display "\r\n" port))
 
-(define (read-response-line port)
-  "Read the first line of an HTTP response from PORT, returning
+(define* (read-response-line port #:optional (read-line read-line))
+  "Read the first line of an HTTP response from @var{port}, returning
 three values: the HTTP version, the response code, and the \"reason
 phrase\"."
-  (let* ((line (read-line* port))
+  (let* ((line (read-line port))
          (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
          (d1 (and d0 (string-index line char-set:whitespace
                                    (skip-whitespace line d0)))))