Refactoring dispatching from rest of server
svn: r682
This commit is contained in:
Jay McCarthy
parent
70a54e379d
commit
0309108a41
77
collects/web-server/dispatch-files.ss
Normal file
77
collects/web-server/dispatch-files.ss
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
(module dispatch-files mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "xml.ss" "xml"))
|
||||
(require "dispatch.ss"
|
||||
"util.ss"
|
||||
"configuration-structures.ss"
|
||||
"response.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher host-info)
|
||||
(lambda (conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(serve-file conn method uri host-info))))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING FILES
|
||||
|
||||
;; serve-file : connection symbol uri host -> void
|
||||
;; to find the file, including searching for implicit index files, and serve it out
|
||||
(define (serve-file conn method uri host-info)
|
||||
(let ([path (url-path->path (paths-htdocs (host-paths host-info))
|
||||
(translate-escapes (url-path->string (url-path uri))))])
|
||||
(cond
|
||||
[(file-exists? path)
|
||||
(output-file conn path method (get-mime-type path))]
|
||||
[(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)]))]
|
||||
[else
|
||||
(output-response/method
|
||||
conn ((responders-file-not-found (host-responders host-info))
|
||||
uri)
|
||||
method)])))
|
||||
|
||||
;; looks-like-directory : str -> bool
|
||||
;; to determine if is url style path looks like it refers to a directory
|
||||
(define (looks-like-directory? path)
|
||||
(eq? #\/ (string-ref path (sub1 (string-length path)))))
|
||||
|
||||
;; output-slash-message: connection symbol string -> void
|
||||
;; basically this is just a special error response
|
||||
(define (output-slash-message conn method url-path-str)
|
||||
(output-response/method
|
||||
conn
|
||||
(make-response/full
|
||||
301 "Moved Permanently"
|
||||
(current-seconds)
|
||||
TEXT/HTML-MIME-TYPE
|
||||
`([Location . ,(string-append url-path-str "/")])
|
||||
(list
|
||||
(xml->string
|
||||
(xexpr->xml
|
||||
`(html
|
||||
(head (title "Add a Slash"))
|
||||
(body "Please use "
|
||||
(a ([href ,(string-append
|
||||
url-path-str "/")])
|
||||
"this url") " instead."))))))
|
||||
method)))
|
||||
|
|
@ -7,11 +7,10 @@
|
|||
"configuration-structures.ss")
|
||||
|
||||
(provide interface-version
|
||||
gen-dispatcher
|
||||
read-passwords)
|
||||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher host-info config:access next-dispatcher)
|
||||
(define (gen-dispatcher host-info config:access)
|
||||
(lambda (conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(cond
|
||||
|
|
@ -19,8 +18,16 @@
|
|||
=> (lambda (realm)
|
||||
(adjust-connection-timeout! conn (timeouts-password (host-timeouts host-info)))
|
||||
(request-authentication conn method uri host-info realm))]
|
||||
[(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
|
||||
(next-dispatcher conn req)]))))
|
||||
(next-dispatcher)]))))
|
||||
|
||||
;; ****************************************
|
||||
;; ****************************************
|
||||
|
|
|
|||
16
collects/web-server/dispatch-pathprocedure.ss
Normal file
16
collects/web-server/dispatch-pathprocedure.ss
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
(module dispatch-pathprocedure mzscheme
|
||||
(require "dispatch.ss"
|
||||
"util.ss"
|
||||
"response.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define ((gen-dispatcher the-path procedure) conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(if (string=? the-path path)
|
||||
(output-response/method
|
||||
conn
|
||||
(procedure)
|
||||
method)
|
||||
(next-dispatcher)))))
|
||||
13
collects/web-server/dispatch-sequencer.ss
Normal file
13
collects/web-server/dispatch-sequencer.ss
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
(module dispatch-sequencer mzscheme
|
||||
(require "dispatch.ss"
|
||||
(lib "list.ss"))
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define ((gen-dispatcher . dispatchers) conn req)
|
||||
(let loop ([dispatchers dispatchers])
|
||||
(let ([c (first dispatchers)])
|
||||
(with-handlers ([exn:dispatcher?
|
||||
(lambda (e) (loop (rest dispatchers)))])
|
||||
(c conn req))))))
|
||||
353
collects/web-server/dispatch-servlets.ss
Normal file
353
collects/web-server/dispatch-servlets.ss
Normal file
|
|
@ -0,0 +1,353 @@
|
|||
(module dispatch-servlets mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "unitsig.ss")
|
||||
(lib "list.ss"))
|
||||
(require "dispatch.ss"
|
||||
"web-server-structs.ss"
|
||||
"connection-manager.ss"
|
||||
"configuration-structures.ss"
|
||||
"response.ss"
|
||||
"request-parsing.ss"
|
||||
"servlet-tables.ss"
|
||||
"servlet.ss"
|
||||
"sig.ss"
|
||||
"timer.ss"
|
||||
"util.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher host-info config:instances config:scripts config:scripts-lock config:make-servlet-namespace)
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING SERVLETS
|
||||
|
||||
;; servlet-content-producer: connection request host -> void
|
||||
(define (servlet-content-producer conn req host-info)
|
||||
(let ([meth (request-method req)])
|
||||
(if (eq? meth 'head)
|
||||
(output-response/method
|
||||
conn
|
||||
(make-response/full
|
||||
200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE
|
||||
'() (list "ignored"))
|
||||
meth)
|
||||
(let ([uri (request-uri req)])
|
||||
(set-request-bindings/raw!
|
||||
req
|
||||
(read-bindings/handled conn meth uri (request-headers req)
|
||||
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)])))))
|
||||
|
||||
;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
|
||||
;; read the bindings and handle any exceptions
|
||||
(define (read-bindings/handled conn meth uri headers host-info)
|
||||
(with-handlers ([exn? (lambda (e)
|
||||
(output-response/method
|
||||
conn
|
||||
;((responders-protocol (host-responders host-info))
|
||||
; (exn-message e))
|
||||
((responders-servlet-loading (host-responders
|
||||
host-info))
|
||||
uri e)
|
||||
|
||||
|
||||
meth)
|
||||
'())])
|
||||
(read-bindings conn meth uri headers)))
|
||||
|
||||
;; servlet-content-producer/path: connection request host url -> void
|
||||
;; 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
|
||||
(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
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))]
|
||||
;; servlet won't load (e.g. syntax error)
|
||||
[(lambda (x) #t)
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-servlet-loading (host-responders
|
||||
host-info)) uri
|
||||
the-exn)
|
||||
(request-method req)))])
|
||||
|
||||
(let ([sema (make-semaphore 0)]
|
||||
[last-inst (thread-cell-ref current-servlet-instance)])
|
||||
(let/cc suspend
|
||||
(let* ([servlet-custodian (make-servlet-custodian)]
|
||||
[inst (create-new-instance!
|
||||
config:instances servlet-custodian
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t)))
|
||||
sema
|
||||
(start-timer 0 (lambda () (void))))]
|
||||
[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)])
|
||||
(parameterize ([current-directory (get-servlet-base-dir real-servlet-path)]
|
||||
[current-custodian servlet-custodian]
|
||||
[exit-handler servlet-exit-handler])
|
||||
(thread-cell-set! current-servlet-instance inst)
|
||||
(let-values (;; timer thread must be within the dynamic extent of
|
||||
;; servlet custodian
|
||||
[(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 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 host-info)])
|
||||
;; Two possibilities:
|
||||
;; - module servlet. start : Request -> Void handles
|
||||
;; output-response via send/finish, etc.
|
||||
;; - unit/sig or simple xexpr servlet. These must produce a
|
||||
;; response, which is then output by the server.
|
||||
;; Here, we do not know if the servlet was a module,
|
||||
;; unit/sig, or Xexpr; we do know whether it produces a
|
||||
;; response.
|
||||
(let ([r (servlet-program req)])
|
||||
(when (response? r)
|
||||
(send/back r)))))))))
|
||||
(thread-cell-set! current-servlet-instance last-inst)
|
||||
(semaphore-post sema))))
|
||||
|
||||
;; make-servlet-exit-handler: servlet-instance -> alpha -> void
|
||||
;; exit handler for a servlet
|
||||
(define (make-servlet-exit-handler inst)
|
||||
(lambda (x)
|
||||
(remove-instance! config:instances inst)
|
||||
(kill-connection!
|
||||
(execution-context-connection
|
||||
(servlet-instance-context inst)))
|
||||
(custodian-shutdown-all (servlet-instance-custodian inst))))
|
||||
|
||||
;; make-servlet-exception-handler: host -> exn -> void
|
||||
;; This exception handler traps all unhandled servlet exceptions
|
||||
;; * Must occur within the dynamic extent of the servlet
|
||||
;; custodian since several connection custodians will typically
|
||||
;; be shutdown during the dynamic extent of a continuation
|
||||
;; * Use the connection from the current-servlet-context in case
|
||||
;; the exception is raised while invoking a continuation.
|
||||
;; * Use the suspend from the servlet-instanct-context which is
|
||||
;; closed over the current tcp ports which may need to be
|
||||
;; closed for an http 1.0 request.
|
||||
;; * Also, suspend will post to the semaphore so that future
|
||||
;; requests won't be blocked.
|
||||
;; * This fixes PR# 7066
|
||||
(define (make-servlet-exception-handler inst host-info)
|
||||
(lambda (the-exn)
|
||||
(let* ([ctxt (servlet-instance-context inst)]
|
||||
[req (execution-context-request ctxt)]
|
||||
[resp ((responders-servlet (host-responders
|
||||
host-info))
|
||||
(request-uri req)
|
||||
the-exn)])
|
||||
;; Don't handle twice
|
||||
(with-handlers ([exn:fail? (lambda (exn) (void))])
|
||||
(output-response/method
|
||||
(execution-context-connection ctxt)
|
||||
resp (request-method req)))
|
||||
((execution-context-suspend ctxt)))))
|
||||
|
||||
;; path -> path
|
||||
;; The actual servlet's parent directory.
|
||||
(define (get-servlet-base-dir servlet-path)
|
||||
(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))))))
|
||||
|
||||
|
||||
;; invoke-servlet-continuation: connection request continuation-reference
|
||||
;; host -> void
|
||||
;; pull the continuation out of the table and apply it
|
||||
(define (invoke-servlet-continuation conn req k-ref host-info)
|
||||
(with-handlers ([exn:servlet-instance?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))]
|
||||
[exn:servlet-continuation?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))])
|
||||
(let* ([last-inst (thread-cell-ref current-servlet-instance)]
|
||||
[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
|
||||
; We don't use call-with-semaphore or dynamic-wind because we
|
||||
; always call a continuation. The exit-handler above ensures that
|
||||
; the post is done.
|
||||
(semaphore-wait (servlet-instance-mutex inst))
|
||||
(thread-cell-set! current-servlet-instance inst)
|
||||
(set-servlet-instance-context!
|
||||
inst
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t))))
|
||||
(increment-timer (servlet-instance-timer inst)
|
||||
(timeouts-default-servlet
|
||||
(host-timeouts host-info)))
|
||||
(let ([k*salt
|
||||
(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))))))
|
||||
(thread-cell-set! current-servlet-instance last-inst)
|
||||
(semaphore-post (servlet-instance-mutex inst))
|
||||
)))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; Paul's ugly loading code:
|
||||
(define make-cache-entry cons)
|
||||
(define cache-entry-servlet car)
|
||||
(define cache-entry-namespace cdr)
|
||||
|
||||
;; 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)))))])
|
||||
(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 -> 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 (entry)
|
||||
; This is only called from cached-load, so config:scripts is locked
|
||||
(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 cache-entry)
|
||||
;; given a string path to a filename attempt to load a servlet
|
||||
;; A servlet-file will contain either
|
||||
;;;; A signed-unit-servlet
|
||||
;;;; A module servlet, currently only 'v1
|
||||
;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.)
|
||||
;;;; A response
|
||||
(define (load-servlet/path a-path)
|
||||
(parameterize ([current-namespace (config:make-servlet-namespace)])
|
||||
(and (file-exists? a-path)
|
||||
(let ([s (load/use-compiled a-path)])
|
||||
(cond
|
||||
;; signed-unit servlet
|
||||
; MF: I'd also like to test that s has the correct import signature.
|
||||
[(unit/sig? s)
|
||||
(make-cache-entry (lambda (initial-request)
|
||||
(invoke-unit/sig s servlet^))
|
||||
(current-namespace))]
|
||||
; FIX - reason about exceptions from dynamic require (catch and report if not already)
|
||||
;; module servlet
|
||||
[(void? s)
|
||||
(let* ([module-name `(file ,(path->string a-path))]
|
||||
[version (dynamic-require module-name 'interface-version)])
|
||||
(case version
|
||||
[(v1)
|
||||
(let ([timeout (dynamic-require module-name 'timeout)]
|
||||
[start (dynamic-require module-name 'start)])
|
||||
(make-cache-entry
|
||||
(lambda (initial-request)
|
||||
(adjust-timeout! timeout)
|
||||
(start initial-request))
|
||||
(current-namespace)))]
|
||||
[else
|
||||
(raise (format "unknown servlet version ~e" version))]))]
|
||||
;; response
|
||||
[(response? s)
|
||||
(letrec ([go (lambda ()
|
||||
(begin
|
||||
(set! go (lambda () (load/use-compiled a-path)))
|
||||
s))])
|
||||
(make-cache-entry (lambda (initial-request) (go))
|
||||
(current-namespace)))]
|
||||
[else
|
||||
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))))
|
||||
|
||||
|
||||
(define servlet-bin?
|
||||
(let ([svt-bin-re (regexp "^/servlets/.*")])
|
||||
(lambda (str)
|
||||
(regexp-match svt-bin-re str))))
|
||||
|
||||
;; return dispatcher
|
||||
(lambda (conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(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)]
|
||||
[(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
|
||||
(next-dispatcher)])))))
|
||||
|
|
@ -2,8 +2,13 @@
|
|||
(require "connection-structs.ss"
|
||||
"request-structs.ss"
|
||||
"response-structs.ss")
|
||||
(require (lib "contract.ss"))
|
||||
(require (lib "contract.ss")
|
||||
(lib "list.ss"))
|
||||
|
||||
(provide dispatcher?)
|
||||
(define dispatcher? (connection? request? . -> . response?))
|
||||
|
||||
(define dispatcher? (connection? request? . -> . response?)))
|
||||
(provide next-dispatcher
|
||||
[struct exn:dispatcher ()])
|
||||
(define-struct exn:dispatcher ())
|
||||
(define (next-dispatcher) (raise (make-exn:dispatcher))))
|
||||
|
|
@ -1,12 +1,20 @@
|
|||
(module sig mzscheme
|
||||
(require (lib "unitsig.ss"))
|
||||
(provide web-server^ servlet^ web-config^ web-config/pervasive^ web-config/local^)
|
||||
(provide
|
||||
dispatch-server^ dispatch-server-config^
|
||||
web-server^ servlet^ web-config^ web-config/pervasive^ web-config/local^)
|
||||
|
||||
(define-signature web-server^
|
||||
(define-signature dispatch-server^
|
||||
(serve
|
||||
serve-ports
|
||||
; for environment:
|
||||
server-loop))
|
||||
(define-signature web-server^
|
||||
((open dispatch-server^)))
|
||||
|
||||
(define-signature dispatch-server-config^
|
||||
(port listen-ip max-waiting initial-connection-timeout
|
||||
read-request dispatch))
|
||||
|
||||
(define-signature servlet^
|
||||
(initial-request send/suspend send/finish send/back send/forward adjust-timeout!))
|
||||
|
|
@ -21,7 +29,8 @@
|
|||
initial-connection-timeout))
|
||||
|
||||
; more here - rename
|
||||
(define-signature web-config/local^ (port listen-ip instances make-servlet-namespace))
|
||||
(define-signature web-config/local^
|
||||
(port listen-ip instances make-servlet-namespace))
|
||||
|
||||
(define-signature web-config^
|
||||
((open web-config/pervasive^) (open web-config/local^))))
|
||||
|
|
@ -3,6 +3,7 @@
|
|||
(lib "string.ss")
|
||||
(lib "list.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "errortrace-lib.ss" "errortrace"))
|
||||
(require "response-structs.ss"
|
||||
"request-structs.ss")
|
||||
|
|
@ -14,6 +15,7 @@
|
|||
url-path->string)
|
||||
|
||||
(provide/contract
|
||||
[xml->string (document? . -> . string?)]
|
||||
[decompose-request ((request?) . ->* . (url? symbol? string?))]
|
||||
[network-error ((symbol? string?) (listof any/c) . ->* . (void))]
|
||||
[path->list (path? . -> . (cons/c (union path? (symbols 'up 'same))
|
||||
|
|
@ -25,6 +27,12 @@
|
|||
[get-mime-type (path? . -> . bytes?)]
|
||||
[build-path-unless-absolute (path? (union string? path?) . -> . path?)])
|
||||
|
||||
;; xml->string: xml -> string
|
||||
(define (xml->string some-xml)
|
||||
(let ([o-port (open-output-string)])
|
||||
(write-xml/content some-xml o-port)
|
||||
(get-output-string o-port)))
|
||||
|
||||
;; ripped this off from url-unit.ss
|
||||
(define (url-path->string strs)
|
||||
(apply
|
||||
|
|
|
|||
9
collects/web-server/web-server-structs.ss
Normal file
9
collects/web-server/web-server-structs.ss
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
(module web-server-structs mzscheme
|
||||
(provide (all-defined))
|
||||
|
||||
(define current-server-custodian (make-parameter #f))
|
||||
|
||||
;; make-servlet-custodian: -> custodian
|
||||
;; create a custodian for the dynamic extent of a servlet continuation
|
||||
(define (make-servlet-custodian)
|
||||
(make-custodian (current-server-custodian))))
|
||||
|
|
@ -1,25 +1,21 @@
|
|||
(module web-server-unit mzscheme
|
||||
(require "sig.ss"
|
||||
"web-server-structs.ss"
|
||||
"connection-manager.ss"
|
||||
"configuration-structures.ss"
|
||||
"util.ss"
|
||||
"response.ss"
|
||||
"servlet-tables.ss"
|
||||
"servlet.ss"
|
||||
"timer.ss")
|
||||
(require (prefix passwords: "dispatch-passwords.ss"))
|
||||
(rename "request-parsing.ss"
|
||||
the-read-request read-request))
|
||||
(require (prefix sequencer: "dispatch-sequencer.ss")
|
||||
(prefix passwords: "dispatch-passwords.ss")
|
||||
(prefix files: "dispatch-files.ss")
|
||||
(prefix servlets: "dispatch-servlets.ss")
|
||||
(prefix path-procedure: "dispatch-pathprocedure.ss"))
|
||||
(require (lib "tcp-sig.ss" "net")
|
||||
(lib "unitsig.ss")
|
||||
(lib "string.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "list.ss"))
|
||||
(provide web-server@)
|
||||
|
||||
(define myprint
|
||||
(lambda args
|
||||
(apply fprintf (cons (current-error-port) args))))
|
||||
|
||||
(lib "url.ss" "net"))
|
||||
(provide web-server@)
|
||||
|
||||
;; ****************************************
|
||||
;; stick this auxilliary outside the unit so
|
||||
|
|
@ -42,16 +38,9 @@
|
|||
|
||||
;; ****************************************
|
||||
|
||||
(define web-server@
|
||||
(unit/sig web-server^
|
||||
(import net:tcp^ (config : web-config^))
|
||||
|
||||
(define current-server-custodian (make-parameter #f))
|
||||
|
||||
;; make-servlet-custodian: -> custodian
|
||||
;; create a custodian for the dynamic extent of a servlet continuation
|
||||
(define (make-servlet-custodian)
|
||||
(make-custodian (current-server-custodian)))
|
||||
(define dispatch-server@
|
||||
(unit/sig dispatch-server^
|
||||
(import net:tcp^ (config : dispatch-server-config^))
|
||||
|
||||
;; serve: -> -> void
|
||||
;; start the server and return a thunk to shut it down
|
||||
|
|
@ -138,463 +127,53 @@
|
|||
;; respond to all requests on this connection
|
||||
(define (serve-connection conn)
|
||||
(let connection-loop ()
|
||||
(let-values ([(req close?) (read-request conn)])
|
||||
(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)
|
||||
(set-connection-close?! conn close?)
|
||||
(adjust-connection-timeout! conn config:initial-connection-timeout)
|
||||
(dispatch conn req host-conf)
|
||||
(cond
|
||||
[(connection-close? conn) (kill-connection! conn)]
|
||||
[else (connection-loop)])))))
|
||||
(let-values ([(req close?) (config:read-request conn)])
|
||||
(set-connection-close?! conn close?)
|
||||
(adjust-connection-timeout! conn config:initial-connection-timeout)
|
||||
(config:dispatch conn req)
|
||||
(cond
|
||||
[(connection-close? conn) (kill-connection! conn)]
|
||||
[else (connection-loop)]))))))
|
||||
|
||||
(define web-config@->dispatch-server-config@
|
||||
(unit/sig dispatch-server-config^
|
||||
(import (config : web-config^))
|
||||
(define read-request the-read-request)
|
||||
|
||||
;; dispatch : connection request host -> void
|
||||
(define port config:port)
|
||||
(define listen-ip config:listen-ip)
|
||||
(define max-waiting config:max-waiting)
|
||||
(define initial-connection-timeout config:initial-connection-timeout)
|
||||
|
||||
;; dispatch: connection request host -> void
|
||||
;; NOTE: (Jay) First step towards a different way of doing dispatching. Initially,
|
||||
;; the dispatchers will be hard-coded based on the configuration file.
|
||||
;; Eventually, they will be more configurable and extensible.
|
||||
(define (dispatch conn req host-info)
|
||||
((passwords:gen-dispatcher
|
||||
host-info config:access
|
||||
(lambda (conn req)
|
||||
(dispatch-old conn req host-info)))
|
||||
conn req))
|
||||
|
||||
;; dispatch-old: connection request host -> void
|
||||
;; 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
|
||||
;; at a later time.
|
||||
(define (dispatch-old conn req host-info)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(cond
|
||||
[(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
|
||||
(passwords:read-passwords host-info))
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-passwords-refreshed (host-responders host-info)))
|
||||
method)]
|
||||
[(string=? "/conf/collect-garbage" path)
|
||||
(collect-garbage)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-collect-garbage (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)])))
|
||||
|
||||
;; conf-prefix?: string -> (union (listof string) #f)
|
||||
;; does the path string have "/conf/" as a prefix?
|
||||
(define conf-prefix?
|
||||
(let ([conf-re (regexp "^/conf/.*")])
|
||||
(lambda (str)
|
||||
(regexp-match conf-re str))))
|
||||
|
||||
(define servlet-bin?
|
||||
(let ([svt-bin-re (regexp "^/servlets/.*")])
|
||||
(lambda (str)
|
||||
(regexp-match svt-bin-re str))))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING FILES
|
||||
|
||||
;; file-content-producer: connection request host -> void
|
||||
(define (file-content-producer conn req host-info)
|
||||
(serve-file conn (request-method req) (request-uri req) host-info))
|
||||
|
||||
;; serve-file : connection symbol uri host -> void
|
||||
;; to find the file, including searching for implicit index files, and serve it out
|
||||
(define (serve-file conn method uri host-info)
|
||||
(let ([path (url-path->path (paths-htdocs (host-paths host-info))
|
||||
(translate-escapes (url-path->string (url-path uri))))])
|
||||
(cond
|
||||
[(file-exists? path)
|
||||
(output-file conn path method (get-mime-type path))]
|
||||
[(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)]))]
|
||||
[else
|
||||
(output-response/method
|
||||
conn ((responders-file-not-found (host-responders host-info))
|
||||
uri)
|
||||
method)])))
|
||||
|
||||
;; looks-like-directory : str -> bool
|
||||
;; to determine if is url style path looks like it refers to a directory
|
||||
(define (looks-like-directory? path)
|
||||
(eq? #\/ (string-ref path (sub1 (string-length path)))))
|
||||
|
||||
;; output-slash-message: connection symbol string -> void
|
||||
;; basically this is just a special error response
|
||||
(define (output-slash-message conn method url-path-str)
|
||||
(output-response/method
|
||||
conn
|
||||
(make-response/full
|
||||
301 "Moved Permanently"
|
||||
(current-seconds)
|
||||
TEXT/HTML-MIME-TYPE
|
||||
`([Location . ,(string-append url-path-str "/")])
|
||||
(list
|
||||
(xml->string
|
||||
(xexpr->xml
|
||||
`(html
|
||||
(head (title "Add a Slash"))
|
||||
(body "Please use "
|
||||
(a ([href ,(string-append
|
||||
url-path-str "/")])
|
||||
"this url") " instead."))))))
|
||||
method))
|
||||
|
||||
;; xml->string: xml -> string
|
||||
(define (xml->string some-xml)
|
||||
(let ([o-port (open-output-string)])
|
||||
(write-xml/content some-xml o-port)
|
||||
(get-output-string o-port)))
|
||||
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING SERVLETS
|
||||
|
||||
;; servlet-content-producer: connection request host -> void
|
||||
(define (servlet-content-producer conn req host-info)
|
||||
(let ([meth (request-method req)])
|
||||
(if (eq? meth 'head)
|
||||
(output-response/method
|
||||
conn
|
||||
(make-response/full
|
||||
200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE
|
||||
'() (list "ignored"))
|
||||
meth)
|
||||
(let ([uri (request-uri req)])
|
||||
(set-request-bindings/raw!
|
||||
req
|
||||
(read-bindings/handled conn meth uri (request-headers req)
|
||||
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)])))))
|
||||
|
||||
;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
|
||||
;; read the bindings and handle any exceptions
|
||||
(define (read-bindings/handled conn meth uri headers host-info)
|
||||
(with-handlers ([exn? (lambda (e)
|
||||
(output-response/method
|
||||
conn
|
||||
;((responders-protocol (host-responders host-info))
|
||||
; (exn-message e))
|
||||
((responders-servlet-loading (host-responders
|
||||
host-info))
|
||||
uri e)
|
||||
|
||||
|
||||
meth)
|
||||
'())])
|
||||
(read-bindings conn meth uri headers)))
|
||||
|
||||
;; servlet-content-producer/path: connection request host url -> void
|
||||
;; 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
|
||||
(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
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))]
|
||||
;; servlet won't load (e.g. syntax error)
|
||||
[(lambda (x) #t)
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-servlet-loading (host-responders
|
||||
host-info)) uri
|
||||
the-exn)
|
||||
(request-method req)))])
|
||||
|
||||
(let ([sema (make-semaphore 0)]
|
||||
[last-inst (thread-cell-ref current-servlet-instance)])
|
||||
(let/cc suspend
|
||||
(let* ([servlet-custodian (make-servlet-custodian)]
|
||||
[inst (create-new-instance!
|
||||
config:instances servlet-custodian
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t)))
|
||||
sema
|
||||
(start-timer 0 (lambda () (void))))]
|
||||
[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)])
|
||||
(parameterize ([current-directory (get-servlet-base-dir real-servlet-path)]
|
||||
[current-custodian servlet-custodian]
|
||||
[exit-handler servlet-exit-handler])
|
||||
(thread-cell-set! current-servlet-instance inst)
|
||||
(let-values (;; timer thread must be within the dynamic extent of
|
||||
;; servlet custodian
|
||||
[(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 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 host-info)])
|
||||
;; Two possibilities:
|
||||
;; - module servlet. start : Request -> Void handles
|
||||
;; output-response via send/finish, etc.
|
||||
;; - unit/sig or simple xexpr servlet. These must produce a
|
||||
;; response, which is then output by the server.
|
||||
;; Here, we do not know if the servlet was a module,
|
||||
;; unit/sig, or Xexpr; we do know whether it produces a
|
||||
;; response.
|
||||
(let ([r (servlet-program req)])
|
||||
(when (response? r)
|
||||
(send/back r)))))))))
|
||||
(thread-cell-set! current-servlet-instance last-inst)
|
||||
(semaphore-post sema))))
|
||||
|
||||
;; make-servlet-exit-handler: servlet-instance -> alpha -> void
|
||||
;; exit handler for a servlet
|
||||
(define (make-servlet-exit-handler inst)
|
||||
(lambda (x)
|
||||
(remove-instance! config:instances inst)
|
||||
(kill-connection!
|
||||
(execution-context-connection
|
||||
(servlet-instance-context inst)))
|
||||
(custodian-shutdown-all (servlet-instance-custodian inst))))
|
||||
|
||||
;; make-servlet-exception-handler: host -> exn -> void
|
||||
;; This exception handler traps all unhandled servlet exceptions
|
||||
;; * Must occur within the dynamic extent of the servlet
|
||||
;; custodian since several connection custodians will typically
|
||||
;; be shutdown during the dynamic extent of a continuation
|
||||
;; * Use the connection from the current-servlet-context in case
|
||||
;; the exception is raised while invoking a continuation.
|
||||
;; * Use the suspend from the servlet-instanct-context which is
|
||||
;; closed over the current tcp ports which may need to be
|
||||
;; closed for an http 1.0 request.
|
||||
;; * Also, suspend will post to the semaphore so that future
|
||||
;; requests won't be blocked.
|
||||
;; * This fixes PR# 7066
|
||||
(define (make-servlet-exception-handler inst host-info)
|
||||
(lambda (the-exn)
|
||||
(let* ([ctxt (servlet-instance-context inst)]
|
||||
[req (execution-context-request ctxt)]
|
||||
[resp ((responders-servlet (host-responders
|
||||
host-info))
|
||||
(request-uri req)
|
||||
the-exn)])
|
||||
;; Don't handle twice
|
||||
(with-handlers ([exn:fail? (lambda (exn) (void))])
|
||||
(output-response/method
|
||||
(execution-context-connection ctxt)
|
||||
resp (request-method req)))
|
||||
((execution-context-suspend ctxt)))))
|
||||
|
||||
;; path -> path
|
||||
;; The actual servlet's parent directory.
|
||||
(define (get-servlet-base-dir servlet-path)
|
||||
(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))))))
|
||||
|
||||
|
||||
;; invoke-servlet-continuation: connection request continuation-reference
|
||||
;; host -> void
|
||||
;; pull the continuation out of the table and apply it
|
||||
(define (invoke-servlet-continuation conn req k-ref host-info)
|
||||
(with-handlers ([exn:servlet-instance?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))]
|
||||
[exn:servlet-continuation?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))])
|
||||
(let* ([last-inst (thread-cell-ref current-servlet-instance)]
|
||||
[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
|
||||
; We don't use call-with-semaphore or dynamic-wind because we
|
||||
; always call a continuation. The exit-handler above ensures that
|
||||
; the post is done.
|
||||
(semaphore-wait (servlet-instance-mutex inst))
|
||||
(thread-cell-set! current-servlet-instance inst)
|
||||
(set-servlet-instance-context!
|
||||
inst
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t))))
|
||||
(increment-timer (servlet-instance-timer inst)
|
||||
(timeouts-default-servlet
|
||||
(host-timeouts host-info)))
|
||||
(let ([k*salt
|
||||
(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))))))
|
||||
(thread-cell-set! current-servlet-instance last-inst)
|
||||
(semaphore-post (servlet-instance-mutex inst))
|
||||
)))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; Paul's ugly loading code:
|
||||
(define make-cache-entry cons)
|
||||
(define cache-entry-servlet car)
|
||||
(define cache-entry-namespace cdr)
|
||||
|
||||
;; 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)))))])
|
||||
(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 -> 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 (entry)
|
||||
; This is only called from cached-load, so config:scripts is locked
|
||||
(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 cache-entry)
|
||||
;; given a string path to a filename attempt to load a servlet
|
||||
;; A servlet-file will contain either
|
||||
;;;; A signed-unit-servlet
|
||||
;;;; A module servlet, currently only 'v1
|
||||
;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.)
|
||||
;;;; A response
|
||||
(define (load-servlet/path a-path)
|
||||
(parameterize ([current-namespace (config:make-servlet-namespace)])
|
||||
(and (file-exists? a-path)
|
||||
(let ([s (load/use-compiled a-path)])
|
||||
(cond
|
||||
;; signed-unit servlet
|
||||
; MF: I'd also like to test that s has the correct import signature.
|
||||
[(unit/sig? s)
|
||||
(make-cache-entry (lambda (initial-request)
|
||||
(invoke-unit/sig s servlet^))
|
||||
(current-namespace))]
|
||||
; FIX - reason about exceptions from dynamic require (catch and report if not already)
|
||||
;; module servlet
|
||||
[(void? s)
|
||||
(let* ([module-name `(file ,(path->string a-path))]
|
||||
[version (dynamic-require module-name 'interface-version)])
|
||||
(case version
|
||||
[(v1)
|
||||
(let ([timeout (dynamic-require module-name 'timeout)]
|
||||
[start (dynamic-require module-name 'start)])
|
||||
(make-cache-entry
|
||||
(lambda (initial-request)
|
||||
(adjust-timeout! timeout)
|
||||
(start initial-request))
|
||||
(current-namespace)))]
|
||||
[else
|
||||
(raise (format "unknown servlet version ~e" version))]))]
|
||||
;; response
|
||||
[(response? s)
|
||||
(letrec ([go (lambda ()
|
||||
(begin
|
||||
(set! go (lambda () (load/use-compiled a-path)))
|
||||
s))])
|
||||
(make-cache-entry (lambda (initial-request) (go))
|
||||
(current-namespace)))]
|
||||
[else
|
||||
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))))
|
||||
)))
|
||||
(define (dispatch conn req)
|
||||
(let* ([host (get-host (request-uri req) (request-headers req))]
|
||||
[host-info (config:virtual-hosts host)])
|
||||
((host-log-message host-info) (request-host-ip req)
|
||||
(request-client-ip req) (request-method req) (request-uri req) host)
|
||||
((sequencer:gen-dispatcher
|
||||
(passwords:gen-dispatcher host-info config:access)
|
||||
(path-procedure:gen-dispatcher "/conf/collect-garbage"
|
||||
(lambda ()
|
||||
(collect-garbage)
|
||||
((responders-collect-garbage (host-responders host-info)))))
|
||||
(servlets:gen-dispatcher host-info
|
||||
config:instances config:scripts config:scripts-lock config:make-servlet-namespace)
|
||||
(files:gen-dispatcher host-info))
|
||||
conn req)))))
|
||||
|
||||
(define web-server@
|
||||
(compound-unit/sig
|
||||
(import (TCP : net:tcp^)
|
||||
(CONFIG : web-config^))
|
||||
(link (DISPATCH : dispatch-server^
|
||||
(dispatch-server@ TCP DISPATCH-CONFIG))
|
||||
(DISPATCH-CONFIG : dispatch-server-config^
|
||||
(web-config@->dispatch-server-config@ CONFIG)))
|
||||
(export (open (DISPATCH : web-server^))))))
|
||||
Loading…
Reference in New Issue
Block a user