From 0309108a41d73d949ad104a6c6a3031bbc313f72 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Aug 2005 13:23:02 +0000 Subject: [PATCH] Refactoring dispatching from rest of server svn: r682 --- collects/web-server/dispatch-files.ss | 77 +++ collects/web-server/dispatch-passwords.ss | 15 +- collects/web-server/dispatch-pathprocedure.ss | 16 + collects/web-server/dispatch-sequencer.ss | 13 + collects/web-server/dispatch-servlets.ss | 353 ++++++++++++ collects/web-server/dispatch.ss | 9 +- collects/web-server/sig.ss | 15 +- collects/web-server/util.ss | 8 + collects/web-server/web-server-structs.ss | 9 + collects/web-server/web-server-unit.ss | 533 ++---------------- 10 files changed, 562 insertions(+), 486 deletions(-) create mode 100644 collects/web-server/dispatch-files.ss create mode 100644 collects/web-server/dispatch-pathprocedure.ss create mode 100644 collects/web-server/dispatch-sequencer.ss create mode 100644 collects/web-server/dispatch-servlets.ss create mode 100644 collects/web-server/web-server-structs.ss diff --git a/collects/web-server/dispatch-files.ss b/collects/web-server/dispatch-files.ss new file mode 100644 index 0000000000..ca43899930 --- /dev/null +++ b/collects/web-server/dispatch-files.ss @@ -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))) \ No newline at end of file diff --git a/collects/web-server/dispatch-passwords.ss b/collects/web-server/dispatch-passwords.ss index 2459d4d08c..55f4404f19 100644 --- a/collects/web-server/dispatch-passwords.ss +++ b/collects/web-server/dispatch-passwords.ss @@ -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)])))) ;; **************************************** ;; **************************************** diff --git a/collects/web-server/dispatch-pathprocedure.ss b/collects/web-server/dispatch-pathprocedure.ss new file mode 100644 index 0000000000..5f364cfa33 --- /dev/null +++ b/collects/web-server/dispatch-pathprocedure.ss @@ -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))))) \ No newline at end of file diff --git a/collects/web-server/dispatch-sequencer.ss b/collects/web-server/dispatch-sequencer.ss new file mode 100644 index 0000000000..59931d2387 --- /dev/null +++ b/collects/web-server/dispatch-sequencer.ss @@ -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)))))) \ No newline at end of file diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss new file mode 100644 index 0000000000..2a23558b15 --- /dev/null +++ b/collects/web-server/dispatch-servlets.ss @@ -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)]))))) \ No newline at end of file diff --git a/collects/web-server/dispatch.ss b/collects/web-server/dispatch.ss index 56f608ed03..6271145040 100644 --- a/collects/web-server/dispatch.ss +++ b/collects/web-server/dispatch.ss @@ -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?))) \ No newline at end of file + (provide next-dispatcher + [struct exn:dispatcher ()]) + (define-struct exn:dispatcher ()) + (define (next-dispatcher) (raise (make-exn:dispatcher)))) \ No newline at end of file diff --git a/collects/web-server/sig.ss b/collects/web-server/sig.ss index 02f782c2b0..0ad1379ae5 100644 --- a/collects/web-server/sig.ss +++ b/collects/web-server/sig.ss @@ -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^)))) \ No newline at end of file diff --git a/collects/web-server/util.ss b/collects/web-server/util.ss index b9a694f368..60235ee54c 100644 --- a/collects/web-server/util.ss +++ b/collects/web-server/util.ss @@ -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 diff --git a/collects/web-server/web-server-structs.ss b/collects/web-server/web-server-structs.ss new file mode 100644 index 0000000000..64939d7ca8 --- /dev/null +++ b/collects/web-server/web-server-structs.ss @@ -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)))) \ No newline at end of file diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 05d7bb0d5e..93a511febe 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -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)]))))) - ))) \ No newline at end of file + (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^)))))) \ No newline at end of file