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

Correcting contract and caching host-table

Browse Source 
svn: r696
This commit is contained in:
Jay McCarthy 2005-08-29 12:38:44 +00:00
parent cc259d1c90
commit 67360f2843
3 changed files with 41 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/web-server/dispatch-servlets.ss
View File

@ -80,11 +80,10 @@
(lambda (the-exn)
(output-response/method
conn
((responders-servlet-loading (host-responders
host-info)) uri
the-exn)
(request-method req)))])
((responders-servlet-loading
(host-responders host-info))
uri the-exn)
(request-method req)))])
(let ([sema (make-semaphore 0)]
[last-inst (thread-cell-ref current-servlet-instance)])
(let/cc suspend
@ -180,7 +179,6 @@
(or (and (directory-exists? base) base)
(loop base))))))
;; invoke-servlet-continuation: connection request continuation-reference
;; host -> void
;; pull the continuation out of the table and apply it

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

@ -128,7 +128,7 @@
(response/full-body resp))))]
[(response/incremental? resp)
(output-response/incremental conn resp)]
[(and (pair? resp) (string? (car resp)))
[(and (pair? resp) (bytes? (car resp)))
(output-response/basic
conn
(make-response/basic 200 "Okay" (current-seconds) (car resp) '())

56
collects/web-server/web-server-unit.ss
View File

@ -150,28 +150,44 @@
;; NOTE: (GregP) I'm going to use the dispatch logic out of v208 for now.
;; I will move the other dispatch logic out of the prototype
;; at a later time.
(define (dispatch conn req)
(let* ([host (get-host (request-uri req) (request-headers req))]
[host-info (config:virtual-hosts host)])
((host-log-message host-info) (request-host-ip req)
(request-client-ip req) (request-method req) (request-uri req) host)
((sequencer:gen-dispatcher
(passwords:gen-dispatcher host-info config:access)
(path-procedure:gen-dispatcher "/conf/collect-garbage"
(lambda ()
(collect-garbage)
((responders-collect-garbage (host-responders host-info)))))
(servlets:gen-dispatcher host-info
config:instances config:scripts config:scripts-lock config:make-servlet-namespace)
(files:gen-dispatcher host-info))
conn req)))))
(define dispatch
(let* ([cache (make-hash-table 'equal)]
[sema (make-semaphore 1)]
[lookup-dispatcher
(lambda (host host-info)
(hash-table-get
cache host
(lambda ()
(call-with-semaphore
sema (lambda ()
(hash-table-get
cache host
(lambda () (host-info->dispatcher host-info))))))))])
(lambda (conn req)
(let* ([host (get-host (request-uri req) (request-headers req))]
[host-info (config:virtual-hosts host)])
((host-log-message host-info) (request-host-ip req)
(request-client-ip req) (request-method req) (request-uri req) host)
((lookup-dispatcher host host-info)
conn req)))))
(define (host-info->dispatcher host-info)
(sequencer:gen-dispatcher
(passwords:gen-dispatcher host-info config:access)
(path-procedure:gen-dispatcher "/conf/collect-garbage"
(lambda ()
(collect-garbage)
((responders-collect-garbage (host-responders host-info)))))
(servlets:gen-dispatcher host-info
config:instances config:scripts config:scripts-lock config:make-servlet-namespace)
(files:gen-dispatcher host-info)))))
(define web-server@
(compound-unit/sig
(import (TCP : net:tcp^)
(CONFIG : web-config^))
(link (DISPATCH : dispatch-server^
(dispatch-server@ TCP DISPATCH-CONFIG))
(DISPATCH-CONFIG : dispatch-server-config^
(web-config@->dispatch-server-config@ CONFIG)))
(export (open (DISPATCH : web-server^))))))
(link (DISPATCH-CONFIG : dispatch-server-config^
(web-config@->dispatch-server-config@ CONFIG))
(DISPATCH : dispatch-server^
(dispatch-server@ TCP DISPATCH-CONFIG)))
(export (open (DISPATCH : web-server^))))))