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

Indenting and bug 7544

Browse Source 
svn: r627
This commit is contained in:
Jay McCarthy 2005-08-22 12:21:18 +00:00
parent 19b1ddfa72
commit 0987bcd1dd
1 changed files with 165 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,18 +14,18 @@
(lib "string.ss") (lib "string.ss")
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "xml.ss" "xml") (lib "xml.ss" "xml")
) (lib "list.ss"))
(provide web-server@) (provide web-server@)
(define myprint (define myprint
(lambda args (lambda args
(apply fprintf (cons (current-error-port) args)))) (apply fprintf (cons (current-error-port) args))))
;; **************************************** ;; ****************************************
;; stick this auxilliary outside the unit so ;; stick this auxilliary outside the unit so
;; I can get at it with require/expose ;; I can get at it with require/expose
;; get-host : Url (listof (cons Symbol String)) -> String ;; get-host : Url (listof (cons Symbol String)) -> String
;; host names are case insesitive---Internet RFC 1034 ;; host names are case insesitive---Internet RFC 1034
(define DEFAULT-HOST-NAME "<none>") (define DEFAULT-HOST-NAME "<none>")
@ -40,20 +40,20 @@
=> =>
(lambda (h) (lower! (bytes->string/utf-8 (cdr h))))] (lambda (h) (lower! (bytes->string/utf-8 (cdr h))))]
[else DEFAULT-HOST-NAME]))) [else DEFAULT-HOST-NAME])))
;; **************************************** ;; ****************************************
(define web-server@ (define web-server@
(unit/sig web-server^ (unit/sig web-server^
(import net:tcp^ (config : web-config^)) (import net:tcp^ (config : web-config^))
(define current-server-custodian (make-parameter #f)) (define current-server-custodian (make-parameter #f))
;; make-servlet-custodian: -> custodian ;; make-servlet-custodian: -> custodian
;; create a custodian for the dynamic extent of a servlet continuation ;; create a custodian for the dynamic extent of a servlet continuation
(define (make-servlet-custodian) (define (make-servlet-custodian)
(make-custodian (current-server-custodian))) (make-custodian (current-server-custodian)))
;; serve: -> -> void ;; serve: -> -> void
;; start the server and return a thunk to shut it down ;; start the server and return a thunk to shut it down
(define (serve) (define (serve)
@ -77,7 +77,7 @@
(server-loop get-ports))))) (server-loop get-ports)))))
(lambda () (lambda ()
(custodian-shutdown-all the-server-custodian)))) (custodian-shutdown-all the-server-custodian))))
;; server-loop: (-> i-port o-port) -> void ;; server-loop: (-> i-port o-port) -> void
;; start a thread to handle each incoming connection ;; start a thread to handle each incoming connection
(define (server-loop get-ports) (define (server-loop get-ports)
@ -91,7 +91,7 @@
(new-connection config:initial-connection-timeout (new-connection config:initial-connection-timeout
ip op (current-custodian) #f)))))) ip op (current-custodian) #f))))))
(loop)))) (loop))))
;; serve-ports : input-port output-port -> void ;; serve-ports : input-port output-port -> void
;; returns immediately, spawning a thread to handle ;; returns immediately, spawning a thread to handle
;; the connection ;; the connection
@ -108,7 +108,7 @@
(serve-connection (serve-connection
(new-connection config:initial-connection-timeout (new-connection config:initial-connection-timeout
ip op connection-cust #f))))))) ip op connection-cust #f)))))))
;; serve-connection: connection -> void ;; serve-connection: connection -> void
;; respond to all requests on this connection ;; respond to all requests on this connection
(define (serve-connection conn) (define (serve-connection conn)
@ -117,16 +117,16 @@
(let* ([host (get-host (request-uri req) (request-headers req))] (let* ([host (get-host (request-uri req) (request-headers req))]
[host-conf (config:virtual-hosts host)]) [host-conf (config:virtual-hosts host)])
((host-log-message host-conf) (request-host-ip req) ((host-log-message host-conf) (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)
(set-connection-close?! conn close?) (set-connection-close?! conn close?)
(dispatch conn req host-conf) (dispatch conn req host-conf)
(adjust-connection-timeout! conn config:initial-connection-timeout) (adjust-connection-timeout! conn config:initial-connection-timeout)
(cond (cond
[close? (kill-connection! conn)] [close? (kill-connection! conn)]
[else (connection-loop)]))))) [else (connection-loop)])))))
;; dispatch: connection request host -> void ;; dispatch: connection request host -> void
;; 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
@ -136,91 +136,91 @@
[method (request-method req)] [method (request-method req)]
[path (translate-escapes (url-path->string (url-path uri)))]) [path (translate-escapes (url-path->string (url-path uri)))])
(cond (cond
[(access-denied? method path (request-headers req) host-info [(access-denied? method path (request-headers req) host-info
config:access) config:access)
=> (lambda (realm) => (lambda (realm)
(adjust-connection-timeout! conn (timeouts-password (adjust-connection-timeout! conn (timeouts-password
(host-timeouts host-info))) (host-timeouts host-info)))
(request-authentication conn method uri host-info realm))] (request-authentication conn method uri host-info realm))]
[(conf-prefix? path) [(conf-prefix? path)
(cond (cond
[(string=? "/conf/refresh-servlets" path) [(string=? "/conf/refresh-servlets" path)
;; more here - this is broken - only out of date or specifically mentioned ;; more here - this is broken - only out of date or specifically mentioned
;; scripts should be flushed. This destroys persistent state! ;; scripts should be flushed. This destroys persistent state!
(call-with-semaphore config:scripts-lock (call-with-semaphore config:scripts-lock
(lambda () (lambda ()
(set-box! config:scripts (make-hash-table 'equal)))) (set-box! config:scripts (make-hash-table 'equal))))
(output-response/method (output-response/method
conn conn
((responders-servlets-refreshed (host-responders host-info))) ((responders-servlets-refreshed (host-responders host-info)))
method)] method)]
[(string=? "/conf/refresh-passwords" path) [(string=? "/conf/refresh-passwords" path)
;; more here - send a nice error page ;; more here - send a nice error page
(hash-table-put! config:access host-info (hash-table-put! config:access host-info
(read-passwords host-info)) (read-passwords host-info))
(output-response/method (output-response/method
conn conn
((responders-passwords-refreshed (host-responders host-info))) ((responders-passwords-refreshed (host-responders host-info)))
method) method)
] ]
[else [else
(output-response/method (output-response/method
conn conn
((responders-file-not-found (host-responders host-info)) uri) ((responders-file-not-found (host-responders host-info)) uri)
method)])] method)])]
[(servlet-bin? path) [(servlet-bin? path)
(adjust-connection-timeout! (adjust-connection-timeout!
conn conn
(timeouts-servlet-connection (host-timeouts host-info))) (timeouts-servlet-connection (host-timeouts host-info)))
;; more here - make timeouts proportional to size of bindings ;; more here - make timeouts proportional to size of bindings
(servlet-content-producer conn req host-info)] (servlet-content-producer conn req host-info)]
[else (file-content-producer conn req host-info)]))) [else (file-content-producer conn req host-info)])))
;; conf-prefix?: string -> (union (listof string) #f) ;; conf-prefix?: string -> (union (listof string) #f)
;; does the path string have "/conf/" as a prefix? ;; does the path string have "/conf/" as a prefix?
(define conf-prefix? (define conf-prefix?
(let ([conf-re (regexp "^/conf/.*")]) (let ([conf-re (regexp "^/conf/.*")])
(lambda (str) (lambda (str)
(regexp-match conf-re str)))) (regexp-match conf-re str))))
(define servlet-bin? (define servlet-bin?
(let ([svt-bin-re (regexp "^/servlets/.*")]) (let ([svt-bin-re (regexp "^/servlets/.*")])
(lambda (str) (lambda (str)
(regexp-match svt-bin-re str)))) (regexp-match svt-bin-re str))))
;; ripped this off from url-unit.ss ;; ripped this off from url-unit.ss
(define (url-path->string strs) (define (url-path->string strs)
(apply (apply
string-append string-append
(let loop ([strs strs]) (let loop ([strs strs])
(cond (cond
[(null? strs) '()] [(null? strs) '()]
[else (list* "/" [else (list* "/"
(maybe-join-params (car strs)) (maybe-join-params (car strs))
(loop (cdr strs)))])))) (loop (cdr strs)))]))))
;; needs to unquote things! ;; needs to unquote things!
(define (maybe-join-params s) (define (maybe-join-params s)
(cond (cond
[(string? s) s] [(string? s) s]
[else (path/param-path s)])) [else (path/param-path s)]))
;; **************************************** ;; ****************************************
;; **************************************** ;; ****************************************
;; ACCESS CONTROL ;; ACCESS CONTROL
;; pass-entry = (make-pass-entry str regexp (list sym str)) ;; pass-entry = (make-pass-entry str regexp (list sym str))
(define-struct pass-entry (domain pattern users)) (define-struct pass-entry (domain pattern users))
;; access-denied? : Method string x-table host Access-table -> (+ false str) ;; access-denied? : Method string x-table host Access-table -> (+ false str)
;; the return string is the prompt for authentication ;; the return string is the prompt for authentication
(define (access-denied? method uri-str headers host-info access-table) (define (access-denied? method uri-str headers host-info access-table)
;; denied?: str sym str -> (U str #f) ;; denied?: str sym str -> (U str #f)
;; a function to authenticate the user ;; a function to authenticate the user
(let ([denied? (let ([denied?
;; GregP lookup the authenticator function, if you can't find it, then try to load the ;; GregP lookup the authenticator function, if you can't find it, then try to load the
;; passwords file for this host. ;; passwords file for this host.
(hash-table-get (hash-table-get
@ -234,9 +234,9 @@
(if user-pass (if user-pass
(denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass)) (denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass))
(denied? uri-str fake-user ""))))) (denied? uri-str fake-user "")))))
(define-struct (exn:password-file exn) ()) (define-struct (exn:password-file exn) ())
;; : host -> (str sym str -> (U str #f)) ;; : host -> (str sym str -> (U str #f))
;; to produce a function that checks if a given url path is accessible by a given user with a given ;; to produce a function that checks if a given url path is accessible by a given user with a given
;; password. If not, the produced function returns a string, prompting for the password. ;; password. If not, the produced function returns a string, prompting for the password.
@ -254,7 +254,7 @@
(raise "malformed passwords")) (raise "malformed passwords"))
(map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x))) (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x)))
raw))]) raw))])
;; string symbol bytes -> (union #f string) ;; string symbol bytes -> (union #f string)
(lambda (request-path user-name password) (lambda (request-path user-name password)
(ormap (lambda (x) (ormap (lambda (x)
@ -268,11 +268,11 @@
(pass-entry-domain x))))) (pass-entry-domain x)))))
passwords))) passwords)))
(lambda (req user pass) #f))))) (lambda (req user pass) #f)))))
(define fake-user (gensym)) (define fake-user (gensym))
;; password-list? : TST -> bool ;; password-list? : TST -> bool
;; Note: andmap fails for dotted pairs at end. ;; Note: andmap fails for dotted pairs at end.
;; This is okay, since #f ends up raising a caught exception anyway. ;; This is okay, since #f ends up raising a caught exception anyway.
(define (password-list? passwords) (define (password-list? passwords)
@ -286,7 +286,7 @@
(symbol? (car x)) (string? (cadr x)))) (symbol? (car x)) (string? (cadr x))))
(cddr domain)))) (cddr domain))))
passwords))) passwords)))
;; request-authentication : connection Method URL iport oport host str bool -> bool ;; request-authentication : connection Method URL iport oport host str bool -> bool
;; GregP: at first look, it seems that this gets called when the user ;; GregP: at first look, it seems that this gets called when the user
;; has supplied bad authentication credentials. ;; has supplied bad authentication credentials.
@ -297,16 +297,16 @@
uri `(WWW-Authenticate . ,(string-append " Basic uri `(WWW-Authenticate . ,(string-append " Basic
realm=\"" realm "\""))) realm=\"" realm "\"")))
method)) method))
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************
;; SERVING FILES ;; SERVING FILES
;; file-content-producer: connection request host -> void ;; file-content-producer: connection request host -> void
(define (file-content-producer conn req host-info) (define (file-content-producer conn req host-info)
(serve-file conn (request-method req) (request-uri req) host-info)) (serve-file conn (request-method req) (request-uri req) host-info))
;; serve-file : connection symbol uri host -> void ;; serve-file : connection symbol uri host -> void
;; to find the file, including searching for implicit index files, and serve it out ;; to find the file, including searching for implicit index files, and serve it out
(define (serve-file conn method uri host-info) (define (serve-file conn method uri host-info)
@ -318,32 +318,32 @@
[(directory-exists? path) [(directory-exists? path)
(let loop ([dir-defaults (host-indices host-info)]) (let loop ([dir-defaults (host-indices host-info)])
(cond (cond
[(pair? dir-defaults) [(pair? dir-defaults)
(let ([full-name (build-path path (car dir-defaults))]) (let ([full-name (build-path path (car dir-defaults))])
(if (file-exists? full-name) (if (file-exists? full-name)
(cond (cond
[(looks-like-directory? (url-path->string (url-path uri))) [(looks-like-directory? (url-path->string (url-path uri)))
(output-file conn full-name method (get-mime-type full-name))] (output-file conn full-name method (get-mime-type full-name))]
[else [else
(output-slash-message conn method (url-path->string (url-path uri)))]) (output-slash-message conn method (url-path->string (url-path uri)))])
(loop (cdr dir-defaults))))] (loop (cdr dir-defaults))))]
[else [else
(output-response/method (output-response/method
conn conn
((responders-file-not-found ((responders-file-not-found
(host-responders host-info)) uri) (host-responders host-info)) uri)
method)]))] method)]))]
[else [else
(output-response/method (output-response/method
conn ((responders-file-not-found (host-responders host-info)) conn ((responders-file-not-found (host-responders host-info))
uri) uri)
method)]))) method)])))
;; looks-like-directory : str -> bool ;; looks-like-directory : str -> bool
;; to determine if is url style path looks like it refers to a directory ;; to determine if is url style path looks like it refers to a directory
(define (looks-like-directory? path) (define (looks-like-directory? path)
(eq? #\/ (string-ref path (sub1 (string-length path))))) (eq? #\/ (string-ref path (sub1 (string-length path)))))
;; output-slash-message: connection symbol string -> void ;; output-slash-message: connection symbol string -> void
;; basically this is just a special error response ;; basically this is just a special error response
(define (output-slash-message conn method url-path-str) (define (output-slash-message conn method url-path-str)
@ -364,18 +364,18 @@
url-path-str "/")]) url-path-str "/")])
"this url") " instead.")))))) "this url") " instead."))))))
method)) method))
;; xml->string: xml -> string ;; xml->string: xml -> string
(define (xml->string some-xml) (define (xml->string some-xml)
(let ([o-port (open-output-string)]) (let ([o-port (open-output-string)])
(write-xml/content some-xml o-port) (write-xml/content some-xml o-port)
(get-output-string o-port))) (get-output-string o-port)))
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************
;; SERVING SERVLETS ;; SERVING SERVLETS
;; servlet-content-producer: connection request host -> void ;; servlet-content-producer: connection request host -> void
(define (servlet-content-producer conn req host-info) (define (servlet-content-producer conn req host-info)
(let ([meth (request-method req)]) (let ([meth (request-method req)])
@ -391,14 +391,14 @@
req req
(read-bindings/handled conn meth uri (request-headers req) (read-bindings/handled conn meth uri (request-headers req)
host-info)) host-info))
(cond (cond
[(continuation-url? uri) [(continuation-url? uri)
=> (lambda (k-ref) => (lambda (k-ref)
(invoke-servlet-continuation conn req k-ref host-info))] (invoke-servlet-continuation conn req k-ref host-info))]
[else [else
(servlet-content-producer/path conn req host-info uri)]))))) (servlet-content-producer/path conn req host-info uri)])))))
;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string)) ;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
;; read the bindings and handle any exceptions ;; read the bindings and handle any exceptions
(define (read-bindings/handled conn meth uri headers host-info) (define (read-bindings/handled conn meth uri headers host-info)
@ -406,27 +406,27 @@
(output-response/method (output-response/method
conn conn
;((responders-protocol (host-responders host-info)) ;((responders-protocol (host-responders host-info))
; (exn-message e)) ; (exn-message e))
((responders-servlet-loading (host-responders ((responders-servlet-loading (host-responders
host-info)) host-info))
uri e) uri e)
meth) meth)
'())]) '())])
(read-bindings conn meth uri headers))) (read-bindings conn meth uri headers)))
;; servlet-content-producer/path: connection request host url -> void ;; servlet-content-producer/path: connection request host url -> void
;; This is not a continuation url so the loading behavior is determined ;; This is not a continuation url so the loading behavior is determined
;; by the url path. Build the servlet path and then load the servlet ;; by the url path. Build the servlet path and then load the servlet
(define (servlet-content-producer/path conn req host-info uri) (define (servlet-content-producer/path conn req host-info uri)
(with-handlers (;; couldn't find the servlet (with-handlers (;; couldn't find the servlet
[exn:fail:filesystem:exists:servlet? [exn:fail:filesystem:exists:servlet?
(lambda (the-exn) (lambda (the-exn)
(output-response/method (output-response/method
conn conn
((responders-file-not-found (host-responders ((responders-file-not-found (host-responders
host-info)) host-info))
(request-uri req)) (request-uri req))
(request-method req)))] (request-method req)))]
;; servlet won't load (e.g. syntax error) ;; servlet won't load (e.g. syntax error)
@ -436,9 +436,9 @@
conn conn
((responders-servlet-loading (host-responders ((responders-servlet-loading (host-responders
host-info)) uri host-info)) uri
the-exn) the-exn)
(request-method req)))]) (request-method req)))])
(let ([sema (make-semaphore 0)]) (let ([sema (make-semaphore 0)])
(let/cc suspend (let/cc suspend
(let* ([servlet-custodian (make-servlet-custodian)] (let* ([servlet-custodian (make-servlet-custodian)]
@ -446,19 +446,19 @@
config:instances servlet-custodian config:instances servlet-custodian
(make-execution-context (make-execution-context
conn req (lambda () (suspend #t))) conn req (lambda () (suspend #t)))
sema)] sema)]
[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 (;; 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
@ -469,18 +469,18 @@
;; 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 (cached-load real-servlet-path)])
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(make-servlet-exception-handler inst (make-servlet-exception-handler inst
host-info)]) host-info)])
;; The following bindings need to be in scope for the ;; The following bindings need to be in scope for the
;; invoke-unit/sig ;; invoke-unit/sig
(let ([adjust-timeout! (let ([adjust-timeout!
(lambda (secs) (reset-timer time-bomb secs))] (lambda (secs) (reset-timer time-bomb secs))]
[initial-request req]) [initial-request req])
;; Two possibilities: ;; Two possibilities:
;; - module servlet. start : Request -> Void handles ;; - module servlet. start : Request -> Void handles
;; output-response via send/finish, etc. ;; output-response via send/finish, etc.
@ -493,7 +493,7 @@
(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
;; exit handler for a servlet ;; exit handler for a servlet
(define (make-servlet-exit-handler inst) (define (make-servlet-exit-handler inst)
@ -503,7 +503,7 @@
(execution-context-connection (execution-context-connection
(servlet-instance-context inst))) (servlet-instance-context inst)))
(custodian-shutdown-all (servlet-instance-custodian inst)))) (custodian-shutdown-all (servlet-instance-custodian inst))))
;; make-servlet-exception-handler: host -> exn -> void ;; make-servlet-exception-handler: host -> exn -> void
;; This exception handler traps all unhandled servlet exceptions ;; This exception handler traps all unhandled servlet exceptions
;; * Must occur within the dynamic extent of the servlet ;; * Must occur within the dynamic extent of the servlet
@ -529,19 +529,19 @@
(execution-context-connection ctxt) (execution-context-connection ctxt)
resp (request-method req)) resp (request-method req))
((execution-context-suspend ctxt))))) ((execution-context-suspend ctxt)))))
;; path -> path ;; path -> path
;; The actual servlet's parent directory. ;; The actual servlet's parent directory.
(define (get-servlet-base-dir servlet-path) (define (get-servlet-base-dir servlet-path)
(let loop ((path servlet-path)) (let loop ((path servlet-path))
(let-values ([(base name must-be-dir?) (split-path path)]) (let-values ([(base name must-be-dir?) (split-path path)])
(if must-be-dir? (if must-be-dir?
(or (and (directory-exists? path) path) (or (and (directory-exists? path) path)
(loop base)) (loop base))
(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
@ -562,36 +562,38 @@
host-info)) host-info))
(request-uri req)) (request-uri req))
(request-method req)))]) (request-method req)))])
(let* ([inst (hash-table-get config:instances (car k-ref) (let* ([inst
(lambda () (hash-table-get config:instances (first k-ref)
(raise (lambda ()
(make-exn:servlet-instance (raise
"" (current-continuation-marks)))))] (make-exn:servlet-instance
"" (current-continuation-marks)))))]
[k-table [k-table
(servlet-instance-k-table inst)]) (servlet-instance-k-table inst)])
(let/cc suspend (let/cc suspend
(set-servlet-instance-context! (set-servlet-instance-context!
inst inst
(make-execution-context (make-execution-context
conn req (lambda () (suspend #t)))) conn req (lambda () (suspend #t))))
(semaphore-wait (servlet-instance-mutex inst)) (let ([k*salt
(let ((k*salt (call-with-semaphore
(hash-table-get k-table (cadr k-ref) (servlet-instance-mutex inst)
(lambda () (lambda ()
(raise (hash-table-get k-table (second k-ref)
(make-exn:servlet-continuation (lambda ()
"" (current-continuation-marks))))))) (raise
(if (= (cadr k*salt) (caddr k-ref)) (make-exn:servlet-continuation
((car k*salt) req) "" (current-continuation-marks)))))))])
(if (= (second k*salt) (third k-ref))
((first k*salt) req)
(raise (raise
(make-exn:servlet-continuation (make-exn:servlet-continuation
"" (current-continuation-marks)))))) "" (current-continuation-marks)))))))))
(semaphore-post (servlet-instance-mutex inst)))))
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************
;; Paul's ugly loading code: ;; Paul's ugly loading code:
;; cached-load : str -> script ;; cached-load : str -> script
;; 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).
@ -601,12 +603,12 @@
(hash-table-get (unbox config:scripts) (hash-table-get (unbox config:scripts)
name name
(lambda () (reload-servlet-script name)))))) (lambda () (reload-servlet-script name))))))
;; 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 -> script
;; 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)
@ -620,8 +622,8 @@
(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 signed-unit)
;; 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
@ -665,5 +667,5 @@
(unit/sig () (import servlet^) (go)))] (unit/sig () (import servlet^) (go)))]
[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))]))))
))) )))