From a3c0f24fc94ebf22dfd4133791ccd425731d0e28 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 21 Nov 2005 21:16:28 +0000 Subject: [PATCH] Removing monolithic host-info svn: r1362 --- .../web-server/configuration-structures.ss | 4 +- collects/web-server/configuration.ss | 57 ++------ collects/web-server/dispatch-files.ss | 70 ++++----- collects/web-server/dispatch-host.ss | 11 ++ collects/web-server/dispatch-log.ss | 57 ++++++++ collects/web-server/dispatch-passwords.ss | 136 +++++++++--------- collects/web-server/dispatch-servlets.ss | 117 ++++++--------- collects/web-server/gui-launch.ss | 1 - collects/web-server/servlet-helpers.ss | 18 ++- collects/web-server/timer.ss | 1 - collects/web-server/web-server-unit.ss | 112 +++++++-------- 11 files changed, 284 insertions(+), 300 deletions(-) create mode 100644 collects/web-server/dispatch-host.ss create mode 100644 collects/web-server/dispatch-log.ss diff --git a/collects/web-server/configuration-structures.ss b/collects/web-server/configuration-structures.ss index 3c32d5c825..b26b8108c5 100644 --- a/collects/web-server/configuration-structures.ss +++ b/collects/web-server/configuration-structures.ss @@ -6,10 +6,10 @@ ; configuration is now a unit. See sig.ss - ; host = (make-host (listof str) (str str sym url str -> str) + ; host = (make-host (listof str) sym string ; passwords resopnders timeouts paths) (provide-define-struct - host (indices log-message passwords responders timeouts paths)) + host (indices log-format log-path passwords responders timeouts paths)) ; passwords = (listof (list* relm:str protected-dir-regexp:str ; (listof (list user:sym password:str)))) diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss index 6ca4e49d6e..4828c67198 100644 --- a/collects/web-server/configuration.ss +++ b/collects/web-server/configuration.ss @@ -8,9 +8,7 @@ "cache-table.ss" "response.ss") (require (lib "unitsig.ss") - (lib "contract.ss") - (lib "url.ss" "net") - (lib "date.ss")) + (lib "contract.ss")) (provide complete-configuration build-developer-configuration @@ -57,11 +55,11 @@ table (let ([default-host (apply-default-functions-to-host-table - base (configuration-table-default-host table) ignore-log)] + base (configuration-table-default-host table))] [expanded-virtual-host-table (map (lambda (x) (list (regexp (string-append (car x) "(:[0-9]*)?")) - (apply-default-functions-to-host-table base (cdr x) ignore-log))) + (apply-default-functions-to-host-table base (cdr x)))) (configuration-table-virtual-hosts table))]) (gen-virtual-hosts expanded-virtual-host-table default-host)))) @@ -71,11 +69,11 @@ table (let ([default-host (apply-default-functions-to-host-table - base (configuration-table-default-host table) gen-log-message)] + base (configuration-table-default-host table))] [expanded-virtual-host-table (map (lambda (x) (list (regexp (string-append (car x) "(:[0-9]*)?")) - (apply-default-functions-to-host-table base (cdr x) gen-log-message))) + (apply-default-functions-to-host-table base (cdr x)))) (configuration-table-virtual-hosts table))]) (gen-virtual-hosts expanded-virtual-host-table default-host)))) @@ -85,7 +83,7 @@ table (gen-virtual-hosts null (apply-default-functions-to-host-table base - (configuration-table-default-host table) ignore-log)))) + (configuration-table-default-host table))))) ; : configuration-table host-table -> configuration (define (build-configuration table the-virtual-hosts) @@ -235,55 +233,18 @@ (lambda (str) (regexp-match servlets-regexp str)))) - ; access-denied? : str sym str -> (U #f str) - ; (define (access-denied? client-ip user-name password) ???) - ; The configuration needs a simple way to combine ip and username authentication with - ; boolean-and, boolean-or, and perhaps others operations. - ; Using quote in the old password system enabled abstraction, which - ; I never used. - ; ... - - ; gen-log-message : sym str -> str str sym url str -> str - ; more here - check apache log configuration formats - ; other server's include the original request line, - ; including the major and minor HTTP version numbers - ; to produce a string that is displayed into the log file - (define (gen-log-message log-format log-path) - (let ([outsem (make-semaphore 1)] - [log-p #f]) - (lambda (host-ip client-ip method uri host) - (call-with-semaphore - outsem - (lambda () - (with-handlers ([exn? (lambda (e) (set! log-p #f))]) - (unless (and log-p (file-exists? log-path)) - (unless (eq? log-p #f) - (close-output-port log-p)) - (set! log-p (open-output-file log-path 'append)) - (file-stream-buffer-mode log-p 'line)) - ; do the display all at once by formating first - (when log-p - (display - (format "~s~n" - (list 'from client-ip 'to host-ip 'for (url->string uri) 'at - (date->string (seconds->date (current-seconds)) #t))) - log-p)))))))) - - ; ignore-log : sym str -> str str sym url str -> str - (define (ignore-log log-format log-path) void) - ; read-file : str -> str (define (read-file path) (call-with-input-file path (lambda (in) (read-string (file-size path) in)))) - ; apply-default-functions-to-host-table : str host-table (sym str -> str str sym url str -> str) -> host + ; apply-default-functions-to-host-table : str host-table -> host ;; Greg P: web-server-root is the directory-part of the path to the configuration-table (I don't think I like this.) - (define (apply-default-functions-to-host-table web-server-root host-table gen-log-message-maybe) + (define (apply-default-functions-to-host-table web-server-root host-table) (let ([paths (expand-paths web-server-root (host-table-paths host-table))]) (make-host (host-table-indices host-table) - (gen-log-message-maybe (host-table-log-format host-table) (paths-log paths)) + (host-table-log-format host-table) (paths-log paths) (paths-passwords paths) (let ([m (host-table-messages host-table)] [conf (paths-conf paths)]) diff --git a/collects/web-server/dispatch-files.ss b/collects/web-server/dispatch-files.ss index 2a347f107d..e1f92d266d 100644 --- a/collects/web-server/dispatch-files.ss +++ b/collects/web-server/dispatch-files.ss @@ -1,54 +1,44 @@ (module dispatch-files mzscheme (require (lib "url.ss" "net") - (lib "xml.ss" "xml")) + (lib "xml.ss" "xml") + (lib "list.ss")) (require "dispatch.ss" "util.ss" - "configuration-structures.ss" "response.ss") (provide interface-version gen-dispatcher) (define interface-version 'v1) - (define (gen-dispatcher host-info) + (define (gen-dispatcher htdocs-path indices file-not-found-responder) (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)]))) + ;; ************************************************************ + ;; ************************************************************ + ;; SERVING FILES + + ;; serve-file : connection symbol uri host -> void + ;; to find the file, including searching for implicit index files, and serve it out + (let ([path (url-path->path htdocs-path + (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 indices]) + (cond + [(pair? dir-defaults) + (let ([full-name (build-path path (first 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 (rest dir-defaults))))] + [else + (output-response/method conn (file-not-found-responder uri) method)]))] + [else + (output-response/method conn (file-not-found-responder uri) method)]))))) ;; looks-like-directory : str -> bool ;; to determine if is url style path looks like it refers to a directory diff --git a/collects/web-server/dispatch-host.ss b/collects/web-server/dispatch-host.ss new file mode 100644 index 0000000000..1c084c8c8a --- /dev/null +++ b/collects/web-server/dispatch-host.ss @@ -0,0 +1,11 @@ +(module dispatch-host mzscheme + (require "dispatch.ss" + "servlet-helpers.ss") + (provide interface-version + gen-dispatcher) + + (define interface-version 'v1) + (define (gen-dispatcher lookup-dispatcher) + (lambda (conn req) + (let* ([host (get-host (request-uri req) (request-headers req))]) + ((lookup-dispatcher host) conn req))))) \ No newline at end of file diff --git a/collects/web-server/dispatch-log.ss b/collects/web-server/dispatch-log.ss new file mode 100644 index 0000000000..917081f101 --- /dev/null +++ b/collects/web-server/dispatch-log.ss @@ -0,0 +1,57 @@ +(module dispatch-log mzscheme + (require (lib "url.ss" "net") + (lib "date.ss") + (lib "async-channel.ss") + (lib "plt-match.ss")) + (require "dispatch.ss" + "servlet-helpers.ss") + (provide interface-version + gen-dispatcher) + + (define interface-version 'v1) + (define (gen-dispatcher log-format log-path) + (let ([log-message (gen-log-message log-format log-path)]) + (lambda (conn req) + (let ([host (get-host (request-uri req) (request-headers req))]) + (log-message (request-host-ip req) + (request-client-ip req) + (request-method req) + (request-uri req) + host) + (next-dispatcher))))) + + ; gen-log-message : sym str -> str str sym url str -> str + ; XXX: check apache log configuration formats + ; other server's include the original request line, + ; including the major and minor HTTP version numbers + ; to produce a string that is displayed into the log file + ; This is a kill-safe wait-less abstraction + (define (gen-log-message log-format log-path) + (let* ([log-ch (make-async-channel)] + [log-thread + (thread/suspend-to-kill + (lambda () + (let loop ([log-p #f]) + (with-handlers ([exn? (lambda (e) (loop #f))]) + (if (not (and log-p (file-exists? log-path))) + (begin + (unless (eq? log-p #f) + (close-output-port log-p)) + (let ([new-log-p (open-output-file log-path 'append)]) + (file-stream-buffer-mode new-log-p 'line) + (loop new-log-p))) + (sync + (handle-evt + log-ch + (match-lambda + [(list host-ip client-ip method uri host) + (display + (format "~s~n" + (list 'from client-ip 'to host-ip 'for (url->string uri) 'at + (date->string (seconds->date (current-seconds)) #t))) + log-p) + (loop log-p)]))))))))]) + (lambda args + (thread-resume log-thread) + (async-channel-put log-ch args) + (void))))) \ No newline at end of file diff --git a/collects/web-server/dispatch-passwords.ss b/collects/web-server/dispatch-passwords.ss index af329c7206..223cabd8a5 100644 --- a/collects/web-server/dispatch-passwords.ss +++ b/collects/web-server/dispatch-passwords.ss @@ -3,31 +3,40 @@ "util.ss" "servlet-helpers.ss" "connection-manager.ss" - "response.ss" - "configuration-structures.ss") + "response.ss") (provide interface-version gen-dispatcher) (define interface-version 'v1) - (define (gen-dispatcher host-info config:access) - (lambda (conn req) - (let-values ([(uri method path) (decompose-request req)]) - (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))] - [(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)])))) + (define (gen-dispatcher password-file password-connection-timeout authentication-responder passwords-refresh-responder) + (let* ([password-cache (box #f)] + [reset-password-cache! + (lambda () + ; more here - a malformed password file will kill the connection + (set-box! password-cache (read-passwords password-file)))] + [read-password-cache + (lambda () + (unbox password-cache))]) + (reset-password-cache!) + (lambda (conn req) + (let-values ([(uri method path) (decompose-request req)]) + (cond + [(access-denied? method path (request-headers req) (read-password-cache)) + => (lambda (realm) + (adjust-connection-timeout! conn password-connection-timeout) + (request-authentication conn method uri + authentication-responder + realm))] + [(string=? "/conf/refresh-passwords" path) + ;; more here - send a nice error page + (reset-password-cache!) + (output-response/method + conn + (passwords-refresh-responder) + method)] + [else + (next-dispatcher)]))))) ;; **************************************** ;; **************************************** @@ -36,26 +45,14 @@ ;; pass-entry = (make-pass-entry str regexp (list sym str)) (define-struct pass-entry (domain pattern users)) - ;; access-denied? : Method string x-table host Access-table -> (+ false str) + ;; access-denied? : Method string x-table denied? -> (+ false str) + ;; denied?: str sym str -> (U str #f) ;; the return string is the prompt for authentication - (define (access-denied? method uri-str headers host-info access-table) - ;; denied?: str sym str -> (U str #f) - ;; a function to authenticate the user - (let ([denied? - - ;; GregP lookup the authenticator function, if you can't find it, then try to load the - ;; passwords file for this host. - (hash-table-get - access-table host-info - (lambda () - ; more here - a malformed password file will kill the connection - (let ([f (read-passwords host-info)]) - (hash-table-put! access-table host-info f) - f)))]) - (let ([user-pass (extract-user-pass headers)]) - (if user-pass - (denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass)) - (denied? uri-str fake-user ""))))) + (define (access-denied? method uri-str headers denied?) + (let ([user-pass (extract-user-pass headers)]) + (if user-pass + (denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass)) + (denied? uri-str fake-user "")))) (define-struct (exn:password-file exn) ()) @@ -64,33 +61,32 @@ ;; password. If not, the produced function returns a string, prompting for the password. ;; If the password file does not exist, all accesses are allowed. If the file is malformed, an ;; exn:password-file is raised. - (define (read-passwords host-info) - (let ([password-path (host-passwords host-info)]) - (with-handlers ([void (lambda (exn) - (raise (make-exn:password-file (string->immutable-string - (format "could not load password file ~a" password-path)) - (current-continuation-marks))))]) - (if (and (file-exists? password-path) (memq 'read (file-or-directory-permissions password-path))) - (let ([passwords - (let ([raw (load password-path)]) - (unless (password-list? raw) - (raise "malformed passwords")) - (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x))) - raw))]) - - ;; string symbol bytes -> (union #f string) - (lambda (request-path user-name password) - (ormap (lambda (x) - (and (regexp-match (pass-entry-pattern x) request-path) - (let ([name-pass (assq user-name (pass-entry-users x))]) - (if (and name-pass - (string=? - (cadr name-pass) - (bytes->string/utf-8 password))) - #f - (pass-entry-domain x))))) - passwords))) - (lambda (req user pass) #f))))) + (define (read-passwords password-path) + (with-handlers ([void (lambda (exn) + (raise (make-exn:password-file (string->immutable-string + (format "could not load password file ~a" password-path)) + (current-continuation-marks))))]) + (if (and (file-exists? password-path) (memq 'read (file-or-directory-permissions password-path))) + (let ([passwords + (let ([raw (load password-path)]) + (unless (password-list? raw) + (raise "malformed passwords")) + (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x))) + raw))]) + + ;; string symbol bytes -> (union #f string) + (lambda (request-path user-name password) + (ormap (lambda (x) + (and (regexp-match (pass-entry-pattern x) request-path) + (let ([name-pass (assq user-name (pass-entry-users x))]) + (if (and name-pass + (string=? + (cadr name-pass) + (bytes->string/utf-8 password))) + #f + (pass-entry-domain x))))) + passwords))) + (lambda (req user pass) #f)))) (define fake-user (gensym)) @@ -113,10 +109,10 @@ ;; request-authentication : connection Method URL iport oport host str bool -> bool ;; GregP: at first look, it seems that this gets called when the user ;; has supplied bad authentication credentials. - (define (request-authentication conn method uri host-info realm) + (define (request-authentication conn method uri authentication-responder realm) (output-response/method conn - ((responders-authentication (host-responders host-info)) - uri `(WWW-Authenticate . ,(string-append " Basic - realm=\"" realm "\""))) + (authentication-responder + uri + `(WWW-Authenticate . ,(format " Basic realm=\"~a\"" realm))) method))) \ No newline at end of file diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index fc408806b8..a94a2c3b7a 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -1,13 +1,10 @@ (module dispatch-servlets mzscheme (require (lib "url.ss" "net") - (lib "unitsig.ss") - (lib "list.ss")) + (lib "unitsig.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" @@ -18,13 +15,17 @@ gen-dispatcher) (define interface-version 'v1) - (define (gen-dispatcher host-info config:instances config:scripts config:make-servlet-namespace) + (define (gen-dispatcher config:instances config:scripts config:make-servlet-namespace + servlet-root + responders-servlets-refreshed responders-servlet-loading responders-servlet + responders-file-not-found + timeouts-servlet-connection timeouts-default-servlet) ;; ************************************************************ ;; ************************************************************ ;; SERVING SERVLETS - ;; servlet-content-producer: connection request host -> void - (define (servlet-content-producer conn req host-info) + ;; servlet-content-producer: connection request -> void + (define (servlet-content-producer conn req) (let ([meth (request-method req)]) (if (eq? meth 'head) (output-response/method @@ -36,54 +37,34 @@ (let ([uri (request-uri req)]) (set-request-bindings/raw! req - (read-bindings/handled conn meth uri (request-headers req) - host-info)) + (read-bindings/handled conn meth uri (request-headers req))) (cond [(continuation-url? uri) => (lambda (k-ref) - (invoke-servlet-continuation conn req k-ref host-info))] + (invoke-servlet-continuation conn req k-ref))] [else - (servlet-content-producer/path conn req host-info uri)]))))) + (servlet-content-producer/path conn req uri)]))))) - ;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string)) + ;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string)) ;; read the bindings and handle any exceptions - (define (read-bindings/handled conn meth uri headers host-info) + (define (read-bindings/handled conn meth uri headers) (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) + (output-response/method conn (responders-servlet-loading uri e) meth) '())]) (read-bindings conn meth uri headers))) - ;; servlet-content-producer/path: connection request host url -> void + ;; servlet-content-producer/path: connection request 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) + (define (servlet-content-producer/path conn req 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)))] + (output-response/method conn (responders-file-not-found (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)))]) + (output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))]) (let ([sema (make-semaphore 0)] [last-inst (thread-cell-ref current-servlet-instance)]) (let/cc suspend @@ -101,19 +82,18 @@ (exn-message e) (exn-continuation-marks e))))]) (url-path->path - (paths-servlet (host-paths host-info)) + servlet-root (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] [current-servlet-continuation-expiration-handler - (make-default-servlet-continuation-expiration-handler host-info)] + (make-default-servlet-continuation-expiration-handler)] [exit-handler servlet-exit-handler]) (thread-cell-set! current-servlet-instance inst) (let (;; timer thread must be within the dynamic extent of ;; servlet custodian - [time-bomb (start-timer (timeouts-default-servlet - (host-timeouts host-info)) + [time-bomb (start-timer timeouts-default-servlet (lambda () (servlet-exit-handler #f)))] ;; any resources (e.g. threads) created when the @@ -123,7 +103,7 @@ (parameterize ([current-namespace (servlet-namespace the-servlet)]) (set-servlet-instance-timer! inst time-bomb) (with-handlers ([(lambda (x) #t) - (make-servlet-exception-handler inst host-info)]) + (make-servlet-exception-handler inst)]) ;; Two possibilities: ;; - module servlet. start : Request -> Void handles ;; output-response via send/finish, etc. @@ -148,23 +128,21 @@ (servlet-instance-context inst))) (custodian-shutdown-all (servlet-instance-custodian inst)))) - ;; make-default-server-continuation-expiration-handler : host -> (request -> response) - (define (make-default-servlet-continuation-expiration-handler host-info) + ;; make-default-server-continuation-expiration-handler : -> (request -> response) + (define (make-default-servlet-continuation-expiration-handler) (lambda (req) (send/back - ((responders-file-not-found (host-responders - host-info)) + (responders-file-not-found (request-uri req))))) - ;; make-default-server-instance-expiration-handler : host -> (request -> response) - (define (make-default-servlet-instance-expiration-handler host-info) + ;; make-default-server-instance-expiration-handler : -> (request -> response) + (define (make-default-servlet-instance-expiration-handler) (lambda (req) - ((responders-file-not-found (host-responders - host-info)) + (responders-file-not-found (request-uri req)))) - ;; make-servlet-exception-handler: host -> exn -> void + ;; make-servlet-exception-handler: servlet-instance -> 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 @@ -177,12 +155,11 @@ ;; * 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) + (define (make-servlet-exception-handler inst) (lambda (the-exn) (let* ([ctxt (servlet-instance-context inst)] [req (execution-context-request ctxt)] - [resp ((responders-servlet (host-responders - host-info)) + [resp (responders-servlet (request-uri req) the-exn)]) ;; Don't handle twice @@ -203,21 +180,20 @@ (or (and (directory-exists? base) base) (loop base)))))) - ;; invoke-servlet-continuation: connection request continuation-reference - ;; host -> void + ;; invoke-servlet-continuation: connection request continuation-reference -> void ;; pull the continuation out of the table and apply it - (define (invoke-servlet-continuation conn req k-ref host-info) + (define (invoke-servlet-continuation conn req k-ref) (let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)]) (let* ([uri (request-uri req)] [real-servlet-path (url-path->path - (paths-servlet (host-paths host-info)) + servlet-root (url-path->string (url-path uri)))] [the-servlet (cached-load real-servlet-path)]) (parameterize ([current-custodian (servlet-custodian the-servlet)]) (let ([default-servlet-instance-expiration-handler - (make-default-servlet-instance-expiration-handler host-info)] + (make-default-servlet-instance-expiration-handler)] [default-servlet-continuation-expiration-handler - (make-default-servlet-continuation-expiration-handler host-info)] + (make-default-servlet-continuation-expiration-handler)] [last-inst (thread-cell-ref current-servlet-instance)]) (thread-cell-set! current-servlet-instance #f) (with-handlers ([exn:servlet:instance? @@ -338,9 +314,8 @@ (make-servlet (v0.servlet->v1.lambda s) servlet-custodian (current-namespace) - (timeouts-default-servlet - (host-timeouts host-info)) - (make-default-servlet-instance-expiration-handler host-info))] + timeouts-default-servlet + (make-default-servlet-instance-expiration-handler))] ; FIX - reason about exceptions from dynamic require (catch and report if not already) ;; module servlet [(void? s) @@ -353,9 +328,8 @@ (make-servlet (v1.module->v1.lambda timeout start) servlet-custodian (current-namespace) - (timeouts-default-servlet - (host-timeouts host-info)) - (make-default-servlet-instance-expiration-handler host-info)))] + timeouts-default-servlet + (make-default-servlet-instance-expiration-handler)))] [(v2-transitional) ; XXX: Undocumented (let ([timeout (dynamic-require module-name 'timeout)] [instance-expiration-handler (dynamic-require module-name 'instance-expiration-handler)] @@ -372,9 +346,8 @@ (make-servlet (v0.response->v1.lambda s a-path) servlet-custodian (current-namespace) - (timeouts-default-servlet - (host-timeouts host-info)) - (make-default-servlet-instance-expiration-handler host-info))] + timeouts-default-servlet + (make-default-servlet-instance-expiration-handler))] [else (raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))))) @@ -392,13 +365,13 @@ (cache-table-clear! (unbox config:scripts)) (output-response/method conn - ((responders-servlets-refreshed (host-responders host-info))) + (responders-servlets-refreshed) method)] [(servlet-bin? path) (adjust-connection-timeout! conn - (timeouts-servlet-connection (host-timeouts host-info))) + timeouts-servlet-connection) ;; more here - make timeouts proportional to size of bindings - (servlet-content-producer conn req host-info)] + (servlet-content-producer conn req)] [else (next-dispatcher)]))))) \ No newline at end of file diff --git a/collects/web-server/gui-launch.ss b/collects/web-server/gui-launch.ss index 427552c1bd..afe1839298 100644 --- a/collects/web-server/gui-launch.ss +++ b/collects/web-server/gui-launch.ss @@ -1,4 +1,3 @@ - (module gui-launch mzscheme (require "launch.ss" (lib "class.ss") diff --git a/collects/web-server/servlet-helpers.ss b/collects/web-server/servlet-helpers.ss index 5588ef7efc..2c01362ee6 100644 --- a/collects/web-server/servlet-helpers.ss +++ b/collects/web-server/servlet-helpers.ss @@ -2,12 +2,13 @@ (require (lib "list.ss") (lib "etc.ss") (lib "xml.ss" "xml") - (lib "base64.ss" "net")) + (lib "base64.ss" "net") + (lib "url.ss" "net")) (require "util.ss" "response.ss" "request-parsing.ss") - - (provide extract-binding/single + (provide get-host + extract-binding/single extract-bindings exists-binding? extract-user-pass @@ -21,6 +22,17 @@ (all-from "request-parsing.ss") (rename get-parsed-bindings request-bindings) translate-escapes) + + ;; get-host : Url (listof (cons Symbol String)) -> Symbol + ;; host names are case insesitive---Internet RFC 1034 + (define DEFAULT-HOST-NAME ') + (define (get-host uri headers) + (cond + [(url-host uri) => string->symbol] + [(assq 'host headers) + => + (lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))] + [else DEFAULT-HOST-NAME])) ;; get-parsed-bindings : request -> (listof (cons sym str)) (define (get-parsed-bindings r) diff --git a/collects/web-server/timer.ss b/collects/web-server/timer.ss index 1669c86852..a01018c617 100644 --- a/collects/web-server/timer.ss +++ b/collects/web-server/timer.ss @@ -10,7 +10,6 @@ (define timer-ch (make-async-channel)) ; start-timer-manager : custodian -> void - ; Thanks to Matthew! ; The timer manager thread (define (start-timer-manager server-custodian) (parameterize ([current-custodian server-custodian]) diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 92ca4cbc00..f3e9411b5e 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -11,30 +11,16 @@ (prefix passwords: "dispatch-passwords.ss") (prefix files: "dispatch-files.ss") (prefix servlets: "dispatch-servlets.ss") - (prefix path-procedure: "dispatch-pathprocedure.ss")) + (prefix path-procedure: "dispatch-pathprocedure.ss") + (prefix log: "dispatch-log.ss") + (prefix host: "dispatch-host.ss")) (require (lib "tcp-sig.ss" "net") (lib "unitsig.ss") (lib "string.ss") (lib "url.ss" "net")) - (provide web-server@) - - ;; **************************************** - ;; stick this auxilliary outside the unit so - ;; I can get at it with require/expose - - ;; get-host : Url (listof (cons Symbol String)) -> Symbol - ;; host names are case insesitive---Internet RFC 1034 - (define DEFAULT-HOST-NAME ') - (define (get-host uri headers) - (cond - [(url-host uri) => string->symbol] - [(assq 'host headers) - => - (lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))] - [else DEFAULT-HOST-NAME])) - - ;; **************************************** + (provide web-server@) + ;; **************************************** (define dispatch-server@ (unit/sig dispatch-server^ (import net:tcp^ (config : dispatch-server-config^)) @@ -55,25 +41,23 @@ ;; listener-loop : -> void ;; loops around starting a listener if the current listener dies (define (listener-loop) - (let ([sema (make-semaphore 0)]) - (let loop () - (let ([listener (tcp-listen config:port config:max-waiting - #t config:listen-ip)]) - (let ([get-ports - (lambda () (tcp-accept listener))]) - (thread - (lambda () - (with-handlers ([void (lambda (e) - ; If the exception did not kill the listener - (with-handlers ([void void]) - (tcp-close listener)) - (semaphore-post sema) - ; Rethrow the error to this thread's error printer - (raise e))]) - (server-loop get-ports - tcp-addresses)))))) - (semaphore-wait sema) - (loop)))) + (let loop () + (thread-wait + (let* ([listener (tcp-listen config:port config:max-waiting + #t config:listen-ip)] + [get-ports + (lambda () (tcp-accept listener))]) + (thread + (lambda () + (with-handlers ([void (lambda (e) + ; If the exception did not kill the listener + (with-handlers ([void void]) + (tcp-close listener)) + ; Rethrow the error to this thread's error printer + (raise e))]) + (server-loop get-ports + tcp-addresses)))))) + (loop))) ;; server-loop: (-> input-port output-port) (input-port -> string string) -> void ;; start a thread to handle each incoming connection @@ -138,39 +122,41 @@ (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. - ;; 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. + ;; dispatch : connection request -> void (define dispatch - (let* ([cache (make-cache-table)] - [lookup-dispatcher - (lambda (host host-info) - (cache-table-lookup! - cache host - (lambda () - (host-info->dispatcher host-info))))]) - (lambda (conn req) - (let* ([host (get-host (request-uri req) (request-headers req))] - [host-info (config:virtual-hosts (symbol->string host))]) - ((host-log-message host-info) (request-host-ip req) - (request-client-ip req) (request-method req) (request-uri req) host) - ((lookup-dispatcher host host-info) - conn req))))) + (let* ([cache (make-cache-table)]) + (host:gen-dispatcher + (lambda (host) + (cache-table-lookup! + cache host + (lambda () + (host-info->dispatcher + (config:virtual-hosts (symbol->string host))))))))) + ;; host-info->dispatcher : host-info -> conn request -> void (define (host-info->dispatcher host-info) (sequencer:gen-dispatcher - (passwords:gen-dispatcher host-info config:access) + (log:gen-dispatcher (host-log-format host-info) + (host-log-path host-info)) + (passwords:gen-dispatcher (host-passwords host-info) + (timeouts-password (host-timeouts host-info)) + (responders-authentication (host-responders host-info)) + (responders-passwords-refreshed (host-responders host-info))) (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:make-servlet-namespace) - (files:gen-dispatcher host-info))))) + (servlets:gen-dispatcher config:instances config:scripts config:make-servlet-namespace + (paths-servlet (host-paths host-info)) + (responders-servlets-refreshed (host-responders host-info)) + (responders-servlet-loading (host-responders host-info)) + (responders-servlet (host-responders host-info)) + (responders-file-not-found (host-responders host-info)) + (timeouts-servlet-connection (host-timeouts host-info)) + (timeouts-default-servlet (host-timeouts host-info))) + (files:gen-dispatcher (paths-htdocs (host-paths host-info)) + (host-indices host-info) + (responders-file-not-found (host-responders host-info))))))) (define web-server@ (compound-unit/sig