From 05c9fcd412e7e4a7b4226f8031657b3ac1666071 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 27 Nov 2010 11:08:48 -0500 Subject: [PATCH] First pass at Xexpr removal --- .../tests/web-server/http/cookies-test.rkt | 17 +-- .../web-server/private/response-test.rkt | 74 +++++----- .../tests/web-server/servlet/helpers-test.rkt | 12 +- .../web-server/stress/vs-snap/dynamic.rkt | 2 +- .../configuration-table-structs.rkt | 16 +-- .../web-server/configuration/responders.rkt | 30 ++--- .../htdocs/servlets/examples/basic.rkt | 5 +- .../htdocs/servlets/examples/digest.rkt | 14 +- .../htdocs/servlets/examples/port.rkt | 2 +- .../servlets/examples/template-full.rkt | 2 +- collects/web-server/dispatch/serve.rkt | 2 +- .../web-server/dispatchers/dispatch-lift.rkt | 2 +- .../dispatchers/dispatch-passwords.rkt | 2 +- .../dispatchers/dispatch-pathprocedure.rkt | 2 +- .../dispatchers/dispatch-servlets.rkt | 4 +- collects/web-server/formlets/servlet.rkt | 2 +- collects/web-server/http/cookie.rkt | 14 +- collects/web-server/http/redirect.rkt | 18 +-- collects/web-server/http/response-structs.rkt | 126 +++--------------- collects/web-server/http/response.rkt | 73 ++++------ collects/web-server/insta/insta.rkt | 4 +- collects/web-server/lang/web.rkt | 12 +- collects/web-server/private/servlet.rkt | 2 +- .../web-server/scribblings/contracts.scrbl | 4 +- .../scribblings/ctable-structs.scrbl | 16 +-- .../scribblings/dispatch-servlets.scrbl | 6 +- .../web-server/scribblings/dispatch.scrbl | 18 +-- .../web-server/scribblings/dispatchers.scrbl | 16 +-- .../web-server/scribblings/formlets.scrbl | 2 +- .../web-server/scribblings/lang-api.scrbl | 2 +- collects/web-server/scribblings/lang.scrbl | 10 +- .../web-server/scribblings/responders.scrbl | 24 ++-- .../scribblings/servlet-env-int.scrbl | 2 +- .../web-server/scribblings/servlet-env.scrbl | 4 +- .../scribblings/servlet-setup.scrbl | 6 +- collects/web-server/scribblings/servlet.scrbl | 2 +- .../web-server/scribblings/templates.scrbl | 4 +- .../scribblings/tutorial/continue.scrbl | 2 +- collects/web-server/scribblings/web.scrbl | 18 +-- collects/web-server/servlet-dispatch.rkt | 2 +- collects/web-server/servlet-env.rkt | 4 +- .../web-server/servlet/servlet-structs.rkt | 4 +- collects/web-server/servlet/setup.rkt | 14 +- collects/web-server/servlet/web.rkt | 12 +- collects/web-server/xexpr.rkt | 29 ++++ 45 files changed, 266 insertions(+), 372 deletions(-) create mode 100644 collects/web-server/xexpr.rkt diff --git a/collects/tests/web-server/http/cookies-test.rkt b/collects/tests/web-server/http/cookies-test.rkt index 902cb3d2eb..b664febf45 100644 --- a/collects/tests/web-server/http/cookies-test.rkt +++ b/collects/tests/web-server/http/cookies-test.rkt @@ -51,22 +51,7 @@ (test-equal? "secure? #f" (header-value (cookie->header (make-cookie "name" "value" #:secure? #f))) - #"name=value; Version=1")) - - (test-suite - "xexpr-response/cookies" - (test-equal? "Simple" - (response/full-body (xexpr-response/cookies empty `(html))) - (list #"")) - - (test-equal? "One (body)" - (response/full-body (xexpr-response/cookies (list (make-cookie "name" "value")) `(html))) - (list #"")) - - (test-equal? "One (headers)" - (map (lambda (h) (cons (header-field h) (header-value h))) - (response/basic-headers (xexpr-response/cookies (list (make-cookie "name" "value")) `(html)))) - (list (cons #"Set-Cookie" #"name=value; Version=1"))))) + #"name=value; Version=1"))) (test-suite "cookie-parse.rkt" diff --git a/collects/tests/web-server/private/response-test.rkt b/collects/tests/web-server/private/response-test.rkt index a012017a93..2ed5b79c03 100644 --- a/collects/tests/web-server/private/response-test.rkt +++ b/collects/tests/web-server/private/response-test.rkt @@ -25,54 +25,54 @@ "output-response" (test-suite - "response/basic" - (test-equal? "response/basic" + "response" + (test-equal? "response" (output output-response - (make-response/basic 404 #"404" (current-seconds) #"text/html" - (list))) + (response 404 #"404" (current-seconds) #"text/html" + (list) void)) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n") - (test-equal? "response/basic (header)" + (test-equal? "response (header)" (output output-response - (make-response/basic 404 #"404" (current-seconds) #"text/html" - (list (make-header #"Header" #"Value")))) + (response 404 #"404" (current-seconds) #"text/html" + (list (make-header #"Header" #"Value")) void)) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n") - (test-equal? "response/basic (body)" + (test-equal? "response (body)" (output output-response - (make-response/basic 404 #"404" (current-seconds) #"text/html" - (list))) + (response 404 #"404" (current-seconds) #"text/html" + (list) void)) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n") - (test-equal? "response/basic (bytes body)" + (test-equal? "response (bytes body)" (output output-response - (make-response/basic 404 #"404" (current-seconds) #"text/html" - (list))) + (response 404 #"404" (current-seconds) #"text/html" + (list) void)) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n") - (test-equal? "response/basic (both)" + (test-equal? "response (both)" (output output-response - (make-response/basic 404 #"404" (current-seconds) #"text/html" - (list (make-header #"Header" #"Value")))) + (response 404 #"404" (current-seconds) #"text/html" + (list (make-header #"Header" #"Value")) void)) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n")) (test-suite "response/full" (test-equal? "response/full" (output output-response - (make-response/full 404 #"404" (current-seconds) #"text/html" + (response/full 404 #"404" (current-seconds) #"text/html" (list) (list))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n") (test-equal? "response/full (header)" (output output-response - (make-response/full 404 #"404" (current-seconds) #"text/html" + (response/full 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (list))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n") (test-equal? "response/full (bytes body)" (output output-response - (make-response/full 404 #"404" (current-seconds) #"text/html" + (response/full 404 #"404" (current-seconds) #"text/html" (list) (list #"Content!"))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 8\r\n\r\nContent!") (test-equal? "response/full (both)" (output output-response - (make-response/full 404 #"404" (current-seconds) #"text/html" + (response/full 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (list #"Content!"))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 8\r\nHeader: Value\r\n\r\nContent!")) @@ -80,36 +80,36 @@ "response/incremental" (test-equal? "response/incremental" (output output-response - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list) (lambda (write) (void)))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\n\r\n0\r\n\r\n") (test-equal? "response/incremental (header)" (output output-response - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (lambda (write) (void)))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n0\r\n\r\n") (test-equal? "response/incremental (body)" (output output-response - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list) (lambda (write) (write #"Content!")))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\n\r\n8\r\nContent!\r\n0\r\n\r\n") (test-equal? "response/incremental (bytes body)" (output output-response - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list) (lambda (write) (write #"Content!")))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\n\r\n8\r\nContent!\r\n0\r\n\r\n") (test-equal? "response/incremental (both)" (output output-response - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (lambda (write) (write #"Content!")))) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n8\r\nContent!\r\n0\r\n\r\n") (test-equal? "response/incremental (twice)" (output output-response - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (lambda (write) (write #"Content!") @@ -147,31 +147,31 @@ "response/full" (test-equal? "response/full" (output output-response/method - (make-response/full 404 #"404" (current-seconds) #"text/html" + (response/full 404 #"404" (current-seconds) #"text/html" (list) (list)) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 0\r\n\r\n") (test-equal? "response/full (header)" (output output-response/method - (make-response/full 404 #"404" (current-seconds) #"text/html" + (response/full 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (list)) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 0\r\nHeader: Value\r\n\r\n") (test-equal? "response/full (body)" (output output-response/method - (make-response/full 404 #"404" (current-seconds) #"text/html" + (response/full 404 #"404" (current-seconds) #"text/html" (list) (list #"Content!")) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 8\r\n\r\n") (test-equal? "response/full (bytes body)" (output output-response/method - (make-response/full 404 #"404" (current-seconds) #"text/html" + (response/full 404 #"404" (current-seconds) #"text/html" (list) (list #"Content!")) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 8\r\n\r\n") (test-equal? "response/full (both)" (output output-response/method - (make-response/full 404 #"404" (current-seconds) #"text/html" + (response/full 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (list #"Content!")) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nContent-Length: 8\r\nHeader: Value\r\n\r\n")) @@ -180,41 +180,41 @@ "response/incremental" (test-equal? "response/incremental" (output output-response/method - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list) (lambda (write) (void))) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\n\r\n") (test-equal? "response/incremental (header)" (output output-response/method - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (lambda (write) (void))) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n") (test-equal? "response/incremental (body)" (output output-response/method - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list) (lambda (write) (write #"Content!"))) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\n\r\n") (test-equal? "response/incremental (bytes body)" (output output-response/method - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list) (lambda (write) (write #"Content!"))) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\n\r\n") (test-equal? "response/incremental (both)" (output output-response/method - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (lambda (write) (write #"Content!"))) #"HEAD") #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nTransfer-Encoding: chunked\r\nHeader: Value\r\n\r\n") (test-equal? "response/incremental (twice)" (output output-response/method - (make-response/incremental 404 #"404" (current-seconds) #"text/html" + (response/incremental 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) (lambda (write) (write #"Content!") diff --git a/collects/tests/web-server/servlet/helpers-test.rkt b/collects/tests/web-server/servlet/helpers-test.rkt index 8c296fdbd2..37c93b916d 100644 --- a/collects/tests/web-server/servlet/helpers-test.rkt +++ b/collects/tests/web-server/servlet/helpers-test.rkt @@ -28,22 +28,22 @@ exn:fail:contract? (lambda () (redirect-to ""))) (test-equal? "Code (temp)" - (response/basic-code (redirect-to "http://test.com/foo")) + (response-code (redirect-to "http://test.com/foo")) 302) (test-equal? "Message (temp)" - (response/basic-message (redirect-to "http://test.com/foo")) + (response-message (redirect-to "http://test.com/foo")) #"Moved Temporarily") (test-equal? "Code" - (response/basic-code (redirect-to "http://test.com/foo" permanently)) + (response-code (redirect-to "http://test.com/foo" permanently)) 301) (test-equal? "Message" - (response/basic-message (redirect-to "http://test.com/foo" permanently)) + (response-message (redirect-to "http://test.com/foo" permanently)) #"Moved Permanently") (test-equal? "URL" - (dehead (response/basic-headers (redirect-to "http://test.com/foo"))) + (dehead (response-headers (redirect-to "http://test.com/foo"))) (list (list #"Location" #"http://test.com/foo"))) (test-equal? "Headers" - (dehead (response/basic-headers (redirect-to "http://test.com/foo" #:headers (list (make-header #"Header" #"Value"))))) + (dehead (response-headers (redirect-to "http://test.com/foo" #:headers (list (make-header #"Header" #"Value"))))) (list (list #"Location" #"http://test.com/foo") (list #"Header" #"Value")))) diff --git a/collects/tests/web-server/stress/vs-snap/dynamic.rkt b/collects/tests/web-server/stress/vs-snap/dynamic.rkt index 8d9d3f8a5f..698b25ce1a 100644 --- a/collects/tests/web-server/stress/vs-snap/dynamic.rkt +++ b/collects/tests/web-server/stress/vs-snap/dynamic.rkt @@ -4,7 +4,7 @@ racket/list) (define resp - (make-response/full + (response/full 200 #"Okay" (current-seconds) TEXT/HTML-MIME-TYPE empty diff --git a/collects/web-server/configuration/configuration-table-structs.rkt b/collects/web-server/configuration/configuration-table-structs.rkt index 48bbe8f7d6..57eed26b50 100644 --- a/collects/web-server/configuration/configuration-table-structs.rkt +++ b/collects/web-server/configuration/configuration-table-structs.rkt @@ -49,14 +49,14 @@ [timeouts timeouts?] [paths paths?])] [struct responders - ([servlet (url? any/c . -> . response/c)] - [servlet-loading (url? any/c . -> . response/c)] - [authentication (url? header? . -> . response/c)] - [servlets-refreshed (-> response/c)] - [passwords-refreshed (-> response/c)] - [file-not-found (request? . -> . response/c)] - [protocol (url? . -> . response/c)] - [collect-garbage (-> response/c)])] + ([servlet (url? any/c . -> . response?)] + [servlet-loading (url? any/c . -> . response?)] + [authentication (url? header? . -> . response?)] + [servlets-refreshed (-> response?)] + [passwords-refreshed (-> response?)] + [file-not-found (request? . -> . response?)] + [protocol (url? . -> . response?)] + [collect-garbage (-> response?)])] [struct messages ([servlet string?] [authentication string?] diff --git a/collects/web-server/configuration/responders.rkt b/collects/web-server/configuration/responders.rkt index 945ecb579d..0a73ad6d6c 100644 --- a/collects/web-server/configuration/responders.rkt +++ b/collects/web-server/configuration/responders.rkt @@ -46,10 +46,10 @@ ; The server should still start without the files there, so the ; configuration tool still runs. (Alternatively, find an work around.) (define (file-response code short text-file . headers) - (make-response/full code short - (current-seconds) TEXT/HTML-MIME-TYPE - headers - (list (read-file text-file)))) + (response/full code short + (current-seconds) TEXT/HTML-MIME-TYPE + headers + (list (read-file text-file)))) ; servlet-loading-responder : url tst -> response ; This is slightly tricky since the (interesting) content comes from the exception. @@ -116,14 +116,14 @@ (lambda (in) (read-bytes (file-size path) in)))) (provide/contract - [file-response ((natural-number/c bytes? path-string?) () #:rest (listof header?) . ->* . response/c)] - [servlet-loading-responder (url? exn? . -> . response/c)] - [gen-servlet-not-found (path-string? . -> . (url? . -> . response/c))] - [servlet-error-responder (url? exn? . -> . response/c)] - [gen-servlet-responder (path-string? . -> . (url? exn? . -> . response/c))] - [gen-servlets-refreshed (path-string? . -> . (-> response/c))] - [gen-passwords-refreshed (path-string? . -> . (-> response/c))] - [gen-authentication-responder (path-string? . -> . (url? header? . -> . response/c))] - [gen-protocol-responder (path-string? . -> . (url? . -> . response/c))] - [gen-file-not-found-responder (path-string? . -> . (request? . -> . response/c))] - [gen-collect-garbage-responder (path-string? . -> . (-> response/c))]) + [file-response ((natural-number/c bytes? path-string?) () #:rest (listof header?) . ->* . response?)] + [servlet-loading-responder (url? exn? . -> . response?)] + [gen-servlet-not-found (path-string? . -> . (url? . -> . response?))] + [servlet-error-responder (url? exn? . -> . response?)] + [gen-servlet-responder (path-string? . -> . (url? exn? . -> . response?))] + [gen-servlets-refreshed (path-string? . -> . (-> response?))] + [gen-passwords-refreshed (path-string? . -> . (-> response?))] + [gen-authentication-responder (path-string? . -> . (url? header? . -> . response?))] + [gen-protocol-responder (path-string? . -> . (url? . -> . response?))] + [gen-file-not-found-responder (path-string? . -> . (request? . -> . response?))] + [gen-collect-garbage-responder (path-string? . -> . (-> response?))]) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/basic.rkt b/collects/web-server/default-web-root/htdocs/servlets/examples/basic.rkt index 6a60b5de95..1a9c17fc55 100644 --- a/collects/web-server/default-web-root/htdocs/servlets/examples/basic.rkt +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/basic.rkt @@ -7,6 +7,7 @@ (body (h1 "User: " ,(bytes->string/utf-8 user)) (h1 "Pass: " ,(bytes->string/utf-8 pass))))] [else - (make-response/basic + (response 401 #"Unauthorized" (current-seconds) TEXT/HTML-MIME-TYPE - (list (make-basic-auth-header (format "Basic Auth Test: ~a" (gensym)))))])) + (list (make-basic-auth-header (format "Basic Auth Test: ~a" (gensym)))) + void)])) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/digest.rkt b/collects/web-server/default-web-root/htdocs/servlets/examples/digest.rkt index c6e3927cb0..0a7a8740e7 100644 --- a/collects/web-server/default-web-root/htdocs/servlets/examples/digest.rkt +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/digest.rkt @@ -7,18 +7,20 @@ (define (start req) (match (request->digest-credentials req) [#f - (make-response/basic + (response 401 #"Unauthorized" (current-seconds) TEXT/HTML-MIME-TYPE (list (make-digest-auth-header (format "Digest Auth Test: ~a" (gensym)) - private-key opaque)))] + private-key opaque)) + void)] [alist (define check (make-check-digest-credentials (password->digest-HA1 (lambda (username realm) "pass")))) (define pass? (check "GET" alist)) - `(html (head (title "Digest Auth Test")) - (body - (h1 ,(if pass? "Pass!" "No Pass!")) - (pre ,(pretty-format alist))))])) + (response/xexpr + `(html (head (title "Digest Auth Test")) + (body + (h1 ,(if pass? "Pass!" "No Pass!")) + (pre ,(pretty-format alist)))))])) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt b/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt index 21955dc509..217cd028cf 100644 --- a/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt @@ -6,7 +6,7 @@ (define timeout +inf.0) (define (start initial-request) - (response/port + (response 200 #"Okay" (current-seconds) #"text/html" empty (λ (op) (display #< . response/c) . -> . void)]) + [serve/dispatch ((request? . -> . response?) . -> . void)]) diff --git a/collects/web-server/dispatchers/dispatch-lift.rkt b/collects/web-server/dispatchers/dispatch-lift.rkt index 649e0105e8..37e7d8f14c 100644 --- a/collects/web-server/dispatchers/dispatch-lift.rkt +++ b/collects/web-server/dispatchers/dispatch-lift.rkt @@ -5,7 +5,7 @@ web-server/http/response) (provide/contract [interface-version dispatcher-interface-version/c] - [make ((request? . -> . response/c) . -> . dispatcher/c)]) + [make ((request? . -> . response?) . -> . dispatcher/c)]) (define interface-version 'v1) (define ((make procedure) conn req) diff --git a/collects/web-server/dispatchers/dispatch-passwords.rkt b/collects/web-server/dispatchers/dispatch-passwords.rkt index 59eaead069..ca4efa89b5 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.rkt +++ b/collects/web-server/dispatchers/dispatch-passwords.rkt @@ -16,7 +16,7 @@ [denied?/c contract?] [make (->* (denied?/c) (#:authentication-responder - (url? header? . -> . response/c)) + (url? header? . -> . response?)) dispatcher/c)] [authorized?/c contract?] [make-basic-denied?/path diff --git a/collects/web-server/dispatchers/dispatch-pathprocedure.rkt b/collects/web-server/dispatchers/dispatch-pathprocedure.rkt index c75355feb4..885d4be081 100644 --- a/collects/web-server/dispatchers/dispatch-pathprocedure.rkt +++ b/collects/web-server/dispatchers/dispatch-pathprocedure.rkt @@ -7,7 +7,7 @@ web-server/http/response) (provide/contract [interface-version dispatcher-interface-version/c] - [make (string? (request? . -> . response/c) . -> . dispatcher/c)]) + [make (string? (request? . -> . response?) . -> . dispatcher/c)]) (define interface-version 'v1) (define ((make the-path procedure) conn req) diff --git a/collects/web-server/dispatchers/dispatch-servlets.rkt b/collects/web-server/dispatchers/dispatch-servlets.rkt index 0db34a8654..0e31a86bc7 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.rkt +++ b/collects/web-server/dispatchers/dispatch-servlets.rkt @@ -47,8 +47,8 @@ ; ----- (provide/contract [make (->* (url->servlet/c) - (#:responders-servlet-loading (url? any/c . -> . response/c) - #:responders-servlet (url? any/c . -> . response/c)) + (#:responders-servlet-loading (url? any/c . -> . response?) + #:responders-servlet (url? any/c . -> . response?)) dispatcher/c)]) (define (make url->servlet diff --git a/collects/web-server/formlets/servlet.rkt b/collects/web-server/formlets/servlet.rkt index f2f11be9f5..3dc00ee3e4 100644 --- a/collects/web-server/formlets/servlet.rkt +++ b/collects/web-server/formlets/servlet.rkt @@ -5,7 +5,7 @@ (provide/contract [send/formlet ((formlet*/c) - (#:wrap (pretty-xexpr/c . -> . response/c)) + (#:wrap (pretty-xexpr/c . -> . response?)) . ->* . any)]) (define (send/formlet f diff --git a/collects/web-server/http/cookie.rkt b/collects/web-server/http/cookie.rkt index c44845aa07..e86ae4c47b 100644 --- a/collects/web-server/http/cookie.rkt +++ b/collects/web-server/http/cookie.rkt @@ -13,8 +13,7 @@ #:path (or/c false/c string?) #:secure? (or/c false/c boolean?)) . ->* . cookie?)] - [cookie->header (cookie? . -> . header?)] - [xexpr-response/cookies ((listof cookie?) pretty-xexpr/c . -> . response/full?)]) + [cookie->header (cookie? . -> . header?)]) (define-syntax setter (syntax-rules () @@ -45,14 +44,3 @@ (define (cookie->header cookie) (make-header #"Set-Cookie" (string->bytes/utf-8 (print-cookie cookie)))) -;; build-cookie-response : xexpr[xhtml] (listof cookie) -> response -(define (xexpr-response/cookies cookies xexpr) - (make-response/full - 200 - #"Okay" - (current-seconds) - TEXT/HTML-MIME-TYPE - (map cookie->header cookies) ; rfc2109 also recommends some cache-control stuff here - (list - (string->bytes/utf-8 - (xexpr->string xexpr))))) diff --git a/collects/web-server/http/redirect.rkt b/collects/web-server/http/redirect.rkt index 4fa6a0744a..ecc81dec44 100644 --- a/collects/web-server/http/redirect.rkt +++ b/collects/web-server/http/redirect.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require racket/contract) -(require web-server/private/util +(require racket/contract + web-server/private/util web-server/http/response-structs web-server/http/request-structs) @@ -16,17 +16,17 @@ uri [perm/temp temporarily] #:headers [headers (list)]) - (make-response/full (redirection-status-code perm/temp) - (redirection-status-message perm/temp) - (current-seconds) #"text/html" - (list* (make-header #"Location" (string->bytes/utf-8 uri)) - headers) - (list))) + (response (redirection-status-code perm/temp) + (redirection-status-message perm/temp) + (current-seconds) #"text/html" + (list* (make-header #"Location" (string->bytes/utf-8 uri)) + headers) + void)) (provide/contract [redirect-to (->* (non-empty-string?) (redirection-status? #:headers (listof header?)) - response/full?)] + response?)] [redirection-status? (any/c . -> . boolean?)] [permanently redirection-status?] [temporarily redirection-status?] diff --git a/collects/web-server/http/response-structs.rkt b/collects/web-server/http/response-structs.rkt index 84f71e26eb..43d6afffcd 100644 --- a/collects/web-server/http/response-structs.rkt +++ b/collects/web-server/http/response-structs.rkt @@ -1,123 +1,31 @@ -#lang racket -(require racket - xml - web-server/private/xexpr +#lang racket/base +(require racket/contract web-server/http/request-structs) (define TEXT/HTML-MIME-TYPE #"text/html; charset=utf-8") -(define-struct response/basic (code message seconds mime headers)) -(define-struct (response/full response/basic) (body)) -(define-struct (response/incremental response/basic) (generator)) -(define-struct (response/port response/basic) (output)) +(struct response (code message seconds mime headers output)) -(define response/c - (or/c response/basic? - (cons/c bytes? (listof (or/c string? bytes?))) - pretty-xexpr/c)) - -;; response/full->size: response/full -> number -(define (response/full->size resp) - (apply + (map bytes-length (response/full-body resp)))) - -(define (normalize-response resp [close? #f]) - (cond - [(response/full? resp) - (make-response/full - (response/basic-code resp) - (response/basic-message resp) - (response/basic-seconds resp) - (response/basic-mime resp) - (list* (make-header #"Content-Length" (string->bytes/utf-8 (number->string (response/full->size resp)))) - (response/basic-headers resp)) - (response/full-body resp))] - [(response/port? resp) - resp] - [(response/incremental? resp) - (if close? - resp - (make-response/incremental - (response/basic-code resp) - (response/basic-message resp) - (response/basic-seconds resp) - (response/basic-mime resp) - (list* (make-header #"Transfer-Encoding" #"chunked") - (response/basic-headers resp)) - (response/incremental-generator resp)))] - [(response/basic? resp) - (normalize-response - (make-response/full - (response/basic-code resp) - (response/basic-message resp) - (response/basic-seconds resp) - (response/basic-mime resp) - (response/basic-headers resp) - empty) - close?)] - [(and (list? resp) - (not (empty? resp)) - (bytes? (first resp)) - (andmap (lambda (i) (or (string? i) - (bytes? i))) - (rest resp))) - (normalize-response - (make-response/full - 200 #"Okay" (current-seconds) (car resp) empty - (map (lambda (bs) - (if (string? bs) - (string->bytes/utf-8 bs) - bs)) - (rest resp))) - close?)] - [else - (normalize-response - (make-xexpr-response resp) - close?)])) - -(define (make-xexpr-response - xexpr - #:code [code 200] - #:message [message #"Okay"] - #:seconds [seconds (current-seconds)] - #:mime-type [mime-type TEXT/HTML-MIME-TYPE] - #:headers [hdrs empty] - #:preamble [preamble #""]) - (make-response/full - code message seconds mime-type hdrs - (list preamble (string->bytes/utf-8 (xexpr->string xexpr))))) +(define (response/full code message seconds mime headers body) + (response code message seconds mime + (list* (make-header #"Content-Length" + (string->bytes/utf-8 + (number->string + (for/fold ([len 0]) + ([b (in-list body)]) + (+ len (bytes-length b)))))) + headers) + (lambda (op) + (for ([b (in-list body)]) + (write-bytes op))))) (provide/contract - [struct response/basic - ([code number?] - [message bytes?] - [seconds number?] - [mime bytes?] - [headers (listof header?)])] - [struct (response/full response/basic) - ([code number?] - [message bytes?] - [seconds number?] - [mime bytes?] - [headers (listof header?)] - [body (listof bytes?)])] - [struct (response/incremental response/basic) - ([code number?] - [message bytes?] - [seconds number?] - [mime bytes?] - [headers (listof header?)] - [generator ((() () #:rest (listof bytes?) . ->* . any) . -> . any)])] - [struct (response/port response/basic) + [struct response ([code number?] [message bytes?] [seconds number?] [mime bytes?] [headers (listof header?)] [output (output-port? . -> . void)])] - [response/c contract?] - [make-xexpr-response - ((pretty-xexpr/c) - (#:code number? #:message bytes? #:seconds number? #:mime-type bytes? #:headers (listof header?) #:preamble bytes?) - . ->* . response/full?)] - [normalize-response ((response/c) (boolean?) . ->* . (or/c response/full? response/incremental? response/port?))] + [response/full (-> number? bytes? number? bytes? (listof header?) (listof bytes?) response?)] [TEXT/HTML-MIME-TYPE bytes?]) diff --git a/collects/web-server/http/response.rkt b/collects/web-server/http/response.rkt index 51ee1eea14..cfe6387187 100644 --- a/collects/web-server/http/response.rkt +++ b/collects/web-server/http/response.rkt @@ -14,8 +14,8 @@ (provide/contract [print-headers (output-port? (listof header?) . -> . void)] - [rename ext:output-response output-response (connection? response/c . -> . void)] - [rename ext:output-response/method output-response/method (connection? response/c bytes? . -> . void)] + [rename ext:output-response output-response (connection? response? . -> . void)] + [rename ext:output-response/method output-response/method (connection? response? bytes? . -> . void)] [rename ext:output-file output-file (connection? path-string? bytes? bytes? (or/c pair? false/c) . -> . void)]) ;; Table 1. head responses: @@ -60,29 +60,28 @@ (output-response/method conn resp #"GET")) (define (output-response/method conn resp meth) - (define bresp (normalize-response resp (connection-close? conn))) - (output-headers+response/basic conn bresp) + (output-response-head conn resp) (unless (bytes-ci=? meth #"HEAD") - (output-response/basic conn bresp))) + (output-response-body conn resp))) ;; Write the headers portion of a response to an output port. ;; NOTE: According to RFC 2145 the server should write HTTP/1.1 ;; header for *all* clients. -(define (output-headers+response/basic conn bresp) +(define (output-response-head conn bresp) (fprintf (connection-o-port conn) "HTTP/1.1 ~a ~a\r\n" - (response/basic-code bresp) - (response/basic-message bresp)) + (response-code bresp) + (response-message bresp)) (output-headers conn (list* (make-header #"Date" (string->bytes/utf-8 (seconds->gmt-string (current-seconds)))) - (make-header #"Last-Modified" (string->bytes/utf-8 (seconds->gmt-string (response/basic-seconds bresp)))) + (make-header #"Last-Modified" (string->bytes/utf-8 (seconds->gmt-string (response-seconds bresp)))) (make-header #"Server" #"Racket") - (make-header #"Content-Type" (response/basic-mime bresp)) + (make-header #"Content-Type" (response-mime bresp)) (append (if (connection-close? conn) (list (make-header #"Connection" #"close")) empty) - (response/basic-headers bresp))))) + (response-headers bresp))))) ;; output-headers : connection (list-of header) -> void (define (output-headers conn headers) @@ -96,32 +95,10 @@ headers) (fprintf out "\r\n")) -(define (output-response/basic conn bresp) +(define (output-response-body conn bresp) (define o-port (connection-o-port conn)) - (match bresp - [(? response/full?) - (for-each - (lambda (str) (display str o-port)) - (response/full-body bresp))] - [(? response/port?) - ((response/port-output bresp) o-port)] - [(? response/incremental?) - (if (connection-close? conn) - ((response/incremental-generator bresp) - (lambda chunks - (for-each (lambda (chunk) (display chunk o-port)) chunks))) - (begin - ((response/incremental-generator bresp) - (lambda chunks - (define length (apply + 0 (map bytes-length chunks))) - (if (zero? length) - (flush-output o-port) - (begin - (fprintf o-port "~x\r\n" length) - (for-each (lambda (chunk) (display chunk o-port)) chunks) - (fprintf o-port "\r\n"))))) - ; one \r\n ends the last (empty) chunk and the second \r\n ends the (non-existant) trailers - (fprintf o-port "0\r\n\r\n")))])) + ((response-output bresp) o-port) + (flush-output o-port)) ; seconds->gmt-string : Nat -> String ; format is rfc1123 compliant according to rfc2068 (http/1.1) @@ -215,7 +192,7 @@ (lambda (exn) (fprintf (current-error-port) (exn-message exn)) - (output-headers+response/basic + (output-response-head conn (make-416-response modified-seconds mime-type)))]) (let* (; converted-ranges : (alist-of integer integer) @@ -251,7 +228,7 @@ converted-ranges multipart-headers))]) ; Send a 206 iff ranges were specified in the request: - (output-headers+response/basic + (output-response-head conn (if ranges (make-206-response modified-seconds mime-type total-content-length total-file-length converted-ranges boundary) @@ -358,36 +335,40 @@ (if (= (length converted-ranges) 1) (let ([start (caar converted-ranges)] [end (cdar converted-ranges)]) - (make-response/basic + (response 206 #"Partial content" modified-seconds mime-type (list (make-header #"Accept-Ranges" #"bytes") (make-content-length-header total-content-length) - (make-content-range-header start end total-file-length)))) - (make-response/basic + (make-content-range-header start end total-file-length)) + void)) + (response 206 #"Partial content" modified-seconds (bytes-append #"multipart/byteranges; boundary=" boundary) (list (make-header #"Accept-Ranges" #"bytes") - (make-content-length-header total-content-length))))) + (make-content-length-header total-content-length)) + void))) ;; make-200-response : integer bytes integer -> basic-response (define (make-200-response modified-seconds mime-type total-content-length) - (make-response/basic + (response 200 #"OK" modified-seconds mime-type (list (make-header #"Accept-Ranges" #"bytes") - (make-content-length-header total-content-length)))) + (make-content-length-header total-content-length)) + void)) ;; make-416-response : integer bytes -> basic-response (define (make-416-response modified-seconds mime-type) - (make-response/basic + (response 416 #"Invalid range request" modified-seconds mime-type - null)) + null + void)) ;; make-content-length-header : integer -> header (define (make-content-length-header total-content-length) diff --git a/collects/web-server/insta/insta.rkt b/collects/web-server/insta/insta.rkt index c145d8320b..a02b568f2c 100644 --- a/collects/web-server/insta/insta.rkt +++ b/collects/web-server/insta/insta.rkt @@ -58,8 +58,8 @@ #'(body ...))]) (quasisyntax/loc stx (#,@expanded - (provide/contract (#,start (request? . -> . response/c))) - (serve/servlet (contract (request? . -> . response/c) #,start + (provide/contract (#,start (request? . -> . response?))) + (serve/servlet (contract (request? . -> . response?) #,start 'you 'web-server "start" #f) diff --git a/collects/web-server/lang/web.rkt b/collects/web-server/lang/web.rkt index 4bf7f58d58..9d82fe9b06 100644 --- a/collects/web-server/lang/web.rkt +++ b/collects/web-server/lang/web.rkt @@ -26,22 +26,22 @@ (provide/contract [make-stateless-servlet - (custodian? namespace? manager? path-string? (request? . -> . response/c) + (custodian? namespace? manager? path-string? (request? . -> . response?) (stuffer/c serializable? bytes?) . -> . stateless-servlet?)]) ; These contracts interfere with the continuation safety marks #;(provide/contract ;; Server Interface - [initialize-servlet ((request? . -> . response/c) . -> . (request? . -> . response/c))] + [initialize-servlet ((request? . -> . response?) . -> . (request? . -> . response?))] ;; Servlet Interface - [send/suspend/hidden ((url? list? . -> . response/c) . -> . request?)] - [send/suspend/url ((url? . -> . response/c) . -> . request?)] - [send/suspend/url/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c) + [send/suspend/hidden ((url? list? . -> . response?) . -> . request?)] + [send/suspend/url ((url? . -> . response?) . -> . request?)] + [send/suspend/url/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response?) . -> . any/c)] [redirect/get (-> request?)]) -;; initial-servlet : (request -> response) -> (request -> response/c) +;; initial-servlet : (request -> response) -> (request -> response?) (define (initialize-servlet start) (let ([params (current-parameterization)]) (lambda (req0) diff --git a/collects/web-server/private/servlet.rkt b/collects/web-server/private/servlet.rkt index d2b8920046..a6613f4d7a 100644 --- a/collects/web-server/private/servlet.rkt +++ b/collects/web-server/private/servlet.rkt @@ -21,7 +21,7 @@ [namespace namespace?] [manager manager?] [directory path-string?] - [handler (request? . -> . response/c)])] + [handler (request? . -> . response?)])] [struct execution-context ([request request?])] [current-servlet (parameter/c (or/c false/c servlet?))] diff --git a/collects/web-server/scribblings/contracts.scrbl b/collects/web-server/scribblings/contracts.scrbl index 6d4edef3dd..e71624958a 100644 --- a/collects/web-server/scribblings/contracts.scrbl +++ b/collects/web-server/scribblings/contracts.scrbl @@ -16,7 +16,7 @@ Equivalent to @racket[string?]. Example: @racket["http://localhost:8080/servlets;1*1*20131636/examples/add.rkt"]} @defthing[response-generator/c contract?]{ -Equivalent to @racket[(k-url? . -> . response/c)]. +Equivalent to @racket[(k-url? . -> . response?)]. Example: @racketblock[(lambda (k-url) `(html @@ -26,7 +26,7 @@ Example: @racketblock[(lambda (k-url) } @defthing[expiration-handler/c contract?]{ -Equivalent to @racket[(or/c false/c (request? . -> . response/c))]. +Equivalent to @racket[(or/c false/c (request? . -> . response?))]. Typically @racket[#f] uses the default expiration handler, which displays an error message. diff --git a/collects/web-server/scribblings/ctable-structs.scrbl b/collects/web-server/scribblings/ctable-structs.scrbl index 9f6345b5e4..de7dfeda66 100644 --- a/collects/web-server/scribblings/ctable-structs.scrbl +++ b/collects/web-server/scribblings/ctable-structs.scrbl @@ -39,14 +39,14 @@ the configuration table S-expression file format described in [paths paths?])] @defstruct[responders - ([servlet (url? any/c . -> . response/c)] - [servlet-loading (url? any/c . -> . response/c)] - [authentication (url? (cons/c symbol? string?) . -> . response/c)] - [servlets-refreshed (-> response/c)] - [passwords-refreshed (-> response/c)] - [file-not-found (request? . -> . response/c)] - [protocol (url? . -> . response/c)] - [collect-garbage (-> response/c)])] + ([servlet (url? any/c . -> . response?)] + [servlet-loading (url? any/c . -> . response?)] + [authentication (url? (cons/c symbol? string?) . -> . response?)] + [servlets-refreshed (-> response?)] + [passwords-refreshed (-> response?)] + [file-not-found (request? . -> . response?)] + [protocol (url? . -> . response?)] + [collect-garbage (-> response?)])] @defstruct[messages ([servlet string?] diff --git a/collects/web-server/scribblings/dispatch-servlets.scrbl b/collects/web-server/scribblings/dispatch-servlets.scrbl index ee44247549..b5026bb701 100644 --- a/collects/web-server/scribblings/dispatch-servlets.scrbl +++ b/collects/web-server/scribblings/dispatch-servlets.scrbl @@ -21,11 +21,11 @@ @defproc[(make [url->servlet url->servlet/c] [#:responders-servlet-loading responders-servlet-loading - (url? exn? . -> . response/c) + (url? exn? . -> . response?) servlet-loading-responder] [#:responders-servlet responders-servlet - (url? exn? . -> . response/c) + (url? exn? . -> . response?) servlet-error-responder]) dispatcher/c]{ This dispatcher runs racket servlets, using @racket[url->servlet] to resolve URLs to the underlying servlets. @@ -46,7 +46,7 @@ [namespace namespace?] [manager manager?] [directory path-string?] - [handler (request? . -> . response/c)]) + [handler (request? . -> . response?)]) #:mutable]{ Instances of this structure hold the necessary parts of a servlet: the @racket[custodian] responsible for the servlet's resources, diff --git a/collects/web-server/scribblings/dispatch.scrbl b/collects/web-server/scribblings/dispatch.scrbl index ca2cdc3dca..166a87ca24 100644 --- a/collects/web-server/scribblings/dispatch.scrbl +++ b/collects/web-server/scribblings/dispatch.scrbl @@ -105,9 +105,9 @@ After mastering the world of blogging software, you decide to put the ubiquitous [dispatch-pattern dispatch-fun] ...)] #:contracts - ([else-fun (request? . -> . response/c)] - [dispatch-fun (request? any/c ... . -> . response/c)])]{ - Returns two values: the first is a dispatching function with the contract @racket[(request? . -> . response/c)] + ([else-fun (request? . -> . response?)] + [dispatch-fun (request? any/c ... . -> . response?)])]{ + Returns two values: the first is a dispatching function with the contract @racket[(request? . -> . response?)] that calls the appropriate @racket[dispatch-fun] based on the first @racket[dispatch-pattern] that matches the request's URL; the second is a URL-generating function with the contract @racket[(procedure? any/c ... . -> . string?)] that generates a URL using @racket[dispatch-pattern] for the @racket[dispatch-fun] given as its first argument. @@ -131,8 +131,8 @@ After mastering the world of blogging software, you decide to put the ubiquitous [dispatch-pattern dispatch-fun] ...)] #:contracts - ([else-fun (request? . -> . response/c)] - [dispatch-fun (request? any/c ... . -> . response/c)])]{ + ([else-fun (request? . -> . response?)] + [dispatch-fun (request? any/c ... . -> . response?)])]{ Like @racket[dispatch-rules], except returns a third value with the contract @racket[(request? . -> . boolean?)] that returns @racket[#t] if the dispatching rules apply to the request and @racket[#f] otherwise. } @@ -146,8 +146,8 @@ After mastering the world of blogging software, you decide to put the ubiquitous [dispatch-pattern dispatch-fun] ...)] #:contracts - ([else-fun (request? . -> . response/c)] - [dispatch-fun (request? any/c ... . -> . response/c)])]{ + ([else-fun (request? . -> . response?)] + [dispatch-fun (request? any/c ... . -> . response?)])]{ Returns a dispatching function as described by @racket[dispatch-rules]. } @@ -156,11 +156,11 @@ After mastering the world of blogging software, you decide to put the ubiquitous [dispatch-pattern dispatch-fun] ...) #:contracts - ([dispatch-fun (request? any/c ... . -> . response/c)])]{ + ([dispatch-fun (request? any/c ... . -> . response?)])]{ Returns a URL-generating function as described by @racket[dispatch-rules]. } -@defproc[(serve/dispatch [dispatch (request? . -> . response/c)]) +@defproc[(serve/dispatch [dispatch (request? . -> . response?)]) void]{ Calls @racket[serve/servlet] with a @racket[#:servlet-regexp] argument (@racket[#rx""]) so that every request is handled by @racket[dispatch]. } diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index e0da447530..2cef0a3ff9 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -141,7 +141,7 @@ URLs to paths on the filesystem. @a-dispatcher[web-server/dispatchers/dispatch-lift @elem{defines a dispatcher constructor.}]{ -@defproc[(make (proc (request? . -> . response/c))) +@defproc[(make (proc (request? . -> . response?))) dispatcher/c]{ Constructs a dispatcher that calls @racket[proc] on the request object, and outputs the response to the connection. @@ -167,7 +167,7 @@ URLs to paths on the filesystem. for invoking a particular procedure when a request is given to a particular URL path.}]{ -@defproc[(make (path string?) (proc (request? . -> . response/c))) +@defproc[(make (path string?) (proc (request? . -> . response?))) dispatcher/c]{ Checks if the request URL path as a string is equal to @racket[path] and if so, calls @racket[proc] for a response. @@ -257,7 +257,7 @@ a URL that refreshes the password file, servlet cache, etc.} @defproc[(make [denied? denied?/c] [#:authentication-responder authentication-responder - (url? header? . -> . response/c) + (url? header? . -> . response?) (gen-authentication-responder "forbidden.html")]) dispatcher/c]{ A dispatcher that checks if the request is denied based on @racket[denied?]. If so, then @@ -389,7 +389,7 @@ Consider this example: (lambda (conn req) (output-response/method conn - (make-response/full + (response/full 200 #"Okay" (current-seconds) TEXT/HTML-MIME-TYPE empty @@ -402,10 +402,10 @@ Consider this example: (lambda (conn req) (output-response/method conn - (make-response/full 200 #"Okay" - (current-seconds) TEXT/HTML-MIME-TYPE - empty - (list #"Unlimited")) + (response/full 200 #"Okay" + (current-seconds) TEXT/HTML-MIME-TYPE + empty + (list #"Unlimited")) (request-method req)))) #:port 8080) diff --git a/collects/web-server/scribblings/formlets.scrbl b/collects/web-server/scribblings/formlets.scrbl index 6814c8c0e5..3e5e4102dd 100755 --- a/collects/web-server/scribblings/formlets.scrbl +++ b/collects/web-server/scribblings/formlets.scrbl @@ -438,7 +438,7 @@ A few utilities are provided for using @tech{formlet}s in Web applications. @defproc[(send/formlet [f (formlet/c any/c ...)] [#:wrap wrapper - (xexpr/c . -> . response/c) + (xexpr/c . -> . response?) (lambda (form-xexpr) `(html (head (title "Form Entry")) (body ,form-xexpr)))]) diff --git a/collects/web-server/scribblings/lang-api.scrbl b/collects/web-server/scribblings/lang-api.scrbl index 452fd28cee..0491180334 100644 --- a/collects/web-server/scribblings/lang-api.scrbl +++ b/collects/web-server/scribblings/lang-api.scrbl @@ -34,7 +34,7 @@ A stateless servlet should @racket[provide] the following exports: } @defproc[(start [initial-request request?]) - response/c]{ + response?]{ This function is called when an instance of this servlet is started. The argument is the HTTP request that initiated the instance. } diff --git a/collects/web-server/scribblings/lang.scrbl b/collects/web-server/scribblings/lang.scrbl index 764232fab7..d011ce655f 100644 --- a/collects/web-server/scribblings/lang.scrbl +++ b/collects/web-server/scribblings/lang.scrbl @@ -11,7 +11,7 @@ @defmodule[web-server/lang/web]{ -@defproc[(send/suspend/url [response-generator (url? . -> . response/c)]) +@defproc[(send/suspend/url [response-generator (url? . -> . response?)]) request?]{ Captures the current continuation. Serializes it and stuffs it into a URL. Calls @racket[response-generator] with this URL and delivers @@ -19,12 +19,12 @@ the request is returned to this continuation. } -@defproc[(send/suspend [response-generator (string? . -> . response/c)]) +@defproc[(send/suspend [response-generator (string? . -> . response?)]) request?]{ Like @racket[send/suspend/url] but with a string URL representation. } -@defproc[(send/suspend/hidden [response-generator (url? xexpr/c . -> . response/c)]) +@defproc[(send/suspend/hidden [response-generator (url? xexpr/c . -> . response?)]) request?]{ Captures the current continuation. Serializes it and stuffs it into a hidden INPUT form element. @@ -34,7 +34,7 @@ the request is returned to this continuation. } -@defproc[(send/suspend/url/dispatch [make-response (((request? . -> . any) . -> . url?) . -> . response/c)]) +@defproc[(send/suspend/url/dispatch [make-response (((request? . -> . any) . -> . url?) . -> . response?)]) any]{ Calls @racket[make-response] with a function that, when called with a procedure from @racket[request?] to @racket[any/c] will generate a URL, that when invoked will call @@ -42,7 +42,7 @@ @racket[send/suspend/dispatch]. } -@defproc[(send/suspend/dispatch [make-response (((request? . -> . any) . -> . string?) . -> . response/c)]) +@defproc[(send/suspend/dispatch [make-response (((request? . -> . any) . -> . string?) . -> . response?)]) request?]{ Like @racket[send/suspend/url/dispatch] but with a string URL representation. } diff --git a/collects/web-server/scribblings/responders.scrbl b/collects/web-server/scribblings/responders.scrbl index f467717c93..e32ddee1bd 100644 --- a/collects/web-server/scribblings/responders.scrbl +++ b/collects/web-server/scribblings/responders.scrbl @@ -13,8 +13,8 @@ These functions are used by the default dispatcher constructor (see @secref["web turn the paths given in the @racket[configuration-table] into responders for the associated circumstance. @defproc[(file-response (http-code natural-number/c) (short-version string?) (text-file string?) (header header?) ...) - response/c]{ - Generates a @racket[response/full] with the given @racket[http-code] and @racket[short-version] + response?]{ + Generates a @racket[response?] with the given @racket[http-code] and @racket[short-version] as the corresponding fields; with the content of the @racket[text-file] as the body; and, with the @racket[header]s as, you guessed it, headers. @@ -24,53 +24,53 @@ to whatever URL @racket[file-response] is used to respond @emph{to}. Thus, you s } @defproc[(servlet-loading-responder (url url?) (exn exn?)) - response/c]{ + response?]{ Gives @racket[exn] to the @racket[current-error-handler] and response with a stack trace and a "Servlet didn't load" message. } @defproc[(gen-servlet-not-found (file path-string?)) - ((url url?) . -> . response/c)]{ + ((url url?) . -> . response?)]{ Returns a function that generates a standard "Servlet not found." error with content from @racket[file]. } @defproc[(servlet-error-responder (url url?) (exn exn?)) - response/c]{ + response?]{ Gives @racket[exn] to the @racket[current-error-handler] and response with a stack trace and a "Servlet error" message. } @defproc[(gen-servlet-responder (file path-string?)) - ((url url?) (exn any/c) . -> . response/c)]{ + ((url url?) (exn any/c) . -> . response?)]{ Prints the @racket[exn] to standard output and responds with a "Servlet error." message with content from @racket[file]. } @defproc[(gen-servlets-refreshed (file path-string?)) - (-> response/c)]{ + (-> response?)]{ Returns a function that generates a standard "Servlet cache refreshed." message with content from @racket[file]. } @defproc[(gen-passwords-refreshed (file path-string?)) - (-> response/c)]{ + (-> response?)]{ Returns a function that generates a standard "Passwords refreshed." message with content from @racket[file]. } @defproc[(gen-authentication-responder (file path-string?)) - ((url url?) (header header?) . -> . response/c)]{ + ((url url?) (header header?) . -> . response?)]{ Returns a function that generates an authentication failure error with content from @racket[file] and @racket[header] as the HTTP header. } @defproc[(gen-protocol-responder (file path-string?)) - ((url url?) . -> . response/c)]{ + ((url url?) . -> . response?)]{ Returns a function that generates a "Malformed request" error with content from @racket[file]. } @defproc[(gen-file-not-found-responder (file path-string?)) - ((req request?) . -> . response/c)]{ + ((req request?) . -> . response?)]{ Returns a function that generates a standard "File not found" error with content from @racket[file]. } @defproc[(gen-collect-garbage-responder (file path-string?)) - (-> response/c)]{ + (-> response?)]{ Returns a function that generates a standard "Garbage collection run" message with content from @racket[file]. } diff --git a/collects/web-server/scribblings/servlet-env-int.scrbl b/collects/web-server/scribblings/servlet-env-int.scrbl index 42a21bad6e..b59a0cebe0 100644 --- a/collects/web-server/scribblings/servlet-env-int.scrbl +++ b/collects/web-server/scribblings/servlet-env-int.scrbl @@ -20,7 +20,7 @@ These functions optimize the construction of dispatchers and launching of servers for single servlets and interactive development. @defproc[(dispatch/servlet - [start (request? . -> . response/c)] + [start (request? . -> . response?)] [#:regexp regexp regexp? #rx""] [#:stateless? stateless? boolean? #f] [#:stuffer stuffer (stuffer/c serializable? bytes?) default-stuffer] diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 65c202efbd..47c805da41 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -125,7 +125,7 @@ Like always, you don't even need to save the file. @section{Full API} -@defproc[(serve/servlet [start (request? . -> . response/c)] +@defproc[(serve/servlet [start (request? . -> . response?)] [#:command-line? command-line? boolean? #f] [#:connection-close? connection-close? boolean? #f] [#:launch-browser? launch-browser? boolean? (not command-line?)] @@ -149,7 +149,7 @@ Like always, you don't even need to save the file. [#:servlets-root servlets-root path-string? (build-path server-root-path "htdocs")] [#:servlet-current-directory servlet-current-directory path-string? servlets-root] [#:file-not-found-responder file-not-found-responder - (request? . -> . response/c) + (request? . -> . response?) (gen-file-not-found-responder (build-path server-root-path diff --git a/collects/web-server/scribblings/servlet-setup.scrbl b/collects/web-server/scribblings/servlet-setup.scrbl index da4f7ce908..bb7bad5cc1 100644 --- a/collects/web-server/scribblings/servlet-setup.scrbl +++ b/collects/web-server/scribblings/servlet-setup.scrbl @@ -14,14 +14,14 @@ This module is used internally to build and load servlets. It may be useful to t @defproc[(make-v1.servlet [directory path-string?] [timeout integer?] - [start (request? . -> . response/c)]) + [start (request? . -> . response?)]) servlet?]{ Creates a version 1 servlet that uses @racket[directory] as its current directory, a timeout manager with a @racket[timeout] timeout, and @racket[start] as the request handler. } @defproc[(make-v2.servlet [directory path-string?] [manager manager?] - [start (request? . -> . response/c)]) + [start (request? . -> . response?)]) servlet?]{ Creates a version 2 servlet that uses @racket[directory] as its current directory, a @racket[manager] as the continuation manager, and @racket[start] as the request handler. } @@ -29,7 +29,7 @@ This module is used internally to build and load servlets. It may be useful to t @defproc[(make-stateless.servlet [directory path-string?] [stuffer (stuffer/c serializable? bytes?)] [manager manager?] - [start (request? . -> . response/c)]) + [start (request? . -> . response?)]) servlet?]{ Creates a stateless @racketmodname[web-server] servlet that uses @racket[directory] as its current directory, @racket[stuffer] as its stuffer, and @racket[manager] as the continuation manager, and @racket[start] as the request handler. } diff --git a/collects/web-server/scribblings/servlet.scrbl b/collects/web-server/scribblings/servlet.scrbl index 1b7f571104..984d3e293e 100644 --- a/collects/web-server/scribblings/servlet.scrbl +++ b/collects/web-server/scribblings/servlet.scrbl @@ -23,7 +23,7 @@ A stateful servlet should @racket[provide] the following exports: } @defproc[(start [initial-request request?]) - response/c]{ + response?]{ This function is called when an instance of this servlet is started. The argument is the HTTP request that initiated the instance. } diff --git a/collects/web-server/scribblings/templates.scrbl b/collects/web-server/scribblings/templates.scrbl index 8f8f716a6a..7223a69d1e 100644 --- a/collects/web-server/scribblings/templates.scrbl +++ b/collects/web-server/scribblings/templates.scrbl @@ -261,9 +261,9 @@ the @racket[list] response type: (list #"text/html" (include-template "static.html")) ] -If you want more control then you can generate a @racket[response/full] struct: +If you want more control then you can generate a @racket[response?] struct: @racketblock[ - (make-response/full + (response/full 200 #"Okay" (current-seconds) TEXT/HTML-MIME-TYPE empty diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index d77cc7c521..66a982bc26 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -1246,7 +1246,7 @@ to racket (require web-server/servlet) -(provide/contract (start (request? . -> . response/c))) +(provide/contract (start (request? . -> . response?))) ] Second, add the following at the bottom of your application: diff --git a/collects/web-server/scribblings/web.scrbl b/collects/web-server/scribblings/web.scrbl index cc7a13fb7c..6f6fc0e850 100644 --- a/collects/web-server/scribblings/web.scrbl +++ b/collects/web-server/scribblings/web.scrbl @@ -12,7 +12,7 @@ @racketmodname[web-server/servlet/web] library provides the primary functions of interest for the servlet developer. -@defproc[(send/back [response response/c]) +@defproc[(send/back [response response?]) void?]{ Sends @racket[response] to the client. No continuation is captured, so the servlet is done. @@ -27,11 +27,11 @@ functions of interest for the servlet developer. ] } -@defproc[(send/suspend [make-response (string? . -> . response/c)]) +@defproc[(send/suspend [make-response (string? . -> . response?)]) request?]{ Captures the current continuation, stores it with @racket[exp] as the expiration handler, and binds it to a URL. @racket[make-response] is called with this URL and - is expected to generate a @racket[response/c], which is sent to the client. If the + is expected to generate a @racket[response?], which is sent to the client. If the continuation URL is invoked, the captured continuation is invoked and the request is returned from this call to @racket[send/suspend]. @@ -51,12 +51,12 @@ functions of interest for the servlet developer. Thus, the request will be ``returned'' from @racket[send/suspend] to the continuation of this call. } -@defproc[(send/suspend/url [make-response (url? . -> . response/c)]) +@defproc[(send/suspend/url [make-response (url? . -> . response?)]) request?]{ Like @racket[send/suspend] but with a URL struct. } -@defproc[(send/suspend/dispatch [make-response (((request? . -> . any) . -> . string?) . -> . response/c)]) +@defproc[(send/suspend/dispatch [make-response (((request? . -> . any) . -> . string?) . -> . response?)]) any]{ Calls @racket[make-response] with a function (@racket[embed/url]) that, when called with a procedure from @racket[request?] to @racket[any/c] will generate a URL, that when invoked will call @@ -117,19 +117,19 @@ functions of interest for the servlet developer. ] } -@defproc[(send/suspend/url/dispatch [make-response (((request? . -> . any) . -> . url?) . -> . response/c)]) +@defproc[(send/suspend/url/dispatch [make-response (((request? . -> . any) . -> . url?) . -> . response?)]) any]{ Like @racket[send/suspend/dispatch], but with a URL struct. } -@defproc[(send/forward [make-response (string? . -> . response/c)]) +@defproc[(send/forward [make-response (string? . -> . response?)]) request?]{ Calls @racket[clear-continuation-table!], then @racket[send/suspend]. Use this if the user can logically go `forward' in your application, but cannot go backward. } -@defproc[(send/finish [response response/c]) +@defproc[(send/finish [response response?]) void?]{ Calls @racket[clear-continuation-table!], then @racket[send/back]. @@ -176,7 +176,7 @@ functions of interest for the servlet developer. captured continuations. } -@defproc[(with-errors-to-browser [send/finish-or-back (response/c . -> . request?)] +@defproc[(with-errors-to-browser [send/finish-or-back (response? . -> . request?)] [thunk (-> any)]) any]{ Calls @racket[thunk] with an exception handler that generates an HTML error page diff --git a/collects/web-server/servlet-dispatch.rkt b/collects/web-server/servlet-dispatch.rkt index 2e063e5824..3db5963919 100644 --- a/collects/web-server/servlet-dispatch.rkt +++ b/collects/web-server/servlet-dispatch.rkt @@ -25,7 +25,7 @@ (define send-url (make-parameter net:send-url)) (provide/contract - [dispatch/servlet (((request? . -> . response/c)) + [dispatch/servlet (((request? . -> . response?)) (#:regexp regexp? #:current-directory path-string? #:stateless? boolean? diff --git a/collects/web-server/servlet-env.rkt b/collects/web-server/servlet-env.rkt index 085c963a1d..d6a2dadd39 100644 --- a/collects/web-server/servlet-env.rkt +++ b/collects/web-server/servlet-env.rkt @@ -38,7 +38,7 @@ "web-server/default-web-root")) (provide/contract - [serve/servlet (((request? . -> . response/c)) + [serve/servlet (((request? . -> . response?)) (#:connection-close? boolean? #:command-line? boolean? #:launch-browser? boolean? @@ -57,7 +57,7 @@ #:extra-files-paths (listof path-string?) #:servlets-root path-string? #:servlet-current-directory path-string? - #:file-not-found-responder (request? . -> . response/c) + #:file-not-found-responder (request? . -> . response?) #:mime-types-path path-string? #:servlet-path string? #:servlet-regexp regexp? diff --git a/collects/web-server/servlet/servlet-structs.rkt b/collects/web-server/servlet/servlet-structs.rkt index 8cf3c65f83..3e1d0ee3b4 100644 --- a/collects/web-server/servlet/servlet-structs.rkt +++ b/collects/web-server/servlet/servlet-structs.rkt @@ -6,11 +6,11 @@ string?) (define response-generator/c - (k-url? . -> . response/c)) + (k-url? . -> . response?)) (define expiration-handler/c (or/c false/c - (request? . -> . response/c))) + (request? . -> . response?))) (define embed/url/c ((request? . -> . any/c) . -> . string?)) diff --git a/collects/web-server/servlet/setup.rkt b/collects/web-server/servlet/setup.rkt index d636cb5974..32c7a697e6 100644 --- a/collects/web-server/servlet/setup.rkt +++ b/collects/web-server/servlet/setup.rkt @@ -111,9 +111,9 @@ servlet-module-specs lang-module-specs)) (provide/contract - [make-v1.servlet (path-string? integer? (request? . -> . response/c) . -> . servlet?)] - [make-v2.servlet (path-string? manager? (request? . -> . response/c) . -> . servlet?)] - [make-stateless.servlet (path-string? (stuffer/c serializable? bytes?) manager? (request? . -> . response/c) . -> . servlet?)] + [make-v1.servlet (path-string? integer? (request? . -> . response?) . -> . servlet?)] + [make-v2.servlet (path-string? manager? (request? . -> . response?) . -> . servlet?)] + [make-stateless.servlet (path-string? (stuffer/c serializable? bytes?) manager? (request? . -> . response?) . -> . servlet?)] [default-module-specs (listof (or/c resolved-module-path? module-path?))]) (define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] @@ -143,13 +143,13 @@ (dynamic-require module-name 'timeout) pos-blame neg-blame "timeout" loc)] - [start (contract (request? . -> . response/c) + [start (contract (request? . -> . response?) (dynamic-require module-name 'start) pos-blame neg-blame "start" loc)]) (make-v1.servlet (directory-part a-path) timeout start))] [(v2) - (let ([start (contract (request? . -> . response/c) + (let ([start (contract (request? . -> . response?) (dynamic-require module-name 'start) pos-blame neg-blame "start" loc)] @@ -159,7 +159,7 @@ "manager" loc)]) (make-v2.servlet (directory-part a-path) manager start))] [(stateless) - (let ([start (contract (request? . -> . response/c) + (let ([start (contract (request? . -> . response?) (dynamic-require module-name 'start) pos-blame neg-blame "start" loc)] @@ -176,7 +176,7 @@ [else (make-v1.servlet (directory-part a-path) timeouts-default-servlet (v0.response->v1.lambda - (contract response/c s + (contract response? s pos-blame neg-blame path-string loc) a-path))]))))) diff --git a/collects/web-server/servlet/web.rkt b/collects/web-server/servlet/web.rkt index da1744e5e1..2cfeb32765 100644 --- a/collects/web-server/servlet/web.rkt +++ b/collects/web-server/servlet/web.rkt @@ -41,13 +41,13 @@ [redirect/get/forget (() (#:headers (listof header?)) . ->* . request?)] [adjust-timeout! (number? . -> . void?)] [clear-continuation-table! (-> void?)] - [send/back (response/c . -> . void?)] - [send/finish (response/c . -> . void?)] + [send/back (response? . -> . void?)] + [send/finish (response? . -> . void?)] [send/forward (response-generator/c . -> . request?)] [send/suspend (response-generator/c . -> . request?)] - [send/suspend/dispatch ((embed/url/c . -> . response/c) . -> . any/c)] - [send/suspend/url ((url? . -> . response/c) . -> . request?)] - [send/suspend/url/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c) . -> . any/c)]) + [send/suspend/dispatch ((embed/url/c . -> . response?) . -> . any/c)] + [send/suspend/url ((url? . -> . response?) . -> . request?)] + [send/suspend/url/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response?) . -> . any/c)]) ;; ************************************************************ ;; EXPORTS @@ -158,7 +158,7 @@ (provide/contract [with-errors-to-browser - ((response/c . -> . request?) + ((response? . -> . request?) (-> any) . -> . any)]) diff --git a/collects/web-server/xexpr.rkt b/collects/web-server/xexpr.rkt new file mode 100644 index 0000000000..89a33bb0c5 --- /dev/null +++ b/collects/web-server/xexpr.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require racket/contract + racket/list + xml + web-server/http/cookie + web-server/private/xexpr + web-server/http/response-structs) + +(define (response/xexpr + xexpr + #:code [code 200] + #:message [message #"Okay"] + #:seconds [seconds (current-seconds)] + #:mime-type [mime-type TEXT/HTML-MIME-TYPE] + #:cookies [cooks empty] + #:headers [hdrs empty] + #:preamble [preamble #""]) + (response/full + code message seconds mime-type + ; rfc2109 also recommends some cache-control stuff here for cookies + (append hdrs (map cookie->header cooks)) + ; XXX Use a normal response and + (list preamble (string->bytes/utf-8 (xexpr->string xexpr))))) + +(provide/contract + [response/xexpr + ((pretty-xexpr/c) + (#:code number? #:message bytes? #:seconds number? #:mime-type bytes? #:headers (listof header?) #:preamble bytes?) + . ->* . response?)]) \ No newline at end of file