Indenting and bug 7544
svn: r627
This commit is contained in:
Jay McCarthy
parent
19b1ddfa72
commit
0987bcd1dd
|
|
@ -14,7 +14,7 @@
|
|||
(lib "string.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "xml.ss" "xml")
|
||||
)
|
||||
(lib "list.ss"))
|
||||
(provide web-server@)
|
||||
|
||||
(define myprint
|
||||
|
|
@ -117,7 +117,7 @@
|
|||
(let* ([host (get-host (request-uri req) (request-headers req))]
|
||||
[host-conf (config:virtual-hosts host)])
|
||||
((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?)
|
||||
(dispatch conn req host-conf)
|
||||
(adjust-connection-timeout! conn config:initial-connection-timeout)
|
||||
|
|
@ -136,46 +136,46 @@
|
|||
[method (request-method req)]
|
||||
[path (translate-escapes (url-path->string (url-path uri)))])
|
||||
(cond
|
||||
[(access-denied? method path (request-headers req) host-info
|
||||
config:access)
|
||||
=> (lambda (realm)
|
||||
(adjust-connection-timeout! conn (timeouts-password
|
||||
(host-timeouts host-info)))
|
||||
(request-authentication conn method uri host-info realm))]
|
||||
[(conf-prefix? path)
|
||||
(cond
|
||||
[(string=? "/conf/refresh-servlets" path)
|
||||
;; more here - this is broken - only out of date or specifically mentioned
|
||||
;; scripts should be flushed. This destroys persistent state!
|
||||
(call-with-semaphore config:scripts-lock
|
||||
(lambda ()
|
||||
(set-box! config:scripts (make-hash-table 'equal))))
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-servlets-refreshed (host-responders host-info)))
|
||||
method)]
|
||||
[(string=? "/conf/refresh-passwords" path)
|
||||
;; more here - send a nice error page
|
||||
(hash-table-put! config:access host-info
|
||||
(read-passwords host-info))
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-passwords-refreshed (host-responders host-info)))
|
||||
method)
|
||||
]
|
||||
[else
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders host-info)) uri)
|
||||
method)])]
|
||||
[(servlet-bin? path)
|
||||
(adjust-connection-timeout!
|
||||
conn
|
||||
(timeouts-servlet-connection (host-timeouts host-info)))
|
||||
;; more here - make timeouts proportional to size of bindings
|
||||
(servlet-content-producer conn req host-info)]
|
||||
[(access-denied? method path (request-headers req) host-info
|
||||
config:access)
|
||||
=> (lambda (realm)
|
||||
(adjust-connection-timeout! conn (timeouts-password
|
||||
(host-timeouts host-info)))
|
||||
(request-authentication conn method uri host-info realm))]
|
||||
[(conf-prefix? path)
|
||||
(cond
|
||||
[(string=? "/conf/refresh-servlets" path)
|
||||
;; more here - this is broken - only out of date or specifically mentioned
|
||||
;; scripts should be flushed. This destroys persistent state!
|
||||
(call-with-semaphore config:scripts-lock
|
||||
(lambda ()
|
||||
(set-box! config:scripts (make-hash-table 'equal))))
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-servlets-refreshed (host-responders host-info)))
|
||||
method)]
|
||||
[(string=? "/conf/refresh-passwords" path)
|
||||
;; more here - send a nice error page
|
||||
(hash-table-put! config:access host-info
|
||||
(read-passwords host-info))
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-passwords-refreshed (host-responders host-info)))
|
||||
method)
|
||||
]
|
||||
[else
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders host-info)) uri)
|
||||
method)])]
|
||||
[(servlet-bin? path)
|
||||
(adjust-connection-timeout!
|
||||
conn
|
||||
(timeouts-servlet-connection (host-timeouts host-info)))
|
||||
;; more here - make timeouts proportional to size of bindings
|
||||
(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)
|
||||
|
|
@ -196,16 +196,16 @@
|
|||
string-append
|
||||
(let loop ([strs strs])
|
||||
(cond
|
||||
[(null? strs) '()]
|
||||
[else (list* "/"
|
||||
(maybe-join-params (car strs))
|
||||
(loop (cdr strs)))]))))
|
||||
[(null? strs) '()]
|
||||
[else (list* "/"
|
||||
(maybe-join-params (car strs))
|
||||
(loop (cdr strs)))]))))
|
||||
|
||||
;; needs to unquote things!
|
||||
(define (maybe-join-params s)
|
||||
(cond
|
||||
[(string? s) s]
|
||||
[else (path/param-path s)]))
|
||||
[(string? s) s]
|
||||
[else (path/param-path s)]))
|
||||
|
||||
;; ****************************************
|
||||
;; ****************************************
|
||||
|
|
@ -318,21 +318,21 @@
|
|||
[(directory-exists? path)
|
||||
(let loop ([dir-defaults (host-indices host-info)])
|
||||
(cond
|
||||
[(pair? dir-defaults)
|
||||
(let ([full-name (build-path path (car dir-defaults))])
|
||||
(if (file-exists? full-name)
|
||||
(cond
|
||||
[(looks-like-directory? (url-path->string (url-path uri)))
|
||||
(output-file conn full-name method (get-mime-type full-name))]
|
||||
[else
|
||||
(output-slash-message conn method (url-path->string (url-path uri)))])
|
||||
(loop (cdr dir-defaults))))]
|
||||
[else
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found
|
||||
(host-responders host-info)) uri)
|
||||
method)]))]
|
||||
[(pair? dir-defaults)
|
||||
(let ([full-name (build-path path (car dir-defaults))])
|
||||
(if (file-exists? full-name)
|
||||
(cond
|
||||
[(looks-like-directory? (url-path->string (url-path uri)))
|
||||
(output-file conn full-name method (get-mime-type full-name))]
|
||||
[else
|
||||
(output-slash-message conn method (url-path->string (url-path uri)))])
|
||||
(loop (cdr dir-defaults))))]
|
||||
[else
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found
|
||||
(host-responders host-info)) uri)
|
||||
method)]))]
|
||||
[else
|
||||
(output-response/method
|
||||
conn ((responders-file-not-found (host-responders host-info))
|
||||
|
|
@ -393,11 +393,11 @@
|
|||
host-info))
|
||||
|
||||
(cond
|
||||
[(continuation-url? uri)
|
||||
=> (lambda (k-ref)
|
||||
(invoke-servlet-continuation conn req k-ref host-info))]
|
||||
[else
|
||||
(servlet-content-producer/path conn req host-info uri)])))))
|
||||
[(continuation-url? uri)
|
||||
=> (lambda (k-ref)
|
||||
(invoke-servlet-continuation conn req k-ref host-info))]
|
||||
[else
|
||||
(servlet-content-producer/path conn req host-info uri)])))))
|
||||
|
||||
;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
|
||||
;; read the bindings and handle any exceptions
|
||||
|
|
@ -406,7 +406,7 @@
|
|||
(output-response/method
|
||||
conn
|
||||
;((responders-protocol (host-responders host-info))
|
||||
; (exn-message e))
|
||||
; (exn-message e))
|
||||
((responders-servlet-loading (host-responders
|
||||
host-info))
|
||||
uri e)
|
||||
|
|
@ -422,11 +422,11 @@
|
|||
(define (servlet-content-producer/path conn req host-info uri)
|
||||
(with-handlers (;; couldn't find the servlet
|
||||
[exn:fail:filesystem:exists:servlet?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))]
|
||||
;; servlet won't load (e.g. syntax error)
|
||||
|
|
@ -436,7 +436,7 @@
|
|||
conn
|
||||
((responders-servlet-loading (host-responders
|
||||
host-info)) uri
|
||||
the-exn)
|
||||
the-exn)
|
||||
(request-method req)))])
|
||||
|
||||
(let ([sema (make-semaphore 0)])
|
||||
|
|
@ -446,7 +446,7 @@
|
|||
config:instances servlet-custodian
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t)))
|
||||
sema)]
|
||||
sema)]
|
||||
[real-servlet-path (url-path->path
|
||||
(paths-servlet (host-paths host-info))
|
||||
(url-path->string (url-path uri)))]
|
||||
|
|
@ -536,10 +536,10 @@
|
|||
(let loop ((path servlet-path))
|
||||
(let-values ([(base name must-be-dir?) (split-path path)])
|
||||
(if must-be-dir?
|
||||
(or (and (directory-exists? path) path)
|
||||
(loop base))
|
||||
(or (and (directory-exists? base) base)
|
||||
(loop base))))))
|
||||
(or (and (directory-exists? path) path)
|
||||
(loop base))
|
||||
(or (and (directory-exists? base) base)
|
||||
(loop base))))))
|
||||
|
||||
|
||||
;; invoke-servlet-continuation: connection request continuation-reference
|
||||
|
|
@ -562,31 +562,33 @@
|
|||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))])
|
||||
(let* ([inst (hash-table-get config:instances (car k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet-instance
|
||||
"" (current-continuation-marks)))))]
|
||||
(let* ([inst
|
||||
(hash-table-get config:instances (first k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet-instance
|
||||
"" (current-continuation-marks)))))]
|
||||
[k-table
|
||||
(servlet-instance-k-table inst)])
|
||||
(let/cc suspend
|
||||
(set-servlet-instance-context!
|
||||
inst
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t))))
|
||||
(semaphore-wait (servlet-instance-mutex inst))
|
||||
(let ((k*salt
|
||||
(hash-table-get k-table (cadr k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet-continuation
|
||||
"" (current-continuation-marks)))))))
|
||||
(if (= (cadr k*salt) (caddr k-ref))
|
||||
((car k*salt) req)
|
||||
inst
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t))))
|
||||
(let ([k*salt
|
||||
(call-with-semaphore
|
||||
(servlet-instance-mutex inst)
|
||||
(lambda ()
|
||||
(hash-table-get k-table (second k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet-continuation
|
||||
"" (current-continuation-marks)))))))])
|
||||
(if (= (second k*salt) (third k-ref))
|
||||
((first k*salt) req)
|
||||
(raise
|
||||
(make-exn:servlet-continuation
|
||||
"" (current-continuation-marks))))))
|
||||
(semaphore-post (servlet-instance-mutex inst)))))
|
||||
"" (current-continuation-marks)))))))))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
|
|
@ -621,7 +623,7 @@
|
|||
(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 signed-unit)
|
||||
;; given a string path to a filename attempt to load a servlet
|
||||
;; A servlet-file will contain either
|
||||
;;;; A signed-unit-servlet
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user