From fa67303a75b22ca2808f53c1dbeff484e2701969 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 13 Jun 2006 14:48:34 +0000 Subject: [PATCH] pr 8028 and 8029 svn: r3347 --- collects/web-server/bindings.ss | 27 ++++ collects/web-server/configuration.ss | 11 ++ collects/web-server/connection-manager.ss | 2 +- .../web-server/dispatchers/dispatch-files.ss | 70 ++++---- .../web-server/dispatchers/dispatch-host.ss | 4 +- .../web-server/dispatchers/dispatch-log.ss | 63 ++++---- .../dispatchers/dispatch-passwords.ss | 75 +++++---- .../dispatchers/dispatch-pathprocedure.ss | 4 +- .../dispatchers/dispatch-sequencer.ss | 4 +- .../dispatchers/dispatch-servlets.ss | 48 +++--- collects/web-server/parse-table.ss | 151 +++++++++--------- collects/web-server/servlet-helpers.ss | 29 +--- collects/web-server/timer.ss | 54 ++++--- collects/web-server/web-server-unit.ss | 61 +++---- 14 files changed, 328 insertions(+), 275 deletions(-) create mode 100644 collects/web-server/bindings.ss diff --git a/collects/web-server/bindings.ss b/collects/web-server/bindings.ss new file mode 100644 index 0000000000..1d8b699be0 --- /dev/null +++ b/collects/web-server/bindings.ss @@ -0,0 +1,27 @@ +(module bindings mzscheme + (require (lib "list.ss")) + (provide extract-binding/single + extract-bindings + exists-binding?) + + ; extract-binding/single : sym (listof (cons str str)) -> str + (define (extract-binding/single name bindings) + (define lst (extract-bindings name bindings)) + (cond + [(empty? lst) + (error 'extract-binding/single "~e not found in ~e" name bindings)] + [(empty? (rest lst)) + (first lst)] + [else + (error 'extract-binding/single "~e occurs multiple times in ~e" name bindings)])) + + ; extract-bindings : sym (listof (cons str str)) -> (listof str) + (define (extract-bindings name bindings) + (map cdr (filter (lambda (x) (equal? name (car x))) bindings))) + + ; exists-binding? : sym (listof (cons sym str)) -> bool + ; for checkboxes + (define (exists-binding? name bindings) + (if (assq name bindings) + #t + #f))) \ No newline at end of file diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss index f56cc8face..b6f3e3022b 100644 --- a/collects/web-server/configuration.ss +++ b/collects/web-server/configuration.ss @@ -21,6 +21,17 @@ [load-configuration (path? . -> . unit/sig?)] [load-developer-configuration (path? . -> . unit/sig?)]) + (provide error-response + servlet-loading-responder + gen-servlet-not-found + gen-servlet-responder + gen-servlets-refreshed + gen-passwords-refreshed + gen-authentication-responder + gen-protocol-responder + gen-file-not-found-responder + gen-collect-garbage-responder) + (define default-configuration-table-path (build-path (collection-path "web-server") "configuration-table")) diff --git a/collects/web-server/connection-manager.ss b/collects/web-server/connection-manager.ss index 59e823e276..a631e4bdb6 100644 --- a/collects/web-server/connection-manager.ss +++ b/collects/web-server/connection-manager.ss @@ -32,7 +32,7 @@ ;; kill-connection!: connection -> void ;; kill this connection - (define (kill-connection! conn-demned) + (define (kill-connection! conn-demned) (cancel-timer! (connection-timer conn-demned)) (with-handlers ([exn:fail:network? void]) (close-output-port (connection-o-port conn-demned))) diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index f79b768954..8fee10ef1f 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -1,46 +1,54 @@ (module dispatch-files mzscheme (require (lib "url.ss" "net") (lib "xml.ss" "xml") + (lib "kw.ss") (lib "list.ss")) (require "dispatch.ss" + "../configuration.ss" "../util.ss" "../mime-types.ss" "../response.ss") (provide interface-version - gen-dispatcher) + make) (define interface-version 'v1) - (define (gen-dispatcher htdocs-path mime-types-path indices file-not-found-responder) - (let ([get-mime-type (make-get-mime-type mime-types-path)]) + (define/kw (make #:key + [htdocs-path "htdocs"] + [mime-types-path "mime.types"] + [indices (list "index.html" "index.htm")] + [file-not-found-responder + (gen-file-not-found-responder "not-found.html")]) + (define get-mime-type (make-get-mime-type mime-types-path)) (lambda (conn req) - (let-values ([(uri method path) (decompose-request req)]) - ;; ************************************************************ - ;; ************************************************************ - ;; 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)])))))) + (define-values (uri method _path) (decompose-request req)) + ;; ************************************************************ + ;; ************************************************************ + ;; SERVING FILES + + ;; serve-file : connection symbol uri host -> void + ;; to find the file, including searching for implicit index files, and serve it out + (define 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/dispatchers/dispatch-host.ss b/collects/web-server/dispatchers/dispatch-host.ss index 7686b92803..572d81aa4b 100644 --- a/collects/web-server/dispatchers/dispatch-host.ss +++ b/collects/web-server/dispatchers/dispatch-host.ss @@ -2,10 +2,10 @@ (require "dispatch.ss" "../servlet-helpers.ss") (provide interface-version - gen-dispatcher) + make) (define interface-version 'v1) - (define (gen-dispatcher lookup-dispatcher) + (define (make lookup-dispatcher) (lambda (conn req) (let* ([host (get-host (request-uri req) (request-headers/raw req))]) ((lookup-dispatcher host) conn req))))) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-log.ss b/collects/web-server/dispatchers/dispatch-log.ss index d95e49b1f5..50b62b6b84 100644 --- a/collects/web-server/dispatchers/dispatch-log.ss +++ b/collects/web-server/dispatchers/dispatch-log.ss @@ -1,15 +1,18 @@ (module dispatch-log mzscheme (require (lib "url.ss" "net") (lib "date.ss") + (lib "kw.ss") (lib "async-channel.ss") (lib "plt-match.ss")) (require "dispatch.ss" "../servlet-helpers.ss") (provide interface-version - gen-dispatcher) + make) (define interface-version 'v1) - (define (gen-dispatcher log-format log-path) + (define/kw (make #:key + [log-format 'parenthesized-default] + [log-path #f]) (if log-path (case log-format [(parenthesized-default) @@ -34,31 +37,31 @@ ; 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 + (define log-ch (make-async-channel)) + (define 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 (current-custodian)) + (async-channel-put log-ch args) + (void)))) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index 8d5269729b..1efa3dfe0d 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -1,42 +1,47 @@ (module dispatch-passwords mzscheme + (require (lib "kw.ss")) (require "dispatch.ss" (all-except "../util.ss" translate-escapes) + "../configuration.ss" "../servlet-helpers.ss" "../connection-manager.ss" - "../response.ss") - + "../response.ss") (provide interface-version - gen-dispatcher) + make) (define interface-version 'v1) - (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/raw 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)]))))) + (define/kw (make #:key + [password-file "passwords"] + [password-connection-timeout 300] + [authentication-responder + (gen-authentication-responder "forbidden.html")] + [passwords-refresh-responder + (gen-passwords-refreshed "passwords-refresh.html")]) + (define password-cache (box #f)) + (define (reset-password-cache!) + ; more here - a malformed password file will kill the connection + (set-box! password-cache (read-passwords password-file))) + (define (read-password-cache) + (unbox password-cache)) + (reset-password-cache!) + (lambda (conn req) + (define-values (uri method path) (decompose-request req)) + (cond + [(access-denied? method path (request-headers/raw 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)]))) ;; **************************************** ;; **************************************** @@ -49,10 +54,10 @@ ;; denied?: str sym str -> (or/c str #f) ;; the return string is the prompt for authentication (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 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) ()) diff --git a/collects/web-server/dispatchers/dispatch-pathprocedure.ss b/collects/web-server/dispatchers/dispatch-pathprocedure.ss index f4b8523030..a6710fc05b 100644 --- a/collects/web-server/dispatchers/dispatch-pathprocedure.ss +++ b/collects/web-server/dispatchers/dispatch-pathprocedure.ss @@ -3,10 +3,10 @@ "../util.ss" "../response.ss") (provide interface-version - gen-dispatcher) + make) (define interface-version 'v1) - (define ((gen-dispatcher the-path procedure) conn req) + (define ((make the-path procedure) conn req) (let-values ([(uri method path) (decompose-request req)]) (if (string=? the-path path) (output-response/method diff --git a/collects/web-server/dispatchers/dispatch-sequencer.ss b/collects/web-server/dispatchers/dispatch-sequencer.ss index 48bf5ca5e9..ade520e799 100644 --- a/collects/web-server/dispatchers/dispatch-sequencer.ss +++ b/collects/web-server/dispatchers/dispatch-sequencer.ss @@ -2,10 +2,10 @@ (require (lib "list.ss")) (require "dispatch.ss") (provide interface-version - gen-dispatcher) + make) (define interface-version 'v1) - (define ((gen-dispatcher . dispatchers) conn req) + (define ((make . dispatchers) conn req) (let loop ([dispatchers dispatchers]) (let ([c (first dispatchers)]) (with-handlers ([exn:dispatcher? diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index b4077aed2f..e50ec2660c 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -1,5 +1,6 @@ (module dispatch-servlets mzscheme (require (lib "url.ss" "net") + (lib "kw.ss") (lib "plt-match.ss") (lib "unitsig.ss")) (require "dispatch.ss" @@ -8,6 +9,7 @@ "../response.ss" "../servlet.ss" "../sig.ss" + "../configuration.ss" (all-except "../util.ss" translate-escapes) "../managers/manager.ss" "../managers/timeouts.ss" @@ -15,14 +17,22 @@ "../private/servlet.ss" "../private/cache-table.ss") (provide interface-version - gen-dispatcher) + make) (define interface-version 'v1) - (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) + (define/kw (make config:instances config:scripts config:make-servlet-namespace + #:key + [servlet-root "servlets"] + [responders-servlets-refreshed + (gen-servlets-refreshed "servlet-refresh.html")] + [responders-servlet-loading + servlet-loading-responder] + [responders-servlet + (gen-servlet-responder "servlet-error.html")] + [responders-file-not-found + (gen-file-not-found-responder "not-found.html")] + [timeouts-servlet-connection (* 60 60 24)] + [timeouts-default-servlet 30]) ;; ************************************************************ ;; ************************************************************ ;; SERVING SERVLETS @@ -47,7 +57,7 @@ (invoke-servlet-continuation conn req instance-id k-id salt)])] [else (servlet-content-producer/path conn req uri)])])) - + ;; 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 @@ -279,9 +289,9 @@ (make-servlet (current-custodian) (current-namespace) (create-timeout-manager - default-servlet-instance-expiration-handler - timeouts-servlet-connection - timeouts-default-servlet) + default-servlet-instance-expiration-handler + timeouts-servlet-connection + timeouts-default-servlet) (v0.servlet->v1.lambda s))] ; FIX - reason about exceptions from dynamic require (catch and report if not already) ;; module servlet @@ -295,9 +305,9 @@ (make-servlet (current-custodian) (current-namespace) (create-timeout-manager - default-servlet-instance-expiration-handler - timeouts-servlet-connection - timeouts-default-servlet) + default-servlet-instance-expiration-handler + timeouts-servlet-connection + timeouts-default-servlet) (v1.module->v1.lambda timeout start)))] [(v2-transitional) ; XXX: Undocumented (let ([start (dynamic-require module-name 'start)] @@ -308,9 +318,9 @@ (define instance-expiration-handler (dynamic-require module-name 'instance-expiration-handler)) (create-timeout-manager - instance-expiration-handler - timeouts-servlet-connection - timeout))]) + instance-expiration-handler + timeouts-servlet-connection + timeout))]) (dynamic-require module-name 'manager))]) (make-servlet (current-custodian) (current-namespace) @@ -323,9 +333,9 @@ (make-servlet (current-custodian) (current-namespace) (create-timeout-manager - default-servlet-instance-expiration-handler - timeouts-servlet-connection - timeouts-default-servlet) + default-servlet-instance-expiration-handler + timeouts-servlet-connection + timeouts-default-servlet) (v0.response->v1.lambda s a-path))] [else (error 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)]))) diff --git a/collects/web-server/parse-table.ss b/collects/web-server/parse-table.ss index d532fd5bb6..58ace328d6 100644 --- a/collects/web-server/parse-table.ss +++ b/collects/web-server/parse-table.ss @@ -1,82 +1,85 @@ (module parse-table mzscheme - (require (lib "match.ss") - "configuration-table-structs.ss") + (require (lib "list.ss")) + (require "configuration-table-structs.ss" + "bindings.ss") (provide parse-configuration-table) - + + (define (get-binding key bindings default) + (first (get-binding* key bindings (list default)))) + + (define (get-binding* key bindings default) + (with-handlers ([exn? (lambda _ default)]) + (extract-binding/single key bindings))) + ; parse-configuration-table : tst -> configuration-table - (define parse-configuration-table - (match-lambda - [`((port ,port) - (max-waiting ,max-waiting) - (initial-connection-timeout ,initial-connection-timeout) - (default-host-table - ,default-host-table) - (virtual-host-table . ,virtual-host-table)) - (if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout) - ; more here - list? isn't really picky enough - (list? virtual-host-table)) - (make-configuration-table - port max-waiting initial-connection-timeout - (parse-host default-host-table) - (map (lambda (h) - (if (and (pair? h) (pair? (cdr h)) (null? (cddr h))) - (cons (car h) (parse-host (cadr h))) - (error 'parse-configuration-table "invalid virtual-host entry ~s" h))) - virtual-host-table)) - (error 'parse-configuration-table "invalid configuration values ~s" - (list port max-waiting initial-connection-timeout default-host-table virtual-host-table)))] - [x (error 'parse-configuration-table "malformed configuration ~s" x)])) + (define (parse-configuration-table t) + (define port (get-binding 'port t 80)) + (define max-waiting (get-binding 'max-waiting t 40)) + (define initial-connection-timeout (get-binding 'initial-connection-timeout t 30)) + (define default-host-table (get-binding* 'default-host-table t `())) + (define virtual-host-table (get-binding* 'virtual-host-table t `())) + (if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout) + ; more here - list? isn't really picky enough + (list? virtual-host-table)) + (make-configuration-table + port max-waiting initial-connection-timeout + (parse-host default-host-table) + (map (lambda (h) + (if (and (pair? h) (pair? (cdr h)) (null? (cddr h))) + (cons (car h) (parse-host (cadr h))) + (error 'parse-configuration-table "invalid virtual-host entry ~s" h))) + virtual-host-table)) + (error 'parse-configuration-table "invalid configuration values ~s" + (list port max-waiting initial-connection-timeout default-host-table virtual-host-table)))) ; parse-host : tst -> host-table - (define parse-host - (match-lambda - [`(host-table - (default-indices . ,default-indices) - (log-format ,log-format) - (messages - (servlet-message ,servlet-message) - (authentication-message ,authentication-message) - (servlets-refreshed ,servlets-refreshed) - (passwords-refreshed ,passwords-refreshed) - (file-not-found-message ,file-not-found-message) - (protocol-message ,protocol-message) - (collect-garbage ,collect-garbage)) - (timeouts - (default-servlet-timeout ,default-servlet-timeout) - (password-connection-timeout ,password-connection-timeout) - (servlet-connection-timeout ,servlet-connection-timeout) - (file-per-byte-connection-timeout ,file-per-byte-connection-timeout) - (file-base-connection-timeout ,file-base-connection-timeout)) - (paths - (configuration-root ,configuration-root) - (host-root ,host-root) - (log-file-path ,log-file-path) - (file-root ,file-root) - (servlet-root ,servlet-root) - (mime-types ,mime-types) - (password-authentication ,password-authentication))) - (make-host-table - default-indices log-format - (make-messages servlet-message - authentication-message - servlets-refreshed - passwords-refreshed - file-not-found-message - protocol-message - collect-garbage) - (make-timeouts default-servlet-timeout - password-connection-timeout - servlet-connection-timeout - file-per-byte-connection-timeout - file-base-connection-timeout) - (make-paths configuration-root - host-root - log-file-path - file-root - servlet-root - mime-types - password-authentication))] - [x (error 'parse-host "malformed host ~s" x)])) + (define (parse-host t) + (define host-table (get-binding* 'host-table t `())) + (define default-indices (get-binding* 'default-indices host-table `("index.html" "index.htm"))) + (define log-format (get-binding 'log-format host-table 'parenthesized-default)) + (define messages (get-binding* 'messages host-table `())) + (define servlet-message (get-binding 'servlet-message messages "servlet-error.html")) + (define authentication-message (get-binding 'authentication-message messages "forbidden.html")) + (define servlets-refreshed (get-binding 'servlets-refreshed messages "servlet-refresh.html")) + (define passwords-refreshed (get-binding 'passwords-refreshed messages "passwords-refresh.html")) + (define file-not-found-message (get-binding 'file-not-found-message messages "not-found.html")) + (define protocol-message (get-binding 'protocol-message messages "protocol-error.html")) + (define collect-garbage (get-binding 'collect-garbage messages "collect-garbage.html")) + (define timeouts (get-binding* 'timeouts host-table `())) + (define default-servlet-timeout (get-binding 'default-servlet-timeout timeouts 30)) + (define password-connection-timeout (get-binding 'password-connection-timeout timeouts 300)) + (define servlet-connection-timeout (get-binding 'servlet-connection-timeout timeouts (* 60 60 24))) + (define file-per-byte-connection-timeout (get-binding 'file-per-byte-connection-timeout timeouts 1/20)) + (define file-base-connection-timeout (get-binding 'file-base-connection-timeout timeouts 30)) + (define paths (get-binding* 'paths host-table `())) + (define configuration-root (get-binding 'configuration-root paths "conf")) + (define host-root (get-binding 'host-root paths "default-web-root")) + (define log-file-path (get-binding 'log-file-path paths "log")) + (define file-root (get-binding 'file-root paths "htdocs")) + (define servlet-root (get-binding 'servlet-root paths ".")) + (define mime-types (get-binding 'mime-types paths "mime.types")) + (define password-authentication (get-binding 'password-authentication paths "passwords")) + (make-host-table + default-indices log-format + (make-messages servlet-message + authentication-message + servlets-refreshed + passwords-refreshed + file-not-found-message + protocol-message + collect-garbage) + (make-timeouts default-servlet-timeout + password-connection-timeout + servlet-connection-timeout + file-per-byte-connection-timeout + file-base-connection-timeout) + (make-paths configuration-root + host-root + log-file-path + file-root + servlet-root + mime-types + password-authentication))) ; nat? : tst -> bool (define (nat? x) diff --git a/collects/web-server/servlet-helpers.ss b/collects/web-server/servlet-helpers.ss index 6826e1b75f..2c23bb5936 100644 --- a/collects/web-server/servlet-helpers.ss +++ b/collects/web-server/servlet-helpers.ss @@ -7,11 +7,10 @@ (lib "url.ss" "net")) (require "util.ss" "response.ss" - "request-structs.ss") + "request-structs.ss" + "bindings.ss") (provide get-host - extract-binding/single - extract-bindings - exists-binding? + (all-from "bindings.ss") extract-user-pass build-suspender make-html-response/incremental @@ -52,27 +51,7 @@ [(struct header (_ v)) (string->symbol (bytes->string/utf-8 v))])] [else DEFAULT-HOST-NAME])) - - ; extract-binding/single : sym (listof (cons str str)) -> str - (define (extract-binding/single name bindings) - (let ([lst (extract-bindings name bindings)]) - (cond - [(null? lst) - (error 'extract-binding/single "~e not found in ~e" name bindings)] - [(null? (cdr lst)) (car lst)] - [else (error 'extract-binding/single "~e occurs multiple times in ~e" name bindings)]))) - - ; extract-bindings : sym (listof (cons str str)) -> (listof str) - (define (extract-bindings name bindings) - (map cdr (filter (lambda (x) (equal? name (car x))) bindings))) - - ; exists-binding? : sym (listof (cons sym str)) -> bool - ; for checkboxes - (define (exists-binding? name bindings) - (if (assq name bindings) - #t - #f)) - + ; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response (define build-suspender (opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null]) diff --git a/collects/web-server/timer.ss b/collects/web-server/timer.ss index ca6fd2f332..c0a7fce8e6 100644 --- a/collects/web-server/timer.ss +++ b/collects/web-server/timer.ss @@ -6,9 +6,9 @@ start-timer reset-timer! increment-timer! cancel-timer! start-timer-manager) - + (define timer-ch (make-async-channel)) - + ; start-timer-manager : custodian -> void ; The timer manager thread (define (start-timer-manager server-custodian) @@ -35,42 +35,46 @@ (loop (remq timer timers))))) timers)))))) (void)) - + ;; Limitation on this add-timer: thunk cannot make timer ;; requests directly, because it's executed directly by ;; the timer-manager thread ;; add-timer : number (-> void) -> timer (define (add-timer msecs thunk) - (let* ([now (current-inexact-milliseconds)] - [timer - (make-timer (alarm-evt (+ now msecs)) - (+ now msecs) - thunk)]) - (async-channel-put timer-ch - (lambda (timers) - (cons timer timers))) - timer)) - + (define now (current-inexact-milliseconds)) + (define timer + (make-timer (alarm-evt (+ now msecs)) + (+ now msecs) + thunk)) + (async-channel-put + timer-ch + (lambda (timers) + (list* timer timers))) + timer) + ; revise-timer! : timer msecs (-> void) -> timer ; revise the timer to ring msecs from now (define (revise-timer! timer msecs thunk) - (let ([now (current-inexact-milliseconds)]) - (async-channel-put - timer-ch - (lambda (timers) - (set-timer-evt! timer (alarm-evt (+ now msecs))) - (set-timer-expire-seconds! timer (+ now msecs)) - (set-timer-action! timer thunk) - timers)))) - + (define now (current-inexact-milliseconds)) + (async-channel-put + timer-ch + (lambda (timers) + (set-timer-evt! timer (alarm-evt (+ now msecs))) + (set-timer-expire-seconds! timer (+ now msecs)) + (set-timer-action! timer thunk) + timers))) + (define (cancel-timer! timer) - (revise-timer! timer 0 void)) - + (async-channel-put + timer-ch + (lambda (timers) + (remq timer timers)))) + ; start-timer : num (-> void) -> timer ; to make a timer that calls to-do after sec from make-timer's application (define (start-timer secs to-do) (add-timer (* 1000 secs) to-do)) - + ; reset-timer : timer num -> void ; to cause timer to expire after sec from the adjust-msec-to-live's application (define (reset-timer! timer secs) diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 3445467620..71f298b20f 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -17,7 +17,9 @@ (require (lib "tcp-sig.ss" "net") (lib "unitsig.ss") (lib "string.ss") + (lib "list.ss") (lib "url.ss" "net")) + (provide web-server@) ;; **************************************** @@ -123,41 +125,42 @@ (define initial-connection-timeout config:initial-connection-timeout) ;; dispatch : connection request -> void + (define dispatch-cache (make-cache-table)) (define dispatch - (let ([cache (make-cache-table)]) - (host:gen-dispatcher - (lambda (host) - (cache-table-lookup! - cache host - (lambda () + (host:make + (lambda (host) + (cache-table-lookup! + dispatch-cache host + (lambda () + (parameterize ([current-custodian (current-server-custodian)]) (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 - (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 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)) - (paths-mime-types (host-paths host-info)) - (host-indices host-info) - (responders-file-not-found (host-responders host-info))))))) + (sequencer:make + (log:make #:log-format (host-log-format host-info) + #:log-path (host-log-path host-info)) + (passwords:make #:password-file (host-passwords host-info) + #:password-connection-timeout (timeouts-password (host-timeouts host-info)) + #:authentication-responder (responders-authentication (host-responders host-info)) + #:passwords-refresh-responder (responders-passwords-refreshed (host-responders host-info))) + (path-procedure:make "/conf/collect-garbage" + (lambda () + (collect-garbage) + ((responders-collect-garbage (host-responders host-info))))) + (servlets:make config:instances config:scripts config:make-servlet-namespace + #:servlet-root (paths-servlet (host-paths host-info)) + #:responders-servlets-refreshed (responders-servlets-refreshed (host-responders host-info)) + #:responders-servlet-loading (responders-servlet-loading (host-responders host-info)) + #:responders-servlet (responders-servlet (host-responders host-info)) + #:responders-file-not-found (responders-file-not-found (host-responders host-info)) + #:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info)) + #:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info))) + (files:make #:htdocs-path (paths-htdocs (host-paths host-info)) + #:mime-types-path (paths-mime-types (host-paths host-info)) + #:indices (host-indices host-info) + #:file-not-found-responder (responders-file-not-found (host-responders host-info))))))) (define web-server@ (compound-unit/sig