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

Fixing PR 7359

Browse Source 
svn: r656
This commit is contained in:
Jay McCarthy 2005-08-24 17:59:53 +00:00
parent 6e1a28e126
commit 68667a740f
1 changed files with 64 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -459,25 +459,22 @@
[real-servlet-path (url-path->path [real-servlet-path (url-path->path
(paths-servlet (host-paths host-info)) (paths-servlet (host-paths host-info))
(url-path->string (url-path uri)))] (url-path->string (url-path uri)))]
[servlet-exit-handler (make-servlet-exit-handler inst)] [servlet-exit-handler (make-servlet-exit-handler inst)])
)
(parameterize ([current-directory (get-servlet-base-dir real-servlet-path)] (parameterize ([current-directory (get-servlet-base-dir real-servlet-path)]
[current-custodian servlet-custodian] [current-custodian servlet-custodian]
[current-servlet-instance inst] [current-servlet-instance inst]
[exit-handler servlet-exit-handler]) [exit-handler servlet-exit-handler])
(let-values (;; timer thread must be within the dynamic extent of
(let (;; timer thread must be within the dynamic extent of
;; servlet custodian ;; servlet custodian
[time-bomb (start-timer (timeouts-default-servlet [(time-bomb) (start-timer (timeouts-default-servlet
(host-timeouts host-info)) (host-timeouts host-info))
(lambda () (lambda ()
(servlet-exit-handler #f)))] (servlet-exit-handler #f)))]
;; any resources (e.g. threads) created when the ;; any resources (e.g. threads) created when the
;; servlet is loaded should be within the dynamic ;; servlet is loaded should be within the dynamic
;; extent of the servlet custodian ;; extent of the servlet custodian
[servlet-program (cached-load real-servlet-path)]) [(servlet-program servlet-namespace) (cached-load real-servlet-path)])
(parameterize ([current-namespace servlet-namespace])
(set-servlet-instance-timer! inst time-bomb) (set-servlet-instance-timer! inst time-bomb)
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(make-servlet-exception-handler inst (make-servlet-exception-handler inst
@ -500,7 +497,7 @@
;; response. ;; response.
(let ([r (invoke-unit/sig servlet-program servlet^)]) (let ([r (invoke-unit/sig servlet-program servlet^)])
(when (response? r) (when (response? r)
(send/back r))))))))) (send/back r))))))))))
(semaphore-post sema)))) (semaphore-post sema))))
;; make-servlet-exit-handler: servlet-instance -> alpha -> void ;; make-servlet-exit-handler: servlet-instance -> alpha -> void
@ -610,37 +607,43 @@
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************
;; Paul's ugly loading code: ;; Paul's ugly loading code:
(define-struct cache-entry (servlet namespace))
;; cached-load : str -> script ;; cached-load : str -> script, namespace
;; timestamps are no longer checked for performance. The cache must be explicitly ;; timestamps are no longer checked for performance. The cache must be explicitly
;; refreshed (see dispatch). ;; refreshed (see dispatch).
(define (cached-load name) (define (cached-load name)
(let ([e
(call-with-semaphore config:scripts-lock (call-with-semaphore config:scripts-lock
(lambda () (lambda ()
(hash-table-get (unbox config:scripts) (hash-table-get (unbox config:scripts)
name name
(lambda () (reload-servlet-script name)))))) (lambda () (reload-servlet-script name)))))])
(values (cache-entry-servlet e)
(cache-entry-namespace e))))
;; exn:i/o:filesystem:servlet-not-found = ;; exn:i/o:filesystem:servlet-not-found =
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym) ;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
(define-struct (exn:fail:filesystem:exists:servlet (define-struct (exn:fail:filesystem:exists:servlet
exn:fail:filesystem:exists) ()) exn:fail:filesystem:exists) ())
;; reload-servlet-script : str -> script ;; reload-servlet-script : str -> cache-entry
;; The servlet is not cached in the servlet-table, so reload it from the filesystem. ;; The servlet is not cached in the servlet-table, so reload it from the filesystem.
(define (reload-servlet-script servlet-filename) (define (reload-servlet-script servlet-filename)
(cond (cond
[(load-servlet/path servlet-filename) [(load-servlet/path servlet-filename)
=> (lambda (svlt) => (lambda (entry)
; This is only called from cached-load, so config:scripts is locked ; This is only called from cached-load, so config:scripts is locked
(hash-table-put! (unbox config:scripts) servlet-filename svlt) (hash-table-put! (unbox config:scripts)
svlt)] servlet-filename
entry)
entry)]
[else [else
(raise (make-exn:fail:filesystem:exists:servlet (raise (make-exn:fail:filesystem:exists:servlet
(string->immutable-string (format "Couldn't find ~a" servlet-filename)) (string->immutable-string (format "Couldn't find ~a" servlet-filename))
(current-continuation-marks) ))])) (current-continuation-marks) ))]))
;; load-servlet/path path -> (union #f signed-unit) ;; load-servlet/path path -> (union #f cache-entry)
;; given a string path to a filename attempt to load a servlet ;; given a string path to a filename attempt to load a servlet
;; A servlet-file will contain either ;; A servlet-file will contain either
;;;; A signed-unit-servlet ;;;; A signed-unit-servlet
@ -653,7 +656,8 @@
(cond (cond
;; signed-unit servlet ;; signed-unit servlet
; MF: I'd also like to test that s has the correct import signature. ; MF: I'd also like to test that s has the correct import signature.
[(unit/sig? s) s] [(unit/sig? s)
(make-cache-entry s (current-namespace))]
; FIX - reason about exceptions from dynamic require (catch and report if not already) ; FIX - reason about exceptions from dynamic require (catch and report if not already)
;; module servlet ;; module servlet
[(void? s) [(void? s)
@ -664,15 +668,18 @@
[(v1) [(v1)
(let ([timeout (dynamic-require module-name 'timeout)] (let ([timeout (dynamic-require module-name 'timeout)]
[start (dynamic-require module-name 'start)]) [start (dynamic-require module-name 'start)])
(make-cache-entry
(unit/sig () (unit/sig ()
(import servlet^) (import servlet^)
(adjust-timeout! timeout) (adjust-timeout! timeout)
(start initial-request)))] (start initial-request))
(current-namespace)))]
[(typed-model-split-store-0) [(typed-model-split-store-0)
(let ([constrained (dynamic-require module-name 'type)] (let ([constrained (dynamic-require module-name 'type)]
[the-servlet (dynamic-require module-name 'servlet)]) [the-servlet (dynamic-require module-name 'servlet)])
; more here - check constraints ; more here - check constraints
the-servlet)] (make-cache-entry the-servlet
(current-namespace)))]
[else [else
(raise (format "unknown servlet version ~e" version))])))] (raise (format "unknown servlet version ~e" version))])))]
;; response ;; response
@ -681,8 +688,8 @@
(begin (begin
(set! go (lambda () (load/use-compiled a-path))) (set! go (lambda () (load/use-compiled a-path)))
s))]) s))])
(unit/sig () (import servlet^) (go)))] (make-cache-entry (unit/sig () (import servlet^) (go))
(current-namespace)))]
[else [else
(raise (format "Loading ~e produced ~n~e~n instead of a servlet." a-path s))])))) (raise (format "Loading ~e produced ~n~e~n instead of a servlet." a-path s))]))))
))) )))