Changeset 11692 in project


Ignore:
Timestamp:
08/21/08 22:05:17 (13 years ago)
Author:
sjamaan
Message:

Improve the interface slightly so it is almost acceptable

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

Legend:

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

    r11599 r11692  
    305305      token))
    306306
    307 (define (default-header-unparser header-name header)
    308   (let loop ((headers (if (pair? header) header (list header)))
    309              (result ""))
     307(define (default-header-unparser header-name header-contents)
     308  (let loop ((headers header-contents)
     309             (result '()))
    310310    (if (null? headers)
    311         (sprintf "~A: ~A\r\n" header-name result) ; TODO: Camel-Case the header name
     311        ;; TODO: Camel-Case the header name
     312        (sprintf "~A: ~A\r\n" header-name (string-join result ","))
    312313        (let* ((contents (value+params-value (car headers)))
    313314               (value (if (pair? contents)
     
    316317               (parameter-unparsers '())) ; Maybe we want to make this a param
    317318         (loop (cdr headers)
    318                (string-append (unparse-token value)
    319                               (unparse-params (value+params-params (car headers))
    320                                               parameter-unparsers)))))))
    321 
     319               (cons
     320                (string-append
     321                 (unparse-token value)
     322                 (unparse-params (value+params-params (car headers))
     323                                 parameter-unparsers))
     324                result))))))
     325
  • release/4/intarweb/trunk/intarweb.scm

    r11599 r11692  
    4848   make-response response? response-major-version response-minor-version
    4949   response-code response-reason response-headers response-port
    50    header-unparsers write-response read-response
     50   header-unparsers unparse-headers write-response read-response
    5151
    5252   ;; http-header-parsers
     
    8080     (else (cons (car h) (loop (cdr h)))))))
    8181
     82(define multi-headers
     83  (make-parameter '(accept accept-encoding accept-language allow
     84                    connection content-encoding content-language from
     85                    if-match if-none-match if-range proxy-authenticate
     86                    te trailer upgrade vary cookie set-cookie via)))
     87
    8288(define (make-updater replacer)
    8389  (lambda (name contents headers)
    84     (let ((old (get-header-contents name headers)))
    85       (if old
    86           (replacer name
    87                     (if (pair? contents)
    88                         (append old contents)
    89                         contents)
    90                     headers)
    91           (replacer name contents headers)))))
     90    (let ((old (get-header-contents name headers '())))
     91      (replacer name
     92                (if (member name (multi-headers))
     93                    (append old contents)
     94                    (list (last contents)))
     95                headers))))
    9296
    9397(define update-header-contents  (make-updater replace-header-contents))
     
    98102(define header-name=? eq?)
    99103
    100 ;; Each header-to-be looks like (name value) or (name value params),
    101 ;; where params is an alist.
    102104(define (make-headers headers-to-be #!optional (old-headers '()))
    103105  (let loop ((h headers-to-be)
    104              (result old-headers))
     106             (new-headers old-headers))
    105107    (if (null? h)
    106         result
     108        new-headers
    107109        (loop (cdr h)
    108               (apply
    109                (lambda (name value #!optional (params '()))
    110                  (update-header-contents name
    111                                          (make-value+params value params)
    112                                          result))
    113                (car h))))))
     110              (update-header-contents (caar h)
     111                                      (map (lambda (v)
     112                                             (make-value+params v '()))
     113                                           (cdar h))
     114                                      new-headers)))))
    114115
    115116(include "../header-parsers")
     
    170171     )))
    171172
    172 (define (get-header-contents name headers)
    173   (alist-ref name headers header-name=?))
     173(define (get-header-contents name headers #!optional (default #f))
     174  (alist-ref name headers header-name=? default))
    174175
    175176;; The parser is supposed to return the new (possibly modified) headers list
     
    257258             (request-major-version request)
    258259             (request-minor-version request))
    259     (for-each
     260    (unparse-headers (request-headers request) o)
     261    (fprintf o "\r\n")))
     262
     263(define-record response code reason major-version minor-version headers port)
     264
     265(define header-unparsers
     266  (make-parameter
     267   `()))
     268
     269(define (unparse-headers headers out)
     270  (for-each
    260271     (lambda (h)
    261272       (let* ((name (car h))
     
    263274              (def default-header-unparser)
    264275              (unparser (alist-ref name (header-unparsers) header-name=? def)))
    265          (display (unparser name contents) o)))
    266      (request-headers request))
    267     (fprintf o "\r\n")))
    268 
    269 (define-record response code reason major-version minor-version headers port)
    270 
    271 (define header-unparsers
    272   (make-parameter
    273    `()))
     276         (display (unparser name contents) out)))
     277     headers))
    274278
    275279;; TODO: Handle HTTP/0.9
     
    281285             (response-code response)
    282286             (response-reason response))
    283     (for-each
    284      (lambda (h)
    285        (let* ((name (car h))
    286               (contents (cdr h))
    287               (def default-header-unparser)
    288               (unparser (alist-ref name (header-unparsers) header-name=? def)))
    289          (display (unparser name contents) o)))
    290      (response-headers response))
     287    (unparse-headers (response-headers response) o)
    291288    (fprintf o "\r\n")))
    292289
Note: See TracChangeset for help on using the changeset viewer.