suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

First pass at Xexpr removal

Browse Source
This commit is contained in:
Jay McCarthy 2010-11-27 11:08:48 -05:00
parent dc01f00afc
commit 05c9fcd412
45 changed files with 266 additions and 372 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/tests/web-server/http/cookies-test.rkt
View File

@ -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 #"<html />"))
(test-equal? "One (body)"
(response/full-body (xexpr-response/cookies (list (make-cookie "name" "value")) `(html)))
(list #"<html />"))
(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"

74
collects/tests/web-server/private/response-test.rkt
View File

@ -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!")

12
collects/tests/web-server/servlet/helpers-test.rkt
View File

@ -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"))))

2
collects/tests/web-server/stress/vs-snap/dynamic.rkt
View File

@ -4,7 +4,7 @@
racket/list)
(define resp
(make-response/full
(response/full
200 #"Okay"
(current-seconds) TEXT/HTML-MIME-TYPE
empty

16
collects/web-server/configuration/configuration-table-structs.rkt
View File

@ -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?]

30
collects/web-server/configuration/responders.rkt
View File

@ -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?))])

5
collects/web-server/default-web-root/htdocs/servlets/examples/basic.rkt
View File

@ -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)]))

14
collects/web-server/default-web-root/htdocs/servlets/examples/digest.rkt
View File

@ -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)))))]))

2
collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt
View File

@ -6,7 +6,7 @@
(define timeout +inf.0)
(define (start initial-request)
(response/port
(response
200 #"Okay" (current-seconds) #"text/html" empty
(λ (op)
(display #<<END

2
collects/web-server/default-web-root/htdocs/servlets/examples/template-full.rkt
View File

@ -6,7 +6,7 @@
(define timeout +inf.0)
(define (start initial-request)
(make-response/full
(response/full
200 #"Okay"
(current-seconds) TEXT/HTML-MIME-TYPE
empty

2
collects/web-server/dispatch/serve.rkt
View File

@ -8,4 +8,4 @@
#:servlet-regexp #rx""))
(provide/contract
[serve/dispatch ((request? . -> . response/c) . -> . void)])
[serve/dispatch ((request? . -> . response?) . -> . void)])

2
collects/web-server/dispatchers/dispatch-lift.rkt
View File

@ -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)

2
collects/web-server/dispatchers/dispatch-passwords.rkt
View File

@ -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

2
collects/web-server/dispatchers/dispatch-pathprocedure.rkt
View File

@ -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)

4
collects/web-server/dispatchers/dispatch-servlets.rkt
View File

@ -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

2
collects/web-server/formlets/servlet.rkt
View File

@ -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

14
collects/web-server/http/cookie.rkt
View File

@ -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)))))

18
collects/web-server/http/redirect.rkt
View File

@ -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?]

126
collects/web-server/http/response-structs.rkt
View File

@ -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?])

73
collects/web-server/http/response.rkt
View File

@ -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)

4
collects/web-server/insta/insta.rkt
View File

@ -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)

12
collects/web-server/lang/web.rkt
View File

@ -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)

2
collects/web-server/private/servlet.rkt
View File

@ -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?))]

4
collects/web-server/scribblings/contracts.scrbl
View File

@ -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.

16
collects/web-server/scribblings/ctable-structs.scrbl
View File

@ -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?]

6
collects/web-server/scribblings/dispatch-servlets.scrbl
View File

@ -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,

18
collects/web-server/scribblings/dispatch.scrbl
View File

@ -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].
}

16
collects/web-server/scribblings/dispatchers.scrbl
View File

@ -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 #"<html><body>Unlimited</body></html>"))
(response/full 200 #"Okay"
(current-seconds) TEXT/HTML-MIME-TYPE
empty
(list #"<html><body>Unlimited</body></html>"))
(request-method req))))
#:port 8080)

2
collects/web-server/scribblings/formlets.scrbl
View File

@ -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)))])

2
collects/web-server/scribblings/lang-api.scrbl
View File

@ -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.
}

10
collects/web-server/scribblings/lang.scrbl
View File

@ -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.
}

24
collects/web-server/scribblings/responders.scrbl
View File

@ -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].
}

2
collects/web-server/scribblings/servlet-env-int.scrbl
View File

@ -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]

4
collects/web-server/scribblings/servlet-env.scrbl
View File

@ -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

6
collects/web-server/scribblings/servlet-setup.scrbl
View File

@ -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.
}

2
collects/web-server/scribblings/servlet.scrbl
View File

@ -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.
}

4
collects/web-server/scribblings/templates.scrbl
View File

@ -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

2
collects/web-server/scribblings/tutorial/continue.scrbl
View File

@ -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:

18
collects/web-server/scribblings/web.scrbl
View File

@ -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

2
collects/web-server/servlet-dispatch.rkt
View File

@ -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?

4
collects/web-server/servlet-env.rkt
View File

@ -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?

4
collects/web-server/servlet/servlet-structs.rkt
View File

@ -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?))

14
collects/web-server/servlet/setup.rkt
View File

@ -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))])))))

12
collects/web-server/servlet/web.rkt
View File

@ -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)])

29
collects/web-server/xexpr.rkt Normal file
View File

@ -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?)])