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

Fixing conn mutexes and adding ssd

Browse Source 
svn: r632
This commit is contained in:
Jay McCarthy 2005-08-22 15:35:32 +00:00
parent 5e0b886ee6
commit a257bb310b
2 changed files with 52 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
collects/web-server/response.ss
View File

@ -74,14 +74,22 @@
. any)]
)]
[response? (any/c . -> . boolean?)]
[output-response (connection? any/c . -> . any)]
[output-response/method (connection? response? symbol? . -> . any)]
[output-file (connection? path? symbol? bytes? . -> . any)]
[rename ext:output-response output-response (connection? any/c . -> . any)]
[rename ext:output-response/method output-response/method (connection? response? symbol? . -> . any)]
[rename ext:output-file output-file (connection? path? symbol? bytes? . -> . any)]
[TEXT/HTML-MIME-TYPE bytes?]
)
(define (ext:output-response conn resp)
(call-with-semaphore (connection-mutex conn)
(lambda () (output-response conn resp))))
(define (ext:output-response/method conn resp meth)
(call-with-semaphore (connection-mutex conn)
(lambda () (output-response/method conn resp meth))))
(define (ext:output-file conn file-path method mime-type)
(call-with-semaphore (connection-mutex conn)
(lambda () (output-file conn file-path method mime-type))))
;; Table 1. head responses:
; ------------------------------------------------------------------------------
@ -175,15 +183,10 @@
(define DAYS
#("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
;; **************************************************
;; output-response: connection response -> void
(define (output-response conn resp)
(call-with-semaphore
(connection-mutex conn)
(lambda ()
(cond
[(response/full? resp)
(output-response/basic
@ -230,7 +233,7 @@
(add1 (string-length str))
(lambda (o-port)
(display str o-port)
(newline o-port)))))]))))
(newline o-port)))))]))
;; response/full->size: response/full -> number
;; compute the size for a response/full
@ -245,32 +248,26 @@
;; **************************************************
;; output-file: connection path symbol bytes -> void
(define (output-file conn file-path method mime-type)
(call-with-semaphore
(connection-mutex conn)
(lambda ()
(output-headers conn 200 "Okay"
`(("Content-length: " ,(file-size file-path)))
(file-or-directory-modify-seconds file-path)
mime-type)
(when (eq? method 'get)
; Give it one second per byte.
(adjust-connection-timeout! conn (file-size file-path))
(call-with-input-file file-path
(lambda (i-port) (copy-port i-port (connection-o-port conn))))))))
(output-headers conn 200 "Okay"
`(("Content-length: " ,(file-size file-path)))
(file-or-directory-modify-seconds file-path)
mime-type)
(when (eq? method 'get)
; Give it one second per byte.
(adjust-connection-timeout! conn (file-size file-path))
(call-with-input-file file-path
(lambda (i-port) (copy-port i-port (connection-o-port conn))))))
;; **************************************************
;; output-response/method: connection response/full symbol -> void
;; If it is a head request output headers only, otherwise output as usual
(define (output-response/method conn resp meth)
(call-with-semaphore
(connection-mutex conn)
(lambda ()
(cond
[(eqv? meth 'head)
(output-headers/response conn resp `(("Content-length: "
,(response/full->size resp))))]
[else
(output-response conn resp)]))))
(cond
[(eqv? meth 'head)
(output-headers/response conn resp `(("Content-length: "
,(response/full->size resp))))]
[else
(output-response conn resp)]))
;; **************************************************
;; output-headers/response: connection response (listof (listof string)) -> void

41
collects/web-server/servlet.ss
View File

@ -15,15 +15,13 @@
(send/suspend ((string? . -> . any/c) . -> . request?))
(send/forward ((string? . -> . any/c) . -> . request?))
;;; validate-xexpr/callback is not checked anywhere:
(send/suspend/callback (xexpr/callback? . -> . any))
)
(send/suspend/callback (xexpr/callback? . -> . any)))
(provide
(all-from "servlet-helpers.ss")
(all-from "xexpr-callback.ss")
)
send/suspend/dispatch
(all-from "servlet-helpers.ss")
(all-from "xexpr-callback.ss"))
;; ************************************************************
;; EXPORTS
@ -45,13 +43,12 @@
(define (send/suspend response-generator)
(let/cc k
(let* ([inst (current-servlet-instance)]
[ctxt (servlet-instance-context inst)])
(output-response
(execution-context-connection ctxt)
(response-generator
(store-continuation!
k (request-uri (execution-context-request ctxt))
inst)))
[ctxt (servlet-instance-context inst)]
[k-url (store-continuation!
k (request-uri (execution-context-request ctxt))
inst)]
[response (response-generator k-url)])
(output-response (execution-context-connection ctxt) response)
((execution-context-suspend ctxt)))))
;; send/forward: (url -> response) -> request
@ -59,15 +56,23 @@
(define (send/forward response-generator)
(clear-continuations! (current-servlet-instance))
(send/suspend response-generator))
;; send/suspend/callback : xexpr/callback? -> void
;; send/back a response with callbacks in it; send/suspend those callbacks.
(define (send/suspend/callback p-exp)
(send/suspend/dispatch
(lambda (embed/url)
(replace-procedures p-exp embed/url))))
;; send/suspend/dispatch : ((proc -> url) -> response) -> request
;; send/back a response generated from a procedure that may convert
;; procedures to continuation urls
(define (send/suspend/dispatch response-generator)
(let/cc k0
(send/back
(replace-procedures
p-exp (lambda (proc)
(let/cc k1 (k0 (proc (send/suspend k1)))))))))
(response-generator
(lambda (proc)
(let/cc k1 (k0 (proc (send/suspend k1)))))))))
;; ************************************************************