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

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

@ -80,11 +80,10 @@
(lambda (the-exn) (lambda (the-exn)
(output-response/method (output-response/method
conn conn
((responders-servlet-loading (host-responders ((responders-servlet-loading
host-info)) uri (host-responders host-info))
the-exn) uri the-exn)
(request-method req)))]) (request-method req)))])
(let ([sema (make-semaphore 0)] (let ([sema (make-semaphore 0)]
[last-inst (thread-cell-ref current-servlet-instance)]) [last-inst (thread-cell-ref current-servlet-instance)])
(let/cc suspend (let/cc suspend
@ -180,7 +179,6 @@
(or (and (directory-exists? base) base) (or (and (directory-exists? base) base)
(loop base)))))) (loop base))))))
;; invoke-servlet-continuation: connection request continuation-reference ;; invoke-servlet-continuation: connection request continuation-reference
;; host -> void ;; host -> void
;; pull the continuation out of the table and apply it ;; 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/full-body resp))))]
[(response/incremental? resp) [(response/incremental? resp)
(output-response/incremental conn resp)] (output-response/incremental conn resp)]
[(and (pair? resp) (string? (car resp))) [(and (pair? resp) (bytes? (car resp)))
(output-response/basic (output-response/basic
conn conn
(make-response/basic 200 "Okay" (current-seconds) (car resp) '()) (make-response/basic 200 "Okay" (current-seconds) (car resp) '())

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

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