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
(paths-servlet (host-paths host-info))
(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)]
[current-custodian servlet-custodian]
[current-servlet-instance inst]
[exit-handler servlet-exit-handler])
(let (;; timer thread must be within the dynamic extent of
(let-values (;; timer thread must be within the dynamic extent of
;; servlet custodian
[time-bomb (start-timer (timeouts-default-servlet
[(time-bomb) (start-timer (timeouts-default-servlet
(host-timeouts host-info))
(lambda ()
(servlet-exit-handler #f)))]
;; any resources (e.g. threads) created when the
;; servlet is loaded should be within the dynamic
;; 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)
(with-handlers ([(lambda (x) #t)
(make-servlet-exception-handler inst
@ -500,7 +497,7 @@
;; response.
(let ([r (invoke-unit/sig servlet-program servlet^)])
(when (response? r)
(send/back r)))))))))
(send/back r))))))))))
(semaphore-post sema))))
;; make-servlet-exit-handler: servlet-instance -> alpha -> void
@ -610,37 +607,43 @@
;; ************************************************************
;; ************************************************************
;; 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
;; refreshed (see dispatch).
(define (cached-load name)
(let ([e
(call-with-semaphore config:scripts-lock
(lambda ()
(hash-table-get (unbox config:scripts)
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 =
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
(define-struct (exn:fail:filesystem:exists:servlet
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.
(define (reload-servlet-script servlet-filename)
(cond
[(load-servlet/path servlet-filename)
=> (lambda (svlt)
=> (lambda (entry)
; This is only called from cached-load, so config:scripts is locked
(hash-table-put! (unbox config:scripts) servlet-filename svlt)
svlt)]
(hash-table-put! (unbox config:scripts)
servlet-filename
entry)
entry)]
[else
(raise (make-exn:fail:filesystem:exists:servlet
(string->immutable-string (format "Couldn't find ~a" servlet-filename))
(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
;; A servlet-file will contain either
;;;; A signed-unit-servlet
@ -653,7 +656,8 @@
(cond
;; signed-unit servlet
; 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)
;; module servlet
[(void? s)
@ -664,15 +668,18 @@
[(v1)
(let ([timeout (dynamic-require module-name 'timeout)]
[start (dynamic-require module-name 'start)])
(make-cache-entry
(unit/sig ()
(import servlet^)
(adjust-timeout! timeout)
(start initial-request)))]
(start initial-request))
(current-namespace)))]
[(typed-model-split-store-0)
(let ([constrained (dynamic-require module-name 'type)]
[the-servlet (dynamic-require module-name 'servlet)])
; more here - check constraints
the-servlet)]
(make-cache-entry the-servlet
(current-namespace)))]
[else
(raise (format "unknown servlet version ~e" version))])))]
;; response
@ -681,8 +688,8 @@
(begin
(set! go (lambda () (load/use-compiled a-path)))
s))])
(unit/sig () (import servlet^) (go)))]
(make-cache-entry (unit/sig () (import servlet^) (go))
(current-namespace)))]
[else
(raise (format "Loading ~e produced ~n~e~n instead of a servlet." a-path s))]))))
)))