Changeset 11734 in project


Ignore:
Timestamp:
08/24/08 15:21:46 (13 years ago)
Author:
sjamaan
Message:

Get ready for using uri-generic

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

Legend:

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

    r11732 r11734  
    4545   http-0.9-request-unparser http-1.x-request-unparser
    4646   
    47    make-request request? request-major-version request-minor-version
    48    request-method request-uri request-headers request-port request-copy
     47   make-request request? request-major-version request-major-version-set!
     48   request-minor-version request-minor-version-set!
     49   request-method request-method-set! request-uri request-uri-set!
     50   request-headers request-headers-set! request-port request-port-set!
     51   request-copy
    4952   
    5053   request-parsers read-request request-unparsers write-request read-headers
    51    make-response response? response-major-version response-minor-version
    52    response-code response-reason response-headers response-port response-copy
     54   
     55   make-response response? response-major-version response-major-version-set!
     56   response-minor-version response-minor-version-set!
     57   response-code response-code-set! response-reason response-reason-set!
     58   response-headers response-headers-set! response-port response-port-set!
     59   response-copy
     60   
    5361   write-response response-parsers read-response
    5462
     
    290298
    291299(define (http-0.9-request-unparser request)
    292   request) ;; The request-body will just follow
     300  (fprintf (request-port request)
     301           "GET ~A"
     302           (request-uri request))
     303  request)
    293304
    294305;; XXX This actually unparses anything >= HTTP/1.0
    295306(define (http-1.x-request-unparser request)
    296   (and-let* (((>= (request-major-version 1)))
     307  (and-let* (((>= (request-major-version request) 1))
    297308             (o (request-port request)))
    298309    (write-request-line request)
     
    301312    request))
    302313
    303 ;; Do something with special headers
     314;; TODO: Do something with special headers
    304315
    305316(define request-unparsers  ; order matters here
     
    333344;; XXX This actually unparses anything >= HTTP/1.0
    334345(define (http-1.x-response-unparser request response)
    335   (and-let* (((>= (response-major-version 1)))
     346  (and-let* (((>= (response-major-version response) 1))
    336347             (o (response-port response)))
    337348    (write-response-line request response)
  • release/4/intarweb/trunk/tests/run.scm

    r11732 r11734  
    44
    55(import intarweb)
    6 
    7 (define (test-read-request str)
    8   (call-with-input-string str
    9     (lambda (in)
    10       (read-request in))))
    116
    127(define-syntax test-error*
     
    2419    ((_ ?error-type ?expr)
    2520     (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
    26 
    27 (test-group "Request line"
    28   (parameterize ((request-parsers `(,(lambda (line in)
    29                                        (and (string=? line "foo") 'foo))
    30                                     ,(lambda (line in)
    31                                        (and (string=? line "bar") 'bar)))))
    32     (test-error* (http unknown-protocol) (test-read-request "qux"))
    33     (test-error* (http unknown-protocol) (test-read-request ""))
    34     (test 'foo (test-read-request "foo"))
    35     (test 'bar (test-read-request "bar")))
    36   (test-group "HTTP/0.9"
    37     (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2\r\n")))
    38       (test 0 (request-major-version req))
    39       (test 9 (request-minor-version req))
    40       (test 'GET (request-method req))
    41       (test "/path/to/stuff?arg1=val1&arg2=val2" (request-uri req))
    42       (test '() (request-headers req)))
    43     ; RFC 1945 5.0 does not mention case-sensitivity for the method in HTTP/0.9.
    44     ; It only mentions it in the context of HTTP/1.x (section 5.1.1).
    45     ; We obey the BNF syntax rule in 2.1:
    46     ;     "literal" - Quotation marks surround literal text.
    47     ;                 Unless stated otherwise, the text is case-insensitive.
    48     ; Section 4.1 defines:
    49     ;     Simple-Request  = "GET" SP Request-URI CRLF
    50     (test "Method is case-insensitive" 'GET (request-method (test-read-request "geT /path\r\n")))
    51     (test-error "0.9 only knows GET" (test-read-request "PUT /path")))
    52   (test-group "HTTP/1.0"
    53     (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.0\r\n\r\n")))
    54       (test 1 (request-major-version req))
    55       (test 0 (request-minor-version req))
    56       (test 'GET (request-method req))
    57       (test "/path/to/stuff?arg1=val1&arg2=val2" (request-uri req))
    58       (test '() (request-headers req)))
    59     (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.0\r\n"))))
    60   (test-group "HTTP/1.1" ; No need to test all things we test for 1.0
    61    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.1\r\n\r\n")))
    62      (test 1 (request-major-version req))
    63      (test 1 (request-minor-version req)))
    64    (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.1\r\n\r\n")))
    65    ; RFC 2616 5.1.1
    66    (test "Method is case-sensitive" 'geT (request-method (test-read-request "geT /path HTTP/1.1\r\n\r\n")))
    67    ; RFC 2616 3.1 + case-insensitivity BNF rule
    68    (test "Protocol is case-insensitive" '1 (request-minor-version (test-read-request "GET /path htTP/1.1\r\n\r\n")))))
    6921
    7022(define (test-read-headers str)
     
    351303                                              (feh . #f)))))))))
    352304
    353 ;(define (test-write-response ))
    354 
    355 #;(test-group "write-response"
     305(define (test-read-request str)
     306  (call-with-input-string str
     307    (lambda (in)
     308      (read-request in))))
     309
     310(test-group "Read-request"
     311  (parameterize ((request-parsers `(,(lambda (line in)
     312                                       (and (string=? line "foo") 'foo))
     313                                    ,(lambda (line in)
     314                                       (and (string=? line "bar") 'bar)))))
     315    (test-error* (http unknown-protocol) (test-read-request "qux"))
     316    (test-error* (http unknown-protocol) (test-read-request ""))
     317    (test 'foo (test-read-request "foo"))
     318    (test 'bar (test-read-request "bar")))
    356319  (test-group "HTTP/0.9"
    357     (test ""
    358           ())))
     320    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2\r\n")))
     321      (test 0 (request-major-version req))
     322      (test 9 (request-minor-version req))
     323      (test 'GET (request-method req))
     324      (test "/path/to/stuff?arg1=val1&arg2=val2" (request-uri req))
     325      (test '() (request-headers req)))
     326    ; RFC 1945 5.0 does not mention case-sensitivity for the method in HTTP/0.9.
     327    ; It only mentions it in the context of HTTP/1.x (section 5.1.1).
     328    ; We obey the BNF syntax rule in 2.1:
     329    ;     "literal" - Quotation marks surround literal text.
     330    ;                 Unless stated otherwise, the text is case-insensitive.
     331    ; Section 4.1 defines:
     332    ;     Simple-Request  = "GET" SP Request-URI CRLF
     333    (test "Method is case-insensitive" 'GET (request-method (test-read-request "geT /path\r\n")))
     334    (test-error "0.9 only knows GET" (test-read-request "PUT /path")))
     335  (test-group "HTTP/1.0"
     336    (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.0\r\n\r\n")))
     337      (test 1 (request-major-version req))
     338      (test 0 (request-minor-version req))
     339      (test 'GET (request-method req))
     340      (test "/path/to/stuff?arg1=val1&arg2=val2" (request-uri req))
     341      (test '() (request-headers req)))
     342    (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.0\r\n"))))
     343  (test-group "HTTP/1.1" ; No need to test all things we test for 1.0
     344   (let ((req (test-read-request "GET /path/to/stuff?arg1=val1&arg2=val2 HTTP/1.1\r\n\r\n")))
     345     (test 1 (request-major-version req))
     346     (test 1 (request-minor-version req)))
     347   (test 'PUT (request-method (test-read-request "PUT /path HTTP/1.1\r\n\r\n")))
     348   ; RFC 2616 5.1.1
     349   (test "Method is case-sensitive" 'geT (request-method (test-read-request "geT /path HTTP/1.1\r\n\r\n")))
     350   ; RFC 2616 3.1 + case-insensitivity BNF rule
     351   (test "Protocol is case-insensitive" '1 (request-minor-version (test-read-request "GET /path htTP/1.1\r\n\r\n")))))
     352
     353(define (test-write-request req #!optional (output ""))
     354  (call-with-output-string
     355    (lambda (out)
     356      (request-port-set! req out)
     357      (display output (request-port (write-request req))))))
     358
     359(test-group "Write request"
     360  ;; This can also be called Simple-Request as per RFC 1945 4.1
     361  ;; RFC 2616 19.6 also states we should recognise 0.9 requests, but if
     362  ;; we understand those we should also be able to generate them because
     363  ;; a 0.9 server does not understand 1.x requests.
     364  (test-group "HTTP/0.9"
     365    (let ((req (make-request minor-version: 9 major-version: 0
     366                             method: 'GET
     367                             uri: "http://example.com/foo/bar.html")))
     368      (test "Always empty headers"
     369            "GET /foo/bar.html"
     370            (test-write-request (request-copy req
     371                                              headers:
     372                                              (make-headers `((foo bar))))
     373                                ""))
     374      (test "Always GET"
     375            "GET /foo/bar.html"
     376            (test-write-request (request-copy req method: 'POST)))))
     377  (test-group "HTTP/1.0"
     378    (let ((req (make-request minor-version: 0 major-version: 1
     379                             method: 'GET
     380                             uri: "http://example.com/foo/bar.html")))
     381      (test "Headers"
     382            "GET /foo/bar.html HTTP/1.0\r\nFoo: bar\r\n\r\ntest"
     383            (test-write-request (request-copy req
     384                                              headers:
     385                                              (make-headers `((foo bar))))
     386                                "test")))))
    359387
    360388;; TODO:
     
    363391;; - When headers are malformed, what to do? Return #f for value and let
    364392;;    single/multiple discard them? Throw an exception?
     393;; - Use uri-generic
Note: See TracChangeset for help on using the changeset viewer.