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

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

@ -14,7 +14,7 @@
(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
@ -117,7 +117,7 @@
(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)
@ -136,46 +136,46 @@
[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)
@ -196,16 +196,16 @@
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)]))
;; **************************************** ;; ****************************************
;; **************************************** ;; ****************************************
@ -318,21 +318,21 @@
[(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))
@ -393,11 +393,11 @@
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
@ -406,7 +406,7 @@
(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)
@ -422,11 +422,11 @@
(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,7 +436,7 @@
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)])
@ -446,7 +446,7 @@
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)))]
@ -536,10 +536,10 @@
(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
@ -562,31 +562,33 @@
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)))))
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************
@ -621,7 +623,7 @@
(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