Changeset 11831 in project


Ignore:
Timestamp:
08/31/08 20:56:12 (13 years ago)
Author:
sjamaan
Message:

Implement inport chunking

Location:
release/4/intarweb/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/intarweb/trunk/intarweb.scm

    r11829 r11831  
    136136(define http-method->string symbol->string)
    137137
     138;; Hack to insert trailer in chunked ports
     139(define *end-of-transfer-object* (list 'eot))
     140
    138141;; Make an output port automatically "chunked"
    139142(define (chunked-output-port port)
    140143  (make-output-port (lambda (s) ; write
    141                       (fprintf port "~X\r\n~A\r\n" (string-length s) s))
     144                      (if (eq? *end-of-transfer-object* s)
     145                          (fprintf port "0\r\n\r\n") ; trailer?
     146                          (fprintf port "~X\r\n~A\r\n" (string-length s) s)))
    142147                    (lambda ()  ; close
    143148                      (close-output-port port))
    144149                    (lambda ()  ; flush
    145150                      (flush-output port))))
     151
     152;; Make an input port automatically "chunked"
     153(define (chunked-input-port port)
     154  (let* ((chunk-length 0)
     155         (position 0)
     156         (check-position (lambda ()
     157                           (when (and position (>= position chunk-length))
     158                             (unless (zero? chunk-length)
     159                                     (read-line port)) ; read \r\n data trailer
     160                             (let* ((line (read-line port)))
     161                               (if (eof-object? line)
     162                                   (set! position #f)
     163                                   (begin
     164                                     (set! chunk-length (string->number line 16))
     165                                     (if chunk-length
     166                                         (set! position 0)
     167                                         (set! position #f)))))))))
     168    (make-input-port (lambda ()         ; read
     169                       (check-position)
     170                       (if position
     171                           (let ((char (read-char port)))
     172                             (if (not (eof-object? char))
     173                                 (set! position (add1 position)))
     174                             char)
     175                           #!eof))
     176                     (lambda ()          ; ready?
     177                       (check-position)
     178                       (and position (char-ready? port)))
     179                     (lambda ()          ; close
     180                       (close-input-port port))
     181                     (lambda ()          ; peek
     182                       (check-position)
     183                       (if position
     184                           (peek-char port)
     185                           #!eof)))))
    146186
    147187;;;;;;;;;;;;;;;;;;;;;;;;;
     
    333373    (unparse-headers (request-headers request) o)
    334374    (display "\r\n" o)
    335     (if (memq 'chunked (header-values 'transfer-coding
     375    (if (memq 'chunked (header-values 'transfer-encoding
    336376                                      (request-headers request)))
    337377        (update-request request port: (chunked-output-port (request-port request)))
     
    388428    (unparse-headers (response-headers response) o)
    389429    (display "\r\n" o)
    390     (if (memq 'chunked (header-values 'transfer-coding
     430    (if (memq 'chunked (header-values 'transfer-encoding
    391431                                      (response-headers response)))
    392432        (update-response response port: (chunked-output-port (response-port response)))
     
    412452;;;;;;;;;;;;;;;;;;;;;;;;;;
    413453
     454;; I don't like this code. Clean it up!
    414455(define (http-1.x-response-parser line in)
    415456  (regex-case line
    416     ("[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+) +([0-9]{3}) +(.*)"
     457    ("[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+) +([0-9]+) +(.*)"
    417458     (_ major minor code reason)
    418      (make-response code: (string->number code) reason: reason
    419                     major: (string->number major)
    420                     minor: (string->number minor)
    421                     headers: (read-headers in)
    422                     port: in))
     459     (let ((major (string->number major))
     460           (minor (string->number minor)))
     461      (and (or (> major 1)
     462               (and (= major 1)
     463                    (> minor 0)))
     464           (let ((response (make-response code: (string->number code)
     465                                          reason: reason
     466                                          major: major
     467                                          minor: minor
     468                                          headers: (read-headers in)
     469                                          port: in)))
     470             (if (memq 'chunked (header-values 'transfer-encoding
     471                                               (response-headers response)))
     472                 (update-response response
     473                                  port: (chunked-input-port
     474                                         (response-port response)))
     475                 response)))))
     476    (else #f)))
     477
     478(define (http-1.0-response-parser line in)
     479  (regex-case line
     480    ("[Hh][Tt][Tt][Pp]/1\\.0 +([0-9]+) +(.*)"
     481     (_ code reason)
     482     (let ((response (make-response code: (string->number code) reason: reason
     483                                    major: 1 minor: 0
     484                                    headers: (read-headers in)
     485                                    port: in)))
     486       response))
    423487    (else #f)))
    424488
     
    431495                 major: 0
    432496                 minor: 9
    433                  port: (call-with-input-string line
     497                 ;; XXX This is wrong, it re-inserts \r\n, while it may have
     498                 ;; been a \n only. To work around this, we'd have to write
     499                 ;; a custom read-line procedure.
     500                 port: (call-with-input-string (string-append line "\r\n")
    434501                         (lambda (str)
    435502                           (make-concatenated-port str in)))))
    436503
    437504(define response-parsers ;; order matters here
    438   (make-parameter (list http-1.x-response-parser http-0.9-response-parser)))
     505  (make-parameter (list http-1.x-response-parser http-1.0-response-parser http-0.9-response-parser)))
    439506
    440507(define (read-response inport)
  • release/4/intarweb/trunk/tests/run.scm

    r11829 r11831  
    348348   (test "Method is case-sensitive" 'geT (request-method (test-read-request "geT /path HTTP/1.1\r\n\r\n")))
    349349   ; RFC 2616 3.1 + case-insensitivity BNF rule
    350    (test "Protocol is case-insensitive" '1 (request-minor (test-read-request "GET /path htTP/1.1\r\n\r\n")))))
     350   (test "Protocol is case-insensitive" '1 (request-minor (test-read-request "GET /path htTP/1.1\r\n\r\n"))))) ;; TODO: Chunking
    351351
    352352(define (test-write-request req . outputs)
     
    388388             "test"))
    389389      (test "Chunking ignored"
    390             "GET /foo/bar.html HTTP/1.0\r\nTransfer-Coding: chunked\r\n\r\nfoobar"
     390            "GET /foo/bar.html HTTP/1.0\r\nTransfer-Encoding: chunked\r\n\r\nfoobar"
    391391            (test-write-request
    392392             (update-request req
    393                              headers: (make-headers `((transfer-coding chunked))))
     393                             headers: (make-headers `((transfer-encoding chunked))))
    394394             "foo" "bar"))))
    395395  (test-group "HTTP/1.1"
     
    404404             "test"))
    405405      (test "Chunking"
    406             "GET /foo/bar.html HTTP/1.1\r\nTransfer-Coding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
     406            "GET /foo/bar.html HTTP/1.1\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n"
    407407            (test-write-request
    408408             (update-request req
    409                              headers: (make-headers `((transfer-coding chunked))))
     409                             headers: (make-headers `((transfer-encoding chunked))))
    410410             "foo" "1234567890")))))
    411411
    412 (define (test-write-request req . outputs)
    413   (call-with-output-string
    414     (lambda (out)
    415       (request-port-set! req out)
    416       (let ((r (write-request req)))
    417        (for-each (lambda (output)
    418                    (display output (request-port r)))
    419                  outputs)))))
     412(define (test-read-response input-string)
     413  (call-with-input-string input-string
     414    (lambda (in)
     415      (read-response in))))
     416
     417(test-group "Read response"
     418  (test-group "HTTP/1.1"
     419    (let ((res (test-read-response "HTTP/1.1 303 See other\r\nFoo: bar\r\n\r\nContents")))
     420      (test "Version detection"
     421            '(1 . 1)
     422            (cons (response-major res) (response-minor res)))
     423      (test "Status"
     424            '(303 . "See other")
     425            (cons (response-code res) (response-reason res)))
     426      (test "Headers"
     427            '("bar")
     428            (header-values 'foo (response-headers res)))
     429      (test "Contents"
     430            "Contents"
     431            (read-string #f (response-port res))))
     432    (let ((res (test-read-response "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n")))
     433      (test "Chunking"
     434            "foo1234567890"
     435            (read-string #f (response-port res)))))
     436  (test-group "HTTP/1.0"
     437    (let ((res (test-read-response "HTTP/1.0 303 See other\r\nFoo: bar\r\n\r\nContents")))
     438      (test "Version detection"
     439            '(1 . 0)
     440            (cons (response-major res) (response-minor res)))
     441      (test "Status"
     442            '(303 . "See other")
     443            (cons (response-code res) (response-reason res)))
     444      (test "Headers"
     445            '("bar")
     446            (header-values 'foo (response-headers res)))
     447      (test "Contents"
     448            "Contents"
     449            (read-string #f (response-port res))))
     450    (let ((res (test-read-response "HTTP/1.0 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n3\r\nfoo\r\na\r\n1234567890\r\n")))
     451      (test "Chunking ignored"
     452            "3\r\nfoo\r\na\r\n1234567890\r\n"
     453            (read-string #f (response-port res)))))
     454  (test-group "HTTP/0.9"
     455    (let ((res (test-read-response "Doesn't matter what's here\r\nLine 2")))
     456      (test "Always OK status"
     457            '(200 . "OK")
     458            (cons (response-code res) (response-reason res)))
     459      (test "Version detection; fallback to 0.9"
     460            '(0 . 9)
     461            (cons (response-major res) (response-minor res)))
     462      (test "No headers"
     463            '() (response-headers res))
     464      (test "Contents"
     465            "Doesn't matter what's here\r\nLine 2"
     466            (read-string #f (response-port res))))))
     467
    420468
    421469;; TODO:
     
    425473;;    single/multiple discard them? Throw an exception?
    426474;; - Use SRFI-19
     475;; - Rethink the auto-chunking stuff. Maybe this should be done at a higher level
Note: See TracChangeset for help on using the changeset viewer.