Changeset 11908 in project


Ignore:
Timestamp:
09/06/08 14:30:30 (13 years ago)
Author:
sjamaan
Message:

Make a new opaque 'headers' type to ensure that the user creates proper headers always

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

Legend:

Unmodified
Added
Removed
  • release/4/intarweb/trunk/header-parsers.scm

    r11854 r11908  
    1616;; Get the raw contents of a header
    1717(define (header-contents name headers #!optional (default #f))
    18   (alist-ref name headers eq? default))
     18  (alist-ref name (headers-v headers) eq? default))
    1919
    2020;; Get all values of a header
  • release/4/intarweb/trunk/intarweb.scm

    r11881 r11908  
    3737(module intarweb
    3838  (read-line-limit replace-header-contents replace-header-contents!
    39    update-header-contents update-header-contents! make-headers single-headers
     39   update-header-contents update-header-contents! headers single-headers
    4040   string->header-name header-name->string
    4141   header-parsers header-unparsers unparse-headers
     
    7777(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
    7878
     79;; Make headers a new type, to force the use of the HEADERS procedure
     80;; and ensure only proper header values are passed to all procedures
     81;; that deal with headers.
     82(define-record headers v)
     83
     84(define-record-printer (headers h out)
     85  (fprintf out "#(headers: ~S)"
     86           (headers-v h)))
     87
    7988(define (replace-header-contents! name contents headers)
    80   (let loop ((h headers))
     89  (let loop ((h (headers-v headers)))
    8190    (cond
    82      ((null? h) (cons (cons name contents) headers))
     91     ((null? h)
     92      (headers-v-set!
     93       headers (cons (cons name contents) (headers-v headers)))
     94      headers)
    8395     ((eq? name (caar h))
    8496      (set-cdr! (car h) contents)
     
    8799
    88100(define (replace-header-contents name contents headers)
    89   (let loop ((h headers))
    90     (cond
    91      ((null? h) (cons (cons name contents) headers))
    92      ((eq? name (caar h))
    93       (cons (cons (caar h) contents) (cdr h)))
    94      (else (cons (car h) (loop (cdr h)))))))
     101  (make-headers
     102   (let loop ((h (headers-v headers)))
     103     (cond
     104      ((null? h) (cons (cons name contents) (headers-v headers)))
     105      ((eq? name (caar h))
     106       (cons (cons (caar h) contents) (cdr h)))
     107      (else (cons (car h) (loop (cdr h))))))))
    95108
    96109(define (make-updater replacer)
     
    111124;; Make a header set from a literal expression by folding in the headers
    112125;; with any previous ones
    113 (define (make-headers headers-to-be #!optional (old-headers '()))
     126(define (headers headers-to-be #!optional (old-headers (make-headers '())))
    114127  (fold (lambda (h new-headers)
    115128          (update-header-contents
     
    261274  (let ((first-line (read-line port)))
    262275    (if (or (eof-object? first-line) (string-null? first-line))
    263         '()
     276        (make-headers '())
    264277        (let loop ((prev-line first-line)
    265278                   (line      (read-line port))
    266                    (headers   '()))
     279                   (headers   (make-headers '())))
    267280          (if (or (eof-object? line) (string-null? line))
    268281              (if (string-null? prev-line)
     
    290303
    291304(defstruct request
    292   (method 'GET) uri (major 1) (minor 1) (headers '()) port)
     305  (method 'GET) uri (major 1) (minor 1) (headers (make-headers '())) port)
    293306
    294307;; Perhaps we should have header parsers indexed by version or
     
    348361              (unparser (alist-ref name (header-unparsers) eq? def)))
    349362         (display (unparser name contents) out)))
    350      headers))
     363     (headers-v headers)))
    351364
    352365(define (write-request-line request)
     
    408421
    409422(defstruct response
    410   (code 200) (reason "OK") (major 1) (minor 1) (headers '()) port)
     423  (code 200) (reason "OK") (major 1) (minor 1) (headers (make-headers '())) port)
    411424
    412425(define (http-0.9-response-unparser response)
  • release/4/intarweb/trunk/tests/run.scm

    r11881 r11908  
    256256             (get-param '$version (second (header-contents 'cookie headers))))))))
    257257
    258 (test-group "Make-headers"
     258(test-group "Headers"
    259259  (test "Simple test"
    260260        `(bar qux)
    261         (header-values 'foo (make-headers `((foo bar qux)))))
     261        (header-values 'foo (headers `((foo bar qux)))))
    262262  (test "Multi headers are folded"
    263263        `(bar qux)
    264         (header-values 'foo (make-headers `((foo bar)
    265                                                   (foo qux)))))
     264        (header-values 'foo (headers `((foo bar)
     265                                       (foo qux)))))
    266266  (test "Single headers are unique"
    267267        `(qux)
    268268        (header-values 'foo (parameterize ((single-headers '(foo)))
    269                                     (make-headers `((foo bar)
    270                                                     (foo qux))))))
     269                                    (headers `((foo bar)
     270                                               (foo qux))))))
    271271  (test "Extra single headers are ignored"
    272272        `(qux)
    273273        (header-values 'foo (parameterize ((single-headers '(foo)))
    274                                     (make-headers `((foo bar qux))))))
     274                                    (headers `((foo bar qux))))))
    275275  (test "Parameters"
    276276        `((bar . qux))
    277277        (get-params
    278          (car (header-contents 'foo (make-headers `((foo #(mooh ((bar . qux))))))))))
     278         (car (header-contents 'foo (headers `((foo #(mooh ((bar . qux))))))))))
    279279  (test "Multi headers are folded into old headers"
    280280        `(bar qux)
    281         (header-values 'foo (make-headers `((foo qux))
    282                                                 (make-headers `((foo bar)))))))
     281        (header-values 'foo (headers `((foo qux))
     282                                     (headers `((foo bar)))))))
    283283
    284284(define (test-unparse-headers h)
    285285  (call-with-output-string
    286286   (lambda (o)
    287      (unparse-headers (make-headers h) o))))
     287     (unparse-headers (headers h) o))))
    288288
    289289(test-group "Unparsers"
     
    338338      (test 'GET (request-method req))
    339339      (test (uri-reference "/path/to/stuff?arg1=val1&arg2=val2") (request-uri req))
    340       (test '() (request-headers req)))
     340      (test (headers '()) (request-headers req)))
    341341    ; RFC 1945 5.0 does not mention case-sensitivity for the method in HTTP/0.9.
    342342    ; It only mentions it in the context of HTTP/1.x (section 5.1.1).
     
    354354      (test 'GET (request-method req))
    355355      (test (uri-reference "/path/to/stuff?arg1=val1&arg2=val2") (request-uri req))
    356       (test '() (request-headers req)))
     356      (test (headers '()) (request-headers req)))
    357357    (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.0\r\n"))))
    358358  (test-group "HTTP/1.1" ; No need to test all things we test for 1.0
     
    388388            (test-write-request (update-request req
    389389                                                headers:
    390                                                 (make-headers `((foo bar))))
     390                                                (headers `((foo bar))))
    391391                                ""))
    392392      (test "Always GET"
     
    401401            (test-write-request
    402402             (update-request req
    403                              headers: (make-headers `((foo bar))))
     403                             headers: (headers `((foo bar))))
    404404             "test"))
    405405      (test "Chunking ignored"
     
    407407            (test-write-request
    408408             (update-request req
    409                              headers: (make-headers `((transfer-encoding chunked))))
     409                             headers: (headers `((transfer-encoding chunked))))
    410410             "foo" "bar"))))
    411411  (test-group "HTTP/1.1"
     
    417417            (test-write-request
    418418             (update-request req
    419                              headers: (make-headers `((foo bar))))
     419                             headers: (headers `((foo bar))))
    420420             "test"))
    421421      (test "Chunking"
     
    423423            (test-write-request
    424424             (update-request req
    425                              headers: (make-headers `((transfer-encoding chunked))))
     425                             headers: (headers `((transfer-encoding chunked))))
    426426             "foo" "1234567890")))))
    427427
     
    477477            (cons (response-major res) (response-minor res)))
    478478      (test "No headers"
    479             '() (response-headers res))
     479            (headers '()) (response-headers res))
    480480      (test "Contents"
    481481            "Doesn't matter what's here\r\nLine 2"
     
    498498            "These are the contents\r\n"
    499499            (test-write-response
    500              (update-response res headers: (make-headers `((foo bar))))
     500             (update-response res headers: (headers `((foo bar))))
    501501             "These are the contents\r\n"))))
    502502  (test-group "HTTP/1.0"
     
    506506            "HTTP/1.0 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
    507507            (test-write-response
    508              (update-response res headers: (make-headers `((foo bar))))
     508             (update-response res headers: (headers `((foo bar))))
    509509             "These are the contents\r\n"))
    510510      (test "Status code"
     
    518518             (update-response
    519519              res
    520               headers: (make-headers `((transfer-encoding chunked))))
     520              headers: (headers `((transfer-encoding chunked))))
    521521             "foo" "1234567890"))))
    522522  (test-group "HTTP/1.1"
     
    526526           "HTTP/1.1 200 OK\r\nFoo: bar\r\n\r\nThese are the contents\r\n"
    527527            (test-write-response
    528              (update-response res headers: (make-headers `((foo bar))))
     528             (update-response res headers: (headers `((foo bar))))
    529529             "These are the contents\r\n"))
    530530     (test "Status code"
     
    538538            (update-response
    539539             res
    540              headers: (make-headers `((transfer-encoding chunked))))
     540             headers: (headers `((transfer-encoding chunked))))
    541541            "foo" "1234567890")))))
    542542
Note: See TracChangeset for help on using the changeset viewer.