Changeset 11732 in project for release/4/intarweb/trunk/intarweb.scm


Ignore:
Timestamp:
08/23/08 21:12:32 (13 years ago)
Author:
sjamaan
Message:

Make parsers/unparsers list complete and rearrange some code

File:
1 edited

Legend:

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

    r11722 r11732  
    3535; http://trac.callcc.org
    3636
    37 (require-library srfi-1 srfi-13 regex regex-case base64)
     37(require-library srfi-1 srfi-13 regex regex-case base64 defstruct)
    3838
    3939(module intarweb
    4040  (read-line-limit replace-header-contents replace-header-contents!
    4141   update-header-contents update-header-contents! make-headers single-headers
    42    string->header-name header-name->string header-parsers
     42   string->header-name header-name->string
     43   header-parsers header-unparsers unparse-headers
    4344   http-0.9-request-parser http-1.x-request-parser
     45   http-0.9-request-unparser http-1.x-request-unparser
     46   
    4447   make-request request? request-major-version request-minor-version
    45    request-method request-uri request-headers request-port
    46    protocol-parsers read-request write-request read-headers
     48   request-method request-uri request-headers request-port request-copy
     49   
     50   request-parsers read-request request-unparsers write-request read-headers
    4751   make-response response? response-major-version response-minor-version
    48    response-code response-reason response-headers response-port
    49    header-unparsers unparse-headers write-response read-response
     52   response-code response-reason response-headers response-port response-copy
     53   write-response response-parsers read-response
    5054
    5155   ;; http-header-parsers
     
    5862
    5963  (import scheme chicken (except extras read-token) ports data-structures
    60           srfi-1 srfi-13 srfi-14 regex regex-case (prefix base64 base64:))
     64          srfi-1 srfi-13 srfi-14 regex regex-case (prefix base64 base64:)
     65          defstruct)
    6166
    6267(define read-line-limit (make-parameter 1024)) ; #f if you want no limit
     
    9499(define (header-name->string h) (string-titlecase (symbol->string h)))
    95100
     101;; Make a header set from a literal expression by folding in the headers
     102;; with any previous ones
    96103(define (make-headers headers-to-be #!optional (old-headers '()))
    97104  (fold (lambda (h new-headers)
     
    105112        headers-to-be))
    106113
    107 (include "../header-parsers")
     114(include "../header-parsers") ; Also includes header unparsers
    108115
    109116;; Any unknown headers are considered to be multi-headers, always
     
    115122                    range referer retry-after server transfer-encoding
    116123                    user-agent www-authenticate)))
     124
     125(define string->http-method string->symbol)
     126(define http-method->string symbol->string)
     127
     128;;;;;;;;;;;;;;;;;;;;;;;;;
     129;;;; Request parsing ;;;;
     130;;;;;;;;;;;;;;;;;;;;;;;;;
    117131
    118132;; This includes parsers for all RFC-defined headers
     
    208222           (make-property-condition 'exn 'message msg))))
    209223
    210 (define-record request method uri major-version minor-version headers port)
     224(defstruct request method uri major-version minor-version (headers '()) port)
    211225
    212226;; Perhaps we should have header parsers indexed by version or
     
    218232    ("[Gg][Ee][Tt] +([^ \t]+)"
    219233     (_ uri)
    220      (make-request 'GET uri 0 9 '() in))
     234     (make-request method: 'GET uri: uri
     235                   major-version: 0 minor-version: 9
     236                   port: in))
    221237    (else #f)))
    222238
    223 (define string->http-method string->symbol)
    224 (define http-method->string symbol->string)
    225 
     239;; XXX This actually parses anything >= HTTP/1.0
    226240(define (http-1.x-request-parser line in)
    227241  (regex-case line
    228242   ("([a-zA-Z]+) +([^ \t]+) +[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+)"
    229243    (_ method uri major minor)
    230     (make-request (string->http-method method)
    231                   uri (string->number major) (string->number minor)
    232                   (read-headers in) in))
     244    (make-request method: (string->http-method method) uri: uri
     245                  major-version: (string->number major)
     246                  minor-version: (string->number minor)
     247                  headers: (read-headers in)
     248     port: in))
    233249   (else #f)))
    234250
    235 (define protocol-parsers   ; order matters here
     251(define request-parsers   ; order matters here
    236252  (make-parameter (list http-1.x-request-parser http-0.9-request-parser)))
    237253
     
    242258    ;; Try each parser in turn to process the request-line.
    243259    ;; A parser returns either #f or a request object
    244     (let loop ((parsers (protocol-parsers)))
     260    (let loop ((parsers (request-parsers)))
    245261      (if (null? parsers)
    246262          (signal-http-condition "Unknown protocol" 'unknown-protocol)
    247263          (or ((car parsers) line inport) (loop (cdr parsers)))))))
    248264
    249 ;; TODO: Handle HTTP/0.9
    250 (define (write-request request)
    251   (let ((o (request-port request)))
    252     (fprintf o "~A ~A HTTP/~A.~A\r\n"
    253              (request-method request)
    254              (request-uri request)
    255              (request-major-version request)
    256              (request-minor-version request))
    257     (unparse-headers (request-headers request) o)
    258     (fprintf o "\r\n")))
    259 
    260 (define-record response code reason major-version minor-version headers port)
     265;;;;;;;;;;;;;;;;;;;;;;;;;;;
     266;;;; Request unparsing ;;;;
     267;;;;;;;;;;;;;;;;;;;;;;;;;;;
    261268
    262269(define header-unparsers
     
    274281     headers))
    275282
    276 ;; TODO: Handle HTTP/0.9
    277 (define (write-response response)
    278   (let ((o (response-port response)))
    279     (fprintf o "HTTP/~A.~A ~A ~A\r\n"
    280              (response-major-version response)
    281              (response-minor-version response)
    282              (response-code response)
    283              (response-reason response))
     283(define (write-request-line request)
     284  (fprintf (request-port request)
     285           "~A ~A HTTP/~A.~A\r\n"
     286           (request-method request)
     287           (request-uri request)
     288           (request-major-version request)
     289           (request-minor-version request)))
     290
     291(define (http-0.9-request-unparser request)
     292  request) ;; The request-body will just follow
     293
     294;; XXX This actually unparses anything >= HTTP/1.0
     295(define (http-1.x-request-unparser request)
     296  (and-let* (((>= (request-major-version 1)))
     297             (o (request-port request)))
     298    (write-request-line request)
     299    (unparse-headers (request-headers request) o)
     300    (fprintf o "\r\n")
     301    request))
     302
     303;; Do something with special headers
     304
     305(define request-unparsers  ; order matters here
     306  (make-parameter (list http-1.x-request-unparser http-0.9-request-unparser)))
     307
     308(define (write-request request)
     309  ;; Try each unparser in turn to write the request-line.
     310  ;; An unparser returns either #f or a new request object.
     311  (let loop ((unparsers (request-unparsers)))
     312    (if (null? unparsers)
     313        (signal-http-condition "Unknown protocol" 'unknown-protocol)
     314        (or ((car unparsers) request) (loop (cdr unparsers))))))
     315
     316;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     317;;;; Response unparsing ;;;;
     318;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     319
     320(defstruct response code reason major-version minor-version headers port)
     321
     322(define (http-0.9-response-unparser request response)
     323  response) ;; The response-body will just follow
     324
     325(define (write-response-line request response)
     326  (fprintf (response-port response)
     327           "HTTP/~A.~A ~A ~A\r\n"
     328           (response-major-version response)
     329           (response-minor-version response)
     330           (response-code response)
     331           (response-reason response)))
     332
     333;; XXX This actually unparses anything >= HTTP/1.0
     334(define (http-1.x-response-unparser request response)
     335  (and-let* (((>= (response-major-version 1)))
     336             (o (response-port response)))
     337    (write-response-line request response)
    284338    (unparse-headers (response-headers response) o)
    285     (fprintf o "\r\n")))
    286 
    287 (define (http-1.x-response-parser line in)
     339    (fprintf o "\r\n")
     340    response))
     341
     342(define response-unparsers
     343  (make-parameter (list http-1.x-response-unparser http-0.9-response-unparser)))
     344
     345(define (write-response request response)
     346  ;; Try each unparser in turn to write the response-line.
     347  ;; An unparser returns either #f or a new response object.
     348  (let loop ((unparsers (response-unparsers)))
     349    (if (null? unparsers)
     350        (signal-http-condition "Unknown protocol" 'unknown-protocol)
     351        (or ((car unparsers) request response) (loop (cdr unparsers))))))
     352
     353;;;;;;;;;;;;;;;;;;;;;;;;;;
     354;;;; Response parsing ;;;;
     355;;;;;;;;;;;;;;;;;;;;;;;;;;
     356
     357(define (http-1.x-response-parser request line in)
    288358  (regex-case line
    289359   ("[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+) ([0-9]{3}) +(.*)"
    290360    (_ major minor code reason)
    291     (make-response (string->number code) reason
    292                    (string->number major) (string->number minor)
    293                    (read-headers in) in))
     361    (make-response code: (string->number code) reason: reason
     362                   major-version: (string->number major)
     363                   minor-version: (string->number minor)
     364                   headers: (read-headers in)
     365                   port: in))
    294366   (else #f)))
    295367
    296 ;; TODO: Handle HTTP/0.9
    297 (define (read-response inport)
    298   (let* ((line (read-line inport (read-line-limit))))
    299     (http-1.x-response-parser line inport)))
     368(define response-parsers ;; order matters here
     369  (make-parameter (list http-1.x-response-parser)))
     370
     371(define (read-response request inport)
     372  ;; You can't "detect" a 0.9 response, because there is no response line.
     373  ;; It will simply output the body directly, so we should not even attempt
     374  ;; to read the line and do detection on it.
     375  ;; This gives us one problem: what if we send a 1.x request and receive
     376  ;; a 0.9 response? Nothing we can do against that right now.
     377  (if (and (= (request-major-version request) 0)
     378           (= (request-minor-version request) 9))
     379      (make-response code: 200 reason: "OK"
     380                     major-version: 0
     381                     minor-version: 9
     382                     port: inport)
     383      (let* ((line (read-line inport (read-line-limit))))
     384        (let loop ((parsers (response-parsers)))
     385          (if (null? parsers)
     386              (signal-http-condition "Unknown protocol" 'unknown-protocol)
     387              (or ((car parsers) request line inport) (loop (cdr parsers))))))))
    300388
    301389)
Note: See TracChangeset for help on using the changeset viewer.